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
(Bod
: Node_Id
; E
: Entity_Id
);
480 -- Reset the scope of declarations and blocks at the top level of Bod
481 -- to be E. Bod is either a block or a subprogram body. Used after
482 -- expanding various kinds of entry bodies into their corresponding
483 -- constructs. This is needed during unnesting to determine whether a
484 -- body geenrated for an entry or an accept alternative includes uplevel
487 function Trivial_Accept_OK
return Boolean;
488 -- If there is no DO-END block for an accept, or if the DO-END block has
489 -- only null statements, then it is possible to do the Rendezvous with much
490 -- less overhead using the Accept_Trivial routine in the run-time library.
491 -- However, this is not always a valid optimization. Whether it is valid or
492 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
493 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
494 -- a rescheduling is required, so this optimization is not allowed. This
495 -- function returns True if the optimization is permitted.
497 -----------------------------
498 -- Actual_Index_Expression --
499 -----------------------------
501 function Actual_Index_Expression
505 Tsk
: Entity_Id
) return Node_Id
507 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
515 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
516 -- Compute difference between bounds of entry family
518 --------------------------
519 -- Actual_Family_Offset --
520 --------------------------
522 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
524 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
525 -- Replace a reference to a discriminant with a selected component
526 -- denoting the discriminant of the target task.
528 -----------------------------
529 -- Actual_Discriminant_Ref --
530 -----------------------------
532 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
533 Typ
: constant Entity_Id
:= Etype
(Bound
);
537 if not Is_Entity_Name
(Bound
)
538 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
540 if Nkind
(Bound
) = N_Attribute_Reference
then
543 B
:= New_Copy_Tree
(Bound
);
548 Make_Selected_Component
(Sloc
,
549 Prefix
=> New_Copy_Tree
(Tsk
),
550 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
552 Analyze_And_Resolve
(B
, Typ
);
556 Make_Attribute_Reference
(Sloc
,
557 Attribute_Name
=> Name_Pos
,
558 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
559 Expressions
=> New_List
(B
));
560 end Actual_Discriminant_Ref
;
562 -- Start of processing for Actual_Family_Offset
566 Make_Op_Subtract
(Sloc
,
567 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
568 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
569 end Actual_Family_Offset
;
571 -- Start of processing for Actual_Index_Expression
574 -- The queues of entries and entry families appear in textual order in
575 -- the associated record. The entry index is computed as the sum of the
576 -- number of queues for all entries that precede the designated one, to
577 -- which is added the index expression, if this expression denotes a
578 -- member of a family.
580 -- The following is a place holder for the count of simple entries
582 Num
:= Make_Integer_Literal
(Sloc
, 1);
584 -- We construct an expression which is a series of addition operations.
585 -- See comments in Entry_Index_Expression, which is identical in
588 if Present
(Index
) then
589 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
595 Actual_Family_Offset
(
596 Make_Attribute_Reference
(Sloc
,
597 Attribute_Name
=> Name_Pos
,
598 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
599 Expressions
=> New_List
(Relocate_Node
(Index
))),
600 Type_Low_Bound
(S
)));
605 -- Now add lengths of preceding entries and entry families
607 Prev
:= First_Entity
(Ttyp
);
608 while Chars
(Prev
) /= Chars
(Ent
)
609 or else (Ekind
(Prev
) /= Ekind
(Ent
))
610 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
612 if Ekind
(Prev
) = E_Entry
then
613 Set_Intval
(Num
, Intval
(Num
) + 1);
615 elsif Ekind
(Prev
) = E_Entry_Family
then
617 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
619 -- The need for the following full view retrieval stems from this
620 -- complex case of nested generics and tasking:
623 -- type Formal_Index is range <>;
626 -- type Index is private;
633 -- type Index is new Formal_Index range 1 .. 10;
636 -- package body Outer is
638 -- entry Fam (Index); -- (2)
641 -- package body Inner is -- (3)
649 -- We are currently building the index expression for the entry
650 -- call "T.E" (1). Part of the expansion must mention the range
651 -- of the discrete type "Index" (2) of entry family "Fam".
653 -- However only the private view of type "Index" is available to
654 -- the inner generic (3) because there was no prior mention of
655 -- the type inside "Inner". This visibility requirement is
656 -- implicit and cannot be detected during the construction of
657 -- the generic trees and needs special handling.
660 and then Is_Private_Type
(S
)
661 and then Present
(Full_View
(S
))
666 Lo
:= Type_Low_Bound
(S
);
667 Hi
:= Type_High_Bound
(S
);
674 Left_Opnd
=> Actual_Family_Offset
(Hi
, Lo
),
675 Right_Opnd
=> Make_Integer_Literal
(Sloc
, 1)));
677 -- Other components are anonymous types to be ignored
687 end Actual_Index_Expression
;
689 --------------------------
690 -- Add_Formal_Renamings --
691 --------------------------
693 procedure Add_Formal_Renamings
699 Ptr
: constant Entity_Id
:=
701 (Next
(First
(Parameter_Specifications
(Spec
))));
702 -- The name of the formal that holds the address of the parameter block
709 Renamed_Formal
: Node_Id
;
712 Formal
:= First_Formal
(Ent
);
713 while Present
(Formal
) loop
714 Comp
:= Entry_Component
(Formal
);
716 Make_Defining_Identifier
(Sloc
(Formal
),
717 Chars
=> Chars
(Formal
));
718 Set_Etype
(New_F
, Etype
(Formal
));
719 Set_Scope
(New_F
, Ent
);
721 -- Now we set debug info needed on New_F even though it does not come
722 -- from source, so that the debugger will get the right information
723 -- for these generated names.
725 Set_Debug_Info_Needed
(New_F
);
727 if Ekind
(Formal
) = E_In_Parameter
then
728 Set_Ekind
(New_F
, E_Constant
);
730 Set_Ekind
(New_F
, E_Variable
);
731 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
734 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
737 Make_Selected_Component
(Loc
,
739 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
740 Make_Identifier
(Loc
, Chars
(Ptr
))),
741 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
744 Build_Renamed_Formal_Declaration
745 (New_F
, Formal
, Comp
, Renamed_Formal
);
747 Append
(Decl
, Decls
);
748 Set_Renamed_Object
(Formal
, New_F
);
749 Next_Formal
(Formal
);
751 end Add_Formal_Renamings
;
753 ------------------------
754 -- Add_Object_Pointer --
755 ------------------------
757 procedure Add_Object_Pointer
759 Conc_Typ
: Entity_Id
;
762 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
767 -- Create the renaming declaration for the Protection object of a
768 -- protected type. _Object is used by Complete_Entry_Body.
769 -- ??? An attempt to make this a renaming was unsuccessful.
771 -- Build the entity for the access type
774 Make_Defining_Identifier
(Loc
,
775 New_External_Name
(Chars
(Rec_Typ
), 'P'));
778 -- _object : poVP := poVP!O;
781 Make_Object_Declaration
(Loc
,
782 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uObject
),
783 Object_Definition
=> New_Occurrence_Of
(Obj_Ptr
, Loc
),
785 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
786 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
787 Prepend_To
(Decls
, Decl
);
790 -- type poVP is access poV;
793 Make_Full_Type_Declaration
(Loc
,
794 Defining_Identifier
=>
797 Make_Access_To_Object_Definition
(Loc
,
798 Subtype_Indication
=>
799 New_Occurrence_Of
(Rec_Typ
, Loc
)));
800 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
801 Prepend_To
(Decls
, Decl
);
802 end Add_Object_Pointer
;
804 -----------------------
805 -- Build_Accept_Body --
806 -----------------------
808 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
809 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
810 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
817 -- At the end of the statement sequence, Complete_Rendezvous is called.
818 -- A label skipping the Complete_Rendezvous, and all other accept
819 -- processing, has already been added for the expansion of requeue
820 -- statements. The Sloc is copied from the last statement since it
821 -- is really part of this last statement.
825 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
826 Insert_Before
(Last
(Statements
(Stats
)), Call
);
829 -- If exception handlers are present, then append Complete_Rendezvous
830 -- calls to the handlers, and construct the required outer block. As
831 -- above, the Sloc is copied from the last statement in the sequence.
833 if Present
(Exception_Handlers
(Stats
)) then
834 Hand
:= First
(Exception_Handlers
(Stats
));
835 while Present
(Hand
) loop
838 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
839 Append
(Call
, Statements
(Hand
));
845 Make_Handled_Sequence_Of_Statements
(Loc
,
846 Statements
=> New_List
(
847 Make_Block_Statement
(Loc
,
848 Handled_Statement_Sequence
=> Stats
)));
854 -- At this stage we know that the new statement sequence does
855 -- not have an exception handler part, so we supply one to call
856 -- Exceptional_Complete_Rendezvous. This handler is
858 -- when all others =>
859 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
861 -- We handle Abort_Signal to make sure that we properly catch the abort
862 -- case and wake up the caller.
864 Ohandle
:= Make_Others_Choice
(Loc
);
865 Set_All_Others
(Ohandle
);
867 Set_Exception_Handlers
(New_S
,
869 Make_Implicit_Exception_Handler
(Loc
,
870 Exception_Choices
=> New_List
(Ohandle
),
872 Statements
=> New_List
(
873 Make_Procedure_Call_Statement
(Sloc
(Stats
),
874 Name
=> New_Occurrence_Of
(
875 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
876 Parameter_Associations
=> New_List
(
877 Make_Function_Call
(Sloc
(Stats
),
880 (RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
882 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
883 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
884 Expand_Exception_Handlers
(New_S
);
886 -- Exceptional_Complete_Rendezvous must be called with abort still
887 -- deferred, which is the case for a "when all others" handler.
890 end Build_Accept_Body
;
892 -----------------------------------
893 -- Build_Activation_Chain_Entity --
894 -----------------------------------
896 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
897 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean;
898 -- Determine whether an extended return statement has activation chain
900 --------------------------
901 -- Has_Activation_Chain --
902 --------------------------
904 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean is
908 Decl
:= First
(Return_Object_Declarations
(Stmt
));
909 while Present
(Decl
) loop
910 if Nkind
(Decl
) = N_Object_Declaration
911 and then Chars
(Defining_Identifier
(Decl
)) = Name_uChain
920 end Has_Activation_Chain
;
925 Context_Id
: Entity_Id
;
928 -- Start of processing for Build_Activation_Chain_Entity
931 -- Activation chain is never used for sequential elaboration policy, see
932 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
934 if Partition_Elaboration_Policy
= 'S' then
938 Find_Enclosing_Context
(N
, Context
, Context_Id
, Decls
);
940 -- If activation chain entity has not been declared already, create one
942 if Nkind
(Context
) = N_Extended_Return_Statement
943 or else No
(Activation_Chain_Entity
(Context
))
945 -- Since extended return statements do not store the entity of the
946 -- chain, examine the return object declarations to avoid creating
949 if Nkind
(Context
) = N_Extended_Return_Statement
950 and then Has_Activation_Chain
(Context
)
956 Loc
: constant Source_Ptr
:= Sloc
(Context
);
961 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
963 -- Note: An extended return statement is not really a task
964 -- activator, but it does have an activation chain on which to
965 -- store the tasks temporarily. On successful return, the tasks
966 -- on this chain are moved to the chain passed in by the caller.
967 -- We do not build an Activation_Chain_Entity for an extended
968 -- return statement, because we do not want to build a call to
969 -- Activate_Tasks. Task activation is the responsibility of the
972 if Nkind
(Context
) /= N_Extended_Return_Statement
then
973 Set_Activation_Chain_Entity
(Context
, Chain
);
977 Make_Object_Declaration
(Loc
,
978 Defining_Identifier
=> Chain
,
979 Aliased_Present
=> True,
981 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
));
983 Prepend_To
(Decls
, Decl
);
985 -- Ensure that _chain appears in the proper scope of the context
987 if Context_Id
/= Current_Scope
then
988 Push_Scope
(Context_Id
);
996 end Build_Activation_Chain_Entity
;
998 ----------------------------
999 -- Build_Barrier_Function --
1000 ----------------------------
1002 function Build_Barrier_Function
1005 Pid
: Node_Id
) return Node_Id
1007 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
1008 Cond
: constant Node_Id
:= Condition
(Ent_Formals
);
1009 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
1010 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
1011 Op_Decls
: constant List_Id
:= New_List
;
1013 Func_Body
: Node_Id
;
1016 -- Add a declaration for the Protection object, renaming declarations
1017 -- for the discriminals and privals and finally a declaration for the
1018 -- entry family index (if applicable).
1020 Install_Private_Data_Declarations
(Sloc
(N
),
1026 Family
=> Ekind
(Ent
) = E_Entry_Family
);
1028 -- If compiling with -fpreserve-control-flow, make sure we insert an
1029 -- IF statement so that the back-end knows to generate a conditional
1030 -- branch instruction, even if the condition is just the name of a
1031 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1032 -- such redundant IF statements under -fpreserve-control-flow
1033 -- (whether coming from this routine, or directly from source).
1035 if Opt
.Suppress_Control_Flow_Optimizations
then
1037 Make_Implicit_If_Statement
(Cond
,
1039 Then_Statements
=> New_List
(
1040 Make_Simple_Return_Statement
(Loc
,
1041 New_Occurrence_Of
(Standard_True
, Loc
))),
1043 Else_Statements
=> New_List
(
1044 Make_Simple_Return_Statement
(Loc
,
1045 New_Occurrence_Of
(Standard_False
, Loc
))));
1048 Stmt
:= Make_Simple_Return_Statement
(Loc
, Cond
);
1051 -- Note: the condition in the barrier function needs to be properly
1052 -- processed for the C/Fortran boolean possibility, but this happens
1053 -- automatically since the return statement does this normalization.
1056 Make_Subprogram_Body
(Loc
,
1058 Build_Barrier_Function_Specification
(Loc
,
1059 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
1060 Declarations
=> Op_Decls
,
1061 Handled_Statement_Sequence
=>
1062 Make_Handled_Sequence_Of_Statements
(Loc
,
1063 Statements
=> New_List
(Stmt
)));
1064 Set_Is_Entry_Barrier_Function
(Func_Body
);
1067 end Build_Barrier_Function
;
1069 ------------------------------------------
1070 -- Build_Barrier_Function_Specification --
1071 ------------------------------------------
1073 function Build_Barrier_Function_Specification
1075 Def_Id
: Entity_Id
) return Node_Id
1078 Set_Debug_Info_Needed
(Def_Id
);
1081 Make_Function_Specification
(Loc
,
1082 Defining_Unit_Name
=> Def_Id
,
1083 Parameter_Specifications
=> New_List
(
1084 Make_Parameter_Specification
(Loc
,
1085 Defining_Identifier
=>
1086 Make_Defining_Identifier
(Loc
, Name_uO
),
1088 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
1090 Make_Parameter_Specification
(Loc
,
1091 Defining_Identifier
=>
1092 Make_Defining_Identifier
(Loc
, Name_uE
),
1094 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
1096 Result_Definition
=>
1097 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1098 end Build_Barrier_Function_Specification
;
1100 --------------------------
1101 -- Build_Call_With_Task --
1102 --------------------------
1104 function Build_Call_With_Task
1106 E
: Entity_Id
) return Node_Id
1108 Loc
: constant Source_Ptr
:= Sloc
(N
);
1111 Make_Function_Call
(Loc
,
1112 Name
=> New_Occurrence_Of
(E
, Loc
),
1113 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
1114 end Build_Call_With_Task
;
1116 -----------------------------
1117 -- Build_Class_Wide_Master --
1118 -----------------------------
1120 procedure Build_Class_Wide_Master
(Typ
: Entity_Id
) is
1121 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1122 Master_Decl
: Node_Id
;
1123 Master_Id
: Entity_Id
;
1124 Master_Scope
: Entity_Id
;
1126 Related_Node
: Node_Id
;
1130 -- Nothing to do if there is no task hierarchy
1132 if Restriction_Active
(No_Task_Hierarchy
) then
1136 -- Find the declaration that created the access type, which is either a
1137 -- type declaration, or an object declaration with an access definition,
1138 -- in which case the type is anonymous.
1140 if Is_Itype
(Typ
) then
1141 Related_Node
:= Associated_Node_For_Itype
(Typ
);
1143 Related_Node
:= Parent
(Typ
);
1146 Master_Scope
:= Find_Master_Scope
(Typ
);
1148 -- Nothing to do if the master scope already contains a _master entity.
1149 -- The only exception to this is the following scenario:
1152 -- Transient_Scope_1
1155 -- Transient_Scope_2
1158 -- In this case the source scope is marked as having the master entity
1159 -- even though the actual declaration appears inside an inner scope. If
1160 -- the second transient scope requires a _master, it cannot use the one
1161 -- already declared because the entity is not visible.
1163 Name_Id
:= Make_Identifier
(Loc
, Name_uMaster
);
1164 Master_Decl
:= Empty
;
1166 if not Has_Master_Entity
(Master_Scope
)
1167 or else No
(Current_Entity_In_Scope
(Name_Id
))
1170 Set_Has_Master_Entity
(Master_Scope
);
1173 -- _master : constant Integer := Current_Master.all;
1176 Make_Object_Declaration
(Loc
,
1177 Defining_Identifier
=>
1178 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1179 Constant_Present
=> True,
1180 Object_Definition
=>
1181 New_Occurrence_Of
(Standard_Integer
, Loc
),
1183 Make_Explicit_Dereference
(Loc
,
1184 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
1186 Insert_Action
(Find_Hook_Context
(Related_Node
), Master_Decl
);
1187 Analyze
(Master_Decl
);
1189 -- Mark the containing scope as a task master. Masters associated
1190 -- with return statements are already marked at this stage (see
1191 -- Analyze_Subprogram_Body).
1193 if Ekind
(Current_Scope
) /= E_Return_Statement
then
1195 Par
: Node_Id
:= Related_Node
;
1198 while Nkind
(Par
) /= N_Compilation_Unit
loop
1199 Par
:= Parent
(Par
);
1201 -- If we fall off the top, we are at the outer level,
1202 -- and the environment task is our effective master,
1203 -- so nothing to mark.
1205 if Nkind_In
(Par
, N_Block_Statement
,
1209 Set_Is_Task_Master
(Par
);
1219 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(Typ
), 'M'));
1222 -- typeMnn renames _master;
1225 Make_Object_Renaming_Declaration
(Loc
,
1226 Defining_Identifier
=> Master_Id
,
1227 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
1230 -- If the master is declared locally, add the renaming declaration
1231 -- immediately after it, to prevent access-before-elaboration in the
1234 if Present
(Master_Decl
) then
1235 Insert_After
(Master_Decl
, Ren_Decl
);
1239 Insert_Action
(Related_Node
, Ren_Decl
);
1242 Set_Master_Id
(Typ
, Master_Id
);
1243 end Build_Class_Wide_Master
;
1245 ----------------------------
1246 -- Build_Contract_Wrapper --
1247 ----------------------------
1249 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1250 Conc_Typ
: constant Entity_Id
:= Scope
(E
);
1251 Loc
: constant Source_Ptr
:= Sloc
(E
);
1253 procedure Add_Discriminant_Renamings
1254 (Obj_Id
: Entity_Id
;
1256 -- Add renaming declarations for all discriminants of concurrent type
1257 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1258 -- represents the concurrent object.
1260 procedure Add_Matching_Formals
1262 Actuals
: in out List_Id
);
1263 -- Add formal parameters that match those of entry E to list Formals.
1264 -- The routine also adds matching actuals for the new formals to list
1267 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
);
1268 -- Relocate pragma Prag to list To. The routine creates a new list if
1269 -- To does not exist.
1271 --------------------------------
1272 -- Add_Discriminant_Renamings --
1273 --------------------------------
1275 procedure Add_Discriminant_Renamings
1276 (Obj_Id
: Entity_Id
;
1282 -- Inspect the discriminants of the concurrent type and generate a
1283 -- renaming for each one.
1285 if Has_Discriminants
(Conc_Typ
) then
1286 Discr
:= First_Discriminant
(Conc_Typ
);
1287 while Present
(Discr
) loop
1289 Make_Object_Renaming_Declaration
(Loc
,
1290 Defining_Identifier
=>
1291 Make_Defining_Identifier
(Loc
, Chars
(Discr
)),
1293 New_Occurrence_Of
(Etype
(Discr
), Loc
),
1295 Make_Selected_Component
(Loc
,
1296 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1298 Make_Identifier
(Loc
, Chars
(Discr
)))));
1300 Next_Discriminant
(Discr
);
1303 end Add_Discriminant_Renamings
;
1305 --------------------------
1306 -- Add_Matching_Formals --
1307 --------------------------
1309 procedure Add_Matching_Formals
1311 Actuals
: in out List_Id
)
1314 New_Formal
: Entity_Id
;
1317 -- Inspect the formal parameters of the entry and generate a new
1318 -- matching formal with the same name for the wrapper. A reference
1319 -- to the new formal becomes an actual in the entry call.
1321 Formal
:= First_Formal
(E
);
1322 while Present
(Formal
) loop
1323 New_Formal
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1325 Make_Parameter_Specification
(Loc
,
1326 Defining_Identifier
=> New_Formal
,
1327 In_Present
=> In_Present
(Parent
(Formal
)),
1328 Out_Present
=> Out_Present
(Parent
(Formal
)),
1330 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
1332 if No
(Actuals
) then
1333 Actuals
:= New_List
;
1336 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
1337 Next_Formal
(Formal
);
1339 end Add_Matching_Formals
;
1341 ---------------------
1342 -- Transfer_Pragma --
1343 ---------------------
1345 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
) is
1353 New_Prag
:= Relocate_Node
(Prag
);
1355 Set_Analyzed
(New_Prag
, False);
1356 Append
(New_Prag
, To
);
1357 end Transfer_Pragma
;
1361 Items
: constant Node_Id
:= Contract
(E
);
1362 Actuals
: List_Id
:= No_List
;
1365 Decls
: List_Id
:= No_List
;
1367 Has_Pragma
: Boolean := False;
1368 Index_Id
: Entity_Id
;
1371 Wrapper_Id
: Entity_Id
;
1373 -- Start of processing for Build_Contract_Wrapper
1376 -- This routine generates a specialized wrapper for a protected or task
1377 -- entry [family] which implements precondition/postcondition semantics.
1378 -- Preconditions and case guards of contract cases are checked before
1379 -- the protected action or rendezvous takes place. Postconditions and
1380 -- consequences of contract cases are checked after the protected action
1381 -- or rendezvous takes place. The structure of the generated wrapper is
1384 -- procedure Wrapper
1385 -- (Obj_Id : Conc_Typ; -- concurrent object
1386 -- [Index : Index_Typ;] -- index of entry family
1387 -- [Formal_1 : ...; -- parameters of original entry
1390 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1391 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1393 -- <precondition checks>
1394 -- <case guard checks>
1396 -- procedure _Postconditions is
1398 -- <postcondition checks>
1399 -- <consequence checks>
1400 -- end _Postconditions;
1403 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1407 -- Create the wrapper only when the entry has at least one executable
1408 -- contract item such as contract cases, precondition or postcondition.
1410 if Present
(Items
) then
1412 -- Inspect the list of pre/postconditions and transfer all available
1413 -- pragmas to the declarative list of the wrapper.
1415 Prag
:= Pre_Post_Conditions
(Items
);
1416 while Present
(Prag
) loop
1417 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
1418 Name_Postcondition
, Name_Precondition
)
1419 and then Is_Checked
(Prag
)
1422 Transfer_Pragma
(Prag
, To
=> Decls
);
1425 Prag
:= Next_Pragma
(Prag
);
1428 -- Inspect the list of test/contract cases and transfer only contract
1429 -- cases pragmas to the declarative part of the wrapper.
1431 Prag
:= Contract_Test_Cases
(Items
);
1432 while Present
(Prag
) loop
1433 if Pragma_Name
(Prag
) = Name_Contract_Cases
1434 and then Is_Checked
(Prag
)
1437 Transfer_Pragma
(Prag
, To
=> Decls
);
1440 Prag
:= Next_Pragma
(Prag
);
1444 -- The entry lacks executable contract items and a wrapper is not needed
1446 if not Has_Pragma
then
1450 -- Create the profile of the wrapper. The first formal parameter is the
1451 -- concurrent object.
1454 Make_Defining_Identifier
(Loc
,
1455 Chars
=> New_External_Name
(Chars
(Conc_Typ
), 'A'));
1457 Formals
:= New_List
(
1458 Make_Parameter_Specification
(Loc
,
1459 Defining_Identifier
=> Obj_Id
,
1460 Out_Present
=> True,
1462 Parameter_Type
=> New_Occurrence_Of
(Conc_Typ
, Loc
)));
1464 -- Construct the call to the original entry. The call will be gradually
1465 -- augmented with an optional entry index and extra parameters.
1468 Make_Selected_Component
(Loc
,
1469 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1470 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1472 -- When creating a wrapper for an entry family, the second formal is the
1475 if Ekind
(E
) = E_Entry_Family
then
1476 Index_Id
:= Make_Defining_Identifier
(Loc
, Name_I
);
1479 Make_Parameter_Specification
(Loc
,
1480 Defining_Identifier
=> Index_Id
,
1482 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1484 -- The call to the original entry becomes an indexed component to
1485 -- accommodate the entry index.
1488 Make_Indexed_Component
(Loc
,
1490 Expressions
=> New_List
(New_Occurrence_Of
(Index_Id
, Loc
)));
1493 -- Add formal parameters to match those of the entry and build actuals
1494 -- for the entry call.
1496 Add_Matching_Formals
(Formals
, Actuals
);
1499 Make_Procedure_Call_Statement
(Loc
,
1501 Parameter_Associations
=> Actuals
);
1503 -- Add renaming declarations for the discriminants of the enclosing type
1504 -- as the various contract items may reference them.
1506 Add_Discriminant_Renamings
(Obj_Id
, Decls
);
1509 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(E
), 'E'));
1510 Set_Contract_Wrapper
(E
, Wrapper_Id
);
1511 Set_Is_Entry_Wrapper
(Wrapper_Id
);
1513 -- The wrapper body is analyzed when the enclosing type is frozen
1515 Append_Freeze_Action
(Defining_Entity
(Decl
),
1516 Make_Subprogram_Body
(Loc
,
1518 Make_Procedure_Specification
(Loc
,
1519 Defining_Unit_Name
=> Wrapper_Id
,
1520 Parameter_Specifications
=> Formals
),
1521 Declarations
=> Decls
,
1522 Handled_Statement_Sequence
=>
1523 Make_Handled_Sequence_Of_Statements
(Loc
,
1524 Statements
=> New_List
(Call
))));
1525 end Build_Contract_Wrapper
;
1527 --------------------------------
1528 -- Build_Corresponding_Record --
1529 --------------------------------
1531 function Build_Corresponding_Record
1534 Loc
: Source_Ptr
) return Node_Id
1536 Rec_Ent
: constant Entity_Id
:=
1537 Make_Defining_Identifier
1538 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1541 New_Disc
: Entity_Id
;
1545 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1546 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1547 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1548 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1549 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1550 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1553 -- Use discriminals to create list of discriminants for record, and
1554 -- create new discriminals for use in default expressions, etc. It is
1555 -- worth noting that a task discriminant gives rise to 5 entities;
1557 -- a) The original discriminant.
1558 -- b) The discriminal for use in the task.
1559 -- c) The discriminant of the corresponding record.
1560 -- d) The discriminal for the init proc of the corresponding record.
1561 -- e) The local variable that renames the discriminant in the procedure
1562 -- for the task body.
1564 -- In fact the discriminals b) are used in the renaming declarations
1565 -- for e). See details in einfo (Handling of Discriminants).
1567 if Present
(Discriminant_Specifications
(N
)) then
1569 Disc
:= First_Discriminant
(Ctyp
);
1571 while Present
(Disc
) loop
1572 New_Disc
:= CR_Discriminant
(Disc
);
1575 Make_Discriminant_Specification
(Loc
,
1576 Defining_Identifier
=> New_Disc
,
1577 Discriminant_Type
=>
1578 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1580 New_Copy
(Discriminant_Default_Value
(Disc
))));
1582 Next_Discriminant
(Disc
);
1589 -- Now we can construct the record type declaration. Note that this
1590 -- record is "limited tagged". It is "limited" to reflect the underlying
1591 -- limitedness of the task or protected object that it represents, and
1592 -- ensuring for example that it is properly passed by reference. It is
1593 -- "tagged" to give support to dispatching calls through interfaces. We
1594 -- propagate here the list of interfaces covered by the concurrent type
1595 -- (Ada 2005: AI-345).
1598 Make_Full_Type_Declaration
(Loc
,
1599 Defining_Identifier
=> Rec_Ent
,
1600 Discriminant_Specifications
=> Dlist
,
1602 Make_Record_Definition
(Loc
,
1604 Make_Component_List
(Loc
, Component_Items
=> Cdecls
),
1606 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1607 Interface_List
=> Interface_List
(N
),
1608 Limited_Present
=> True));
1609 end Build_Corresponding_Record
;
1611 ---------------------------------
1612 -- Build_Dispatching_Tag_Check --
1613 ---------------------------------
1615 function Build_Dispatching_Tag_Check
1617 N
: Node_Id
) return Node_Id
1619 Loc
: constant Source_Ptr
:= Sloc
(N
);
1626 New_Occurrence_Of
(K
, Loc
),
1628 New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
1632 New_Occurrence_Of
(K
, Loc
),
1634 New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
)));
1635 end Build_Dispatching_Tag_Check
;
1637 ----------------------------------
1638 -- Build_Entry_Count_Expression --
1639 ----------------------------------
1641 function Build_Entry_Count_Expression
1642 (Concurrent_Type
: Node_Id
;
1643 Component_List
: List_Id
;
1644 Loc
: Source_Ptr
) return Node_Id
1656 -- Count number of non-family entries
1659 Ent
:= First_Entity
(Concurrent_Type
);
1660 while Present
(Ent
) loop
1661 if Ekind
(Ent
) = E_Entry
then
1668 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1670 -- Loop through entry families building the addition nodes
1672 Ent
:= First_Entity
(Concurrent_Type
);
1673 Comp
:= First
(Component_List
);
1674 while Present
(Ent
) loop
1675 if Ekind
(Ent
) = E_Entry_Family
then
1676 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1680 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1681 Hi
:= Type_High_Bound
(Typ
);
1682 Lo
:= Type_Low_Bound
(Typ
);
1683 Large
:= Is_Potentially_Large_Family
1684 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1687 Left_Opnd
=> Ecount
,
1689 Family_Size
(Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1696 end Build_Entry_Count_Expression
;
1698 ---------------------------
1699 -- Build_Parameter_Block --
1700 ---------------------------
1702 function Build_Parameter_Block
1706 Decls
: List_Id
) return Entity_Id
1712 Has_Comp
: Boolean := False;
1716 Actual
:= First
(Actuals
);
1718 Formal
:= Defining_Identifier
(First
(Formals
));
1720 while Present
(Actual
) loop
1721 if not Is_Controlling_Actual
(Actual
) then
1724 -- type Ann is access all <actual-type>
1726 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
1727 Set_Is_Param_Block_Component_Type
(Comp_Nam
);
1730 Make_Full_Type_Declaration
(Loc
,
1731 Defining_Identifier
=> Comp_Nam
,
1733 Make_Access_To_Object_Definition
(Loc
,
1734 All_Present
=> True,
1735 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
1736 Subtype_Indication
=>
1737 New_Occurrence_Of
(Etype
(Actual
), Loc
))));
1743 Make_Component_Declaration
(Loc
,
1744 Defining_Identifier
=>
1745 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
1746 Component_Definition
=>
1747 Make_Component_Definition
(Loc
,
1750 Subtype_Indication
=>
1751 New_Occurrence_Of
(Comp_Nam
, Loc
))));
1756 Next_Actual
(Actual
);
1757 Next_Formal_With_Extras
(Formal
);
1760 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
1765 -- type Pnn is record
1770 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1771 -- the original parameter names and Ann1 .. AnnN are the access to
1775 Make_Full_Type_Declaration
(Loc
,
1776 Defining_Identifier
=>
1779 Make_Record_Definition
(Loc
,
1781 Make_Component_List
(Loc
, Comps
))));
1784 -- type Pnn is null record;
1787 Make_Full_Type_Declaration
(Loc
,
1788 Defining_Identifier
=>
1791 Make_Record_Definition
(Loc
,
1792 Null_Present
=> True,
1793 Component_List
=> Empty
)));
1797 end Build_Parameter_Block
;
1799 --------------------------------------
1800 -- Build_Renamed_Formal_Declaration --
1801 --------------------------------------
1803 function Build_Renamed_Formal_Declaration
1807 Renamed_Formal
: Node_Id
) return Node_Id
1809 Loc
: constant Source_Ptr
:= Sloc
(New_F
);
1813 -- If the formal is a tagged incomplete type, it is already passed
1814 -- by reference, so it is sufficient to rename the pointer component
1815 -- that corresponds to the actual. Otherwise we need to dereference
1816 -- the pointer component to obtain the actual.
1818 if Is_Incomplete_Type
(Etype
(Formal
))
1819 and then Is_Tagged_Type
(Etype
(Formal
))
1822 Make_Object_Renaming_Declaration
(Loc
,
1823 Defining_Identifier
=> New_F
,
1824 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Comp
), Loc
),
1825 Name
=> Renamed_Formal
);
1829 Make_Object_Renaming_Declaration
(Loc
,
1830 Defining_Identifier
=> New_F
,
1831 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Formal
), Loc
),
1833 Make_Explicit_Dereference
(Loc
, Renamed_Formal
));
1837 end Build_Renamed_Formal_Declaration
;
1839 --------------------------
1840 -- Build_Wrapper_Bodies --
1841 --------------------------
1843 procedure Build_Wrapper_Bodies
1848 Rec_Typ
: Entity_Id
;
1850 function Build_Wrapper_Body
1852 Subp_Id
: Entity_Id
;
1853 Obj_Typ
: Entity_Id
;
1854 Formals
: List_Id
) return Node_Id
;
1855 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1856 -- associated with a protected or task type. Subp_Id is the subprogram
1857 -- name which will be wrapped. Obj_Typ is the type of the new formal
1858 -- parameter which handles dispatching and object notation. Formals are
1859 -- the original formals of Subp_Id which will be explicitly replicated.
1861 ------------------------
1862 -- Build_Wrapper_Body --
1863 ------------------------
1865 function Build_Wrapper_Body
1867 Subp_Id
: Entity_Id
;
1868 Obj_Typ
: Entity_Id
;
1869 Formals
: List_Id
) return Node_Id
1871 Body_Spec
: Node_Id
;
1874 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
1876 -- The subprogram is not overriding or is not a primitive declared
1877 -- between two views.
1879 if No
(Body_Spec
) then
1884 Actuals
: List_Id
:= No_List
;
1886 First_Form
: Node_Id
;
1891 -- Map formals to actuals. Use the list built for the wrapper
1892 -- spec, skipping the object notation parameter.
1894 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
1896 Formal
:= First_Form
;
1899 if Present
(Formal
) then
1900 Actuals
:= New_List
;
1901 while Present
(Formal
) loop
1903 Make_Identifier
(Loc
,
1904 Chars
=> Chars
(Defining_Identifier
(Formal
))));
1909 -- Special processing for primitives declared between a private
1910 -- type and its completion: the wrapper needs a properly typed
1911 -- parameter if the wrapped operation has a controlling first
1912 -- parameter. Note that this might not be the case for a function
1913 -- with a controlling result.
1915 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
1916 if No
(Actuals
) then
1917 Actuals
:= New_List
;
1920 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
1921 Prepend_To
(Actuals
,
1922 Unchecked_Convert_To
1923 (Corresponding_Concurrent_Type
(Obj_Typ
),
1924 Make_Identifier
(Loc
, Name_uO
)));
1927 Prepend_To
(Actuals
,
1928 Make_Identifier
(Loc
,
1929 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
1932 Nam
:= New_Occurrence_Of
(Subp_Id
, Loc
);
1934 -- An access-to-variable object parameter requires an explicit
1935 -- dereference in the unchecked conversion. This case occurs
1936 -- when a protected entry wrapper must override an interface
1937 -- level procedure with interface access as first parameter.
1939 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1941 if Nkind
(Parameter_Type
(First_Form
)) =
1945 Make_Explicit_Dereference
(Loc
,
1946 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
1948 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
1952 Make_Selected_Component
(Loc
,
1954 Unchecked_Convert_To
1955 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
1956 Selector_Name
=> New_Occurrence_Of
(Subp_Id
, Loc
));
1959 -- Create the subprogram body. For a function, the call to the
1960 -- actual subprogram has to be converted to the corresponding
1961 -- record if it is a controlling result.
1963 if Ekind
(Subp_Id
) = E_Function
then
1969 Make_Function_Call
(Loc
,
1971 Parameter_Associations
=> Actuals
);
1973 if Has_Controlling_Result
(Subp_Id
) then
1975 Unchecked_Convert_To
1976 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
1980 Make_Subprogram_Body
(Loc
,
1981 Specification
=> Body_Spec
,
1982 Declarations
=> Empty_List
,
1983 Handled_Statement_Sequence
=>
1984 Make_Handled_Sequence_Of_Statements
(Loc
,
1985 Statements
=> New_List
(
1986 Make_Simple_Return_Statement
(Loc
, Res
))));
1991 Make_Subprogram_Body
(Loc
,
1992 Specification
=> Body_Spec
,
1993 Declarations
=> Empty_List
,
1994 Handled_Statement_Sequence
=>
1995 Make_Handled_Sequence_Of_Statements
(Loc
,
1996 Statements
=> New_List
(
1997 Make_Procedure_Call_Statement
(Loc
,
1999 Parameter_Associations
=> Actuals
))));
2002 end Build_Wrapper_Body
;
2004 -- Start of processing for Build_Wrapper_Bodies
2007 if Is_Concurrent_Type
(Typ
) then
2008 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2013 -- Generate wrapper bodies for a concurrent type which implements an
2016 if Present
(Interfaces
(Rec_Typ
)) then
2018 Insert_Nod
: Node_Id
;
2020 Prim_Elmt
: Elmt_Id
;
2021 Prim_Decl
: Node_Id
;
2023 Wrap_Body
: Node_Id
;
2024 Wrap_Id
: Entity_Id
;
2029 -- Examine all primitive operations of the corresponding record
2030 -- type, looking for wrapper specs. Generate bodies in order to
2033 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
2034 while Present
(Prim_Elmt
) loop
2035 Prim
:= Node
(Prim_Elmt
);
2037 if (Ekind
(Prim
) = E_Function
2038 or else Ekind
(Prim
) = E_Procedure
)
2039 and then Is_Primitive_Wrapper
(Prim
)
2041 Subp
:= Wrapped_Entity
(Prim
);
2042 Prim_Decl
:= Parent
(Parent
(Prim
));
2045 Build_Wrapper_Body
(Loc
,
2048 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
2049 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
2051 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
2052 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
2054 Insert_After
(Insert_Nod
, Wrap_Body
);
2055 Insert_Nod
:= Wrap_Body
;
2057 Analyze
(Wrap_Body
);
2060 Next_Elmt
(Prim_Elmt
);
2064 end Build_Wrapper_Bodies
;
2066 ------------------------
2067 -- Build_Wrapper_Spec --
2068 ------------------------
2070 function Build_Wrapper_Spec
2071 (Subp_Id
: Entity_Id
;
2072 Obj_Typ
: Entity_Id
;
2073 Formals
: List_Id
) return Node_Id
2075 function Overriding_Possible
2076 (Iface_Op
: Entity_Id
;
2077 Wrapper
: Entity_Id
) return Boolean;
2078 -- Determine whether a primitive operation can be overridden by Wrapper.
2079 -- Iface_Op is the candidate primitive operation of an interface type,
2080 -- Wrapper is the generated entry wrapper.
2082 function Replicate_Formals
2084 Formals
: List_Id
) return List_Id
;
2085 -- An explicit parameter replication is required due to the Is_Entry_
2086 -- Formal flag being set for all the formals of an entry. The explicit
2087 -- replication removes the flag that would otherwise cause a different
2088 -- path of analysis.
2090 -------------------------
2091 -- Overriding_Possible --
2092 -------------------------
2094 function Overriding_Possible
2095 (Iface_Op
: Entity_Id
;
2096 Wrapper
: Entity_Id
) return Boolean
2098 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2099 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2101 function Type_Conformant_Parameters
2102 (Iface_Op_Params
: List_Id
;
2103 Wrapper_Params
: List_Id
) return Boolean;
2104 -- Determine whether the parameters of the generated entry wrapper
2105 -- and those of a primitive operation are type conformant. During
2106 -- this check, the first parameter of the primitive operation is
2107 -- skipped if it is a controlling argument: protected functions
2108 -- may have a controlling result.
2110 --------------------------------
2111 -- Type_Conformant_Parameters --
2112 --------------------------------
2114 function Type_Conformant_Parameters
2115 (Iface_Op_Params
: List_Id
;
2116 Wrapper_Params
: List_Id
) return Boolean
2118 Iface_Op_Param
: Node_Id
;
2119 Iface_Op_Typ
: Entity_Id
;
2120 Wrapper_Param
: Node_Id
;
2121 Wrapper_Typ
: Entity_Id
;
2124 -- Skip the first (controlling) parameter of primitive operation
2126 Iface_Op_Param
:= First
(Iface_Op_Params
);
2128 if Present
(First_Formal
(Iface_Op
))
2129 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2131 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2134 Wrapper_Param
:= First
(Wrapper_Params
);
2135 while Present
(Iface_Op_Param
)
2136 and then Present
(Wrapper_Param
)
2138 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2139 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2141 -- The two parameters must be mode conformant
2143 if not Conforming_Types
2144 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2149 Next
(Iface_Op_Param
);
2150 Next
(Wrapper_Param
);
2153 -- One of the lists is longer than the other
2155 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2160 end Type_Conformant_Parameters
;
2162 -- Start of processing for Overriding_Possible
2165 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2169 -- If an inherited subprogram is implemented by a protected procedure
2170 -- or an entry, then the first parameter of the inherited subprogram
2171 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2173 if Ekind
(Iface_Op
) = E_Procedure
2174 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2177 Obj_Param
: constant Node_Id
:=
2178 First
(Parameter_Specifications
(Iface_Op_Spec
));
2180 if not Out_Present
(Obj_Param
)
2181 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2190 Type_Conformant_Parameters
2191 (Parameter_Specifications
(Iface_Op_Spec
),
2192 Parameter_Specifications
(Wrapper_Spec
));
2193 end Overriding_Possible
;
2195 -----------------------
2196 -- Replicate_Formals --
2197 -----------------------
2199 function Replicate_Formals
2201 Formals
: List_Id
) return List_Id
2203 New_Formals
: constant List_Id
:= New_List
;
2205 Param_Type
: Node_Id
;
2208 Formal
:= First
(Formals
);
2210 -- Skip the object parameter when dealing with primitives declared
2211 -- between two views.
2213 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2214 and then not Has_Controlling_Result
(Subp_Id
)
2216 Formal
:= Next
(Formal
);
2219 while Present
(Formal
) loop
2221 -- Create an explicit copy of the entry parameter
2223 -- When creating the wrapper subprogram for a primitive operation
2224 -- of a protected interface we must construct an equivalent
2225 -- signature to that of the overriding operation. For regular
2226 -- parameters we can just use the type of the formal, but for
2227 -- access to subprogram parameters we need to reanalyze the
2228 -- parameter type to create local entities for the signature of
2229 -- the subprogram type. Using the entities of the overriding
2230 -- subprogram will result in out-of-scope errors in the back-end.
2232 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2233 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2236 New_Occurrence_Of
(Etype
(Parameter_Type
(Formal
)), Loc
);
2239 Append_To
(New_Formals
,
2240 Make_Parameter_Specification
(Loc
,
2241 Defining_Identifier
=>
2242 Make_Defining_Identifier
(Loc
,
2243 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2244 In_Present
=> In_Present
(Formal
),
2245 Out_Present
=> Out_Present
(Formal
),
2246 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
2247 Parameter_Type
=> Param_Type
));
2253 end Replicate_Formals
;
2257 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2258 First_Param
: Node_Id
:= Empty
;
2260 Iface_Elmt
: Elmt_Id
;
2261 Iface_Op
: Entity_Id
;
2262 Iface_Op_Elmt
: Elmt_Id
;
2263 Overridden_Subp
: Entity_Id
;
2265 -- Start of processing for Build_Wrapper_Spec
2268 -- No point in building wrappers for untagged concurrent types
2270 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2272 -- Check if this subprogram has a profile that matches some interface
2275 Check_Synchronized_Overriding
(Subp_Id
, Overridden_Subp
);
2277 if Present
(Overridden_Subp
) then
2279 First
(Parameter_Specifications
(Parent
(Overridden_Subp
)));
2281 -- An entry or a protected procedure can override a routine where the
2282 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2283 -- type. Since the wrapper must have the exact same signature as that of
2284 -- the overridden subprogram, we try to find the overriding candidate
2285 -- and use its controlling formal.
2287 -- Check every implemented interface
2289 elsif Present
(Interfaces
(Obj_Typ
)) then
2290 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2291 Search
: while Present
(Iface_Elmt
) loop
2292 Iface
:= Node
(Iface_Elmt
);
2294 -- Check every interface primitive
2296 if Present
(Primitive_Operations
(Iface
)) then
2297 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2298 while Present
(Iface_Op_Elmt
) loop
2299 Iface_Op
:= Node
(Iface_Op_Elmt
);
2301 -- Ignore predefined primitives
2303 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2304 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2306 -- The current primitive operation can be overridden by
2307 -- the generated entry wrapper.
2309 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2311 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2317 Next_Elmt
(Iface_Op_Elmt
);
2321 Next_Elmt
(Iface_Elmt
);
2325 -- Do not generate the wrapper if no interface primitive is covered by
2326 -- the subprogram and it is not a primitive declared between two views
2327 -- (see Process_Full_View).
2330 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2336 Wrapper_Id
: constant Entity_Id
:=
2337 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2338 New_Formals
: List_Id
;
2339 Obj_Param
: Node_Id
;
2340 Obj_Param_Typ
: Entity_Id
;
2343 -- Minimum decoration is needed to catch the entity in
2344 -- Sem_Ch6.Override_Dispatching_Operation.
2346 if Ekind
(Subp_Id
) = E_Function
then
2347 Set_Ekind
(Wrapper_Id
, E_Function
);
2349 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2352 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2353 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2354 Set_Is_Private_Primitive
(Wrapper_Id
,
2355 Is_Private_Primitive_Subprogram
(Subp_Id
));
2357 -- Process the formals
2359 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2361 -- A function with a controlling result and no first controlling
2362 -- formal needs no additional parameter.
2364 if Has_Controlling_Result
(Subp_Id
)
2366 (No
(First_Formal
(Subp_Id
))
2367 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2371 -- Routine Subp_Id has been found to override an interface primitive.
2372 -- If the interface operation has an access parameter, create a copy
2373 -- of it, with the same null exclusion indicator if present.
2375 elsif Present
(First_Param
) then
2376 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2378 Make_Access_Definition
(Loc
,
2380 New_Occurrence_Of
(Obj_Typ
, Loc
),
2381 Null_Exclusion_Present
=>
2382 Null_Exclusion_Present
(Parameter_Type
(First_Param
)),
2384 Constant_Present
(Parameter_Type
(First_Param
)));
2386 Obj_Param_Typ
:= New_Occurrence_Of
(Obj_Typ
, Loc
);
2390 Make_Parameter_Specification
(Loc
,
2391 Defining_Identifier
=>
2392 Make_Defining_Identifier
(Loc
,
2394 In_Present
=> In_Present
(First_Param
),
2395 Out_Present
=> Out_Present
(First_Param
),
2396 Parameter_Type
=> Obj_Param_Typ
);
2398 Prepend_To
(New_Formals
, Obj_Param
);
2400 -- If we are dealing with a primitive declared between two views,
2401 -- implemented by a synchronized operation, we need to create
2402 -- a default parameter. The mode of the parameter must match that
2403 -- of the primitive operation.
2406 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2409 Make_Parameter_Specification
(Loc
,
2410 Defining_Identifier
=>
2411 Make_Defining_Identifier
(Loc
, Name_uO
),
2413 In_Present
(Parent
(First_Entity
(Subp_Id
))),
2414 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2415 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2417 Prepend_To
(New_Formals
, Obj_Param
);
2420 -- Build the final spec. If it is a function with a controlling
2421 -- result, it is a primitive operation of the corresponding
2422 -- record type, so mark the spec accordingly.
2424 if Ekind
(Subp_Id
) = E_Function
then
2429 if Has_Controlling_Result
(Subp_Id
) then
2432 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2434 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2438 Make_Function_Specification
(Loc
,
2439 Defining_Unit_Name
=> Wrapper_Id
,
2440 Parameter_Specifications
=> New_Formals
,
2441 Result_Definition
=> Res_Def
);
2445 Make_Procedure_Specification
(Loc
,
2446 Defining_Unit_Name
=> Wrapper_Id
,
2447 Parameter_Specifications
=> New_Formals
);
2450 end Build_Wrapper_Spec
;
2452 -------------------------
2453 -- Build_Wrapper_Specs --
2454 -------------------------
2456 procedure Build_Wrapper_Specs
2462 Rec_Typ
: Entity_Id
;
2463 procedure Scan_Declarations
(L
: List_Id
);
2464 -- Common processing for visible and private declarations
2465 -- of a protected type.
2467 procedure Scan_Declarations
(L
: List_Id
) is
2469 Wrap_Decl
: Node_Id
;
2470 Wrap_Spec
: Node_Id
;
2478 while Present
(Decl
) loop
2481 if Nkind
(Decl
) = N_Entry_Declaration
2482 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2486 (Subp_Id
=> Defining_Identifier
(Decl
),
2488 Formals
=> Parameter_Specifications
(Decl
));
2490 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2493 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2496 Parameter_Specifications
(Specification
(Decl
)));
2499 if Present
(Wrap_Spec
) then
2501 Make_Subprogram_Declaration
(Loc
,
2502 Specification
=> Wrap_Spec
);
2504 Insert_After
(N
, Wrap_Decl
);
2507 Analyze
(Wrap_Decl
);
2512 end Scan_Declarations
;
2514 -- start of processing for Build_Wrapper_Specs
2517 if Is_Protected_Type
(Typ
) then
2518 Def
:= Protected_Definition
(Parent
(Typ
));
2519 else pragma Assert
(Is_Task_Type
(Typ
));
2520 Def
:= Task_Definition
(Parent
(Typ
));
2523 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2525 -- Generate wrapper specs for a concurrent type which implements an
2526 -- interface. Operations in both the visible and private parts may
2527 -- implement progenitor operations.
2529 if Present
(Interfaces
(Rec_Typ
)) and then Present
(Def
) then
2530 Scan_Declarations
(Visible_Declarations
(Def
));
2531 Scan_Declarations
(Private_Declarations
(Def
));
2533 end Build_Wrapper_Specs
;
2535 ---------------------------
2536 -- Build_Find_Body_Index --
2537 ---------------------------
2539 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2540 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2543 Has_F
: Boolean := False;
2545 If_St
: Node_Id
:= Empty
;
2548 Decls
: List_Id
:= New_List
;
2551 Siz
: Node_Id
:= Empty
;
2553 procedure Add_If_Clause
(Expr
: Node_Id
);
2554 -- Add test for range of current entry
2556 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2557 -- If a bound of an entry is given by a discriminant, retrieve the
2558 -- actual value of the discriminant from the enclosing object.
2564 procedure Add_If_Clause
(Expr
: Node_Id
) is
2566 Stats
: constant List_Id
:=
2568 Make_Simple_Return_Statement
(Loc
,
2569 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2572 -- Index for current entry body
2576 -- Compute total length of entry queues so far
2584 Right_Opnd
=> Expr
);
2589 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2592 -- Map entry queue indexes in the range of the current family
2593 -- into the current index, that designates the entry body.
2597 Make_Implicit_If_Statement
(Typ
,
2599 Then_Statements
=> Stats
,
2600 Elsif_Parts
=> New_List
);
2604 Append_To
(Elsif_Parts
(If_St
),
2605 Make_Elsif_Part
(Loc
,
2607 Then_Statements
=> Stats
));
2611 ------------------------------
2612 -- Convert_Discriminant_Ref --
2613 ------------------------------
2615 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2619 if Is_Entity_Name
(Bound
)
2620 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2623 Make_Selected_Component
(Loc
,
2625 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2626 Make_Explicit_Dereference
(Loc
,
2627 Make_Identifier
(Loc
, Name_uObject
))),
2628 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
2629 Set_Etype
(B
, Etype
(Entity
(Bound
)));
2631 B
:= New_Copy_Tree
(Bound
);
2635 end Convert_Discriminant_Ref
;
2637 -- Start of processing for Build_Find_Body_Index
2640 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
2642 Ent
:= First_Entity
(Typ
);
2643 while Present
(Ent
) loop
2644 if Ekind
(Ent
) = E_Entry_Family
then
2654 -- If the protected type has no entry families, there is a one-one
2655 -- correspondence between entry queue and entry body.
2658 Make_Simple_Return_Statement
(Loc
,
2659 Expression
=> Make_Identifier
(Loc
, Name_uE
));
2662 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2665 -- if E <= l1 then return 1;
2666 -- elsif E <= l1 + l2 then return 2;
2671 Ent
:= First_Entity
(Typ
);
2673 Add_Object_Pointer
(Loc
, Typ
, Decls
);
2675 while Present
(Ent
) loop
2676 if Ekind
(Ent
) = E_Entry
then
2677 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
2679 elsif Ekind
(Ent
) = E_Entry_Family
then
2680 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
2681 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
2682 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
2683 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
2692 Make_Simple_Return_Statement
(Loc
,
2693 Expression
=> Make_Integer_Literal
(Loc
, 1));
2695 elsif Nkind
(Ret
) = N_If_Statement
then
2697 -- Ranges are in increasing order, so last one doesn't need guard
2700 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
2703 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
2709 Make_Subprogram_Body
(Loc
,
2710 Specification
=> Spec
,
2711 Declarations
=> Decls
,
2712 Handled_Statement_Sequence
=>
2713 Make_Handled_Sequence_Of_Statements
(Loc
,
2714 Statements
=> New_List
(Ret
)));
2715 end Build_Find_Body_Index
;
2717 --------------------------------
2718 -- Build_Find_Body_Index_Spec --
2719 --------------------------------
2721 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
2722 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2723 Id
: constant Entity_Id
:=
2724 Make_Defining_Identifier
(Loc
,
2725 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
2726 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
2727 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
2731 Make_Function_Specification
(Loc
,
2732 Defining_Unit_Name
=> Id
,
2733 Parameter_Specifications
=> New_List
(
2734 Make_Parameter_Specification
(Loc
,
2735 Defining_Identifier
=> Parm1
,
2737 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2739 Make_Parameter_Specification
(Loc
,
2740 Defining_Identifier
=> Parm2
,
2742 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
2744 Result_Definition
=> New_Occurrence_Of
(
2745 RTE
(RE_Protected_Entry_Index
), Loc
));
2746 end Build_Find_Body_Index_Spec
;
2748 -----------------------------------------------
2749 -- Build_Lock_Free_Protected_Subprogram_Body --
2750 -----------------------------------------------
2752 function Build_Lock_Free_Protected_Subprogram_Body
2755 Unprot_Spec
: Node_Id
) return Node_Id
2757 Actuals
: constant List_Id
:= New_List
;
2758 Loc
: constant Source_Ptr
:= Sloc
(N
);
2759 Spec
: constant Node_Id
:= Specification
(N
);
2760 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
2762 Prot_Spec
: Node_Id
;
2766 -- Create the protected version of the body
2769 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
2771 -- Build the actual parameters which appear in the call to the
2772 -- unprotected version of the body.
2774 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
2775 while Present
(Formal
) loop
2777 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
2782 -- Function case, generate:
2783 -- return <Unprot_Func_Call>;
2785 if Nkind
(Spec
) = N_Function_Specification
then
2787 Make_Simple_Return_Statement
(Loc
,
2789 Make_Function_Call
(Loc
,
2791 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2792 Parameter_Associations
=> Actuals
));
2794 -- Procedure case, call the unprotected version
2798 Make_Procedure_Call_Statement
(Loc
,
2800 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2801 Parameter_Associations
=> Actuals
);
2805 Make_Subprogram_Body
(Loc
,
2806 Declarations
=> Empty_List
,
2807 Specification
=> Prot_Spec
,
2808 Handled_Statement_Sequence
=>
2809 Make_Handled_Sequence_Of_Statements
(Loc
,
2810 Statements
=> New_List
(Stmt
)));
2811 end Build_Lock_Free_Protected_Subprogram_Body
;
2813 -------------------------------------------------
2814 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2815 -------------------------------------------------
2817 -- Procedures which meet the lock-free implementation requirements and
2818 -- reference a unique scalar component Comp are expanded in the following
2821 -- procedure P (...) is
2822 -- Expected_Comp : constant Comp_Type :=
2824 -- (System.Atomic_Primitives.Lock_Free_Read_N
2825 -- (_Object.Comp'Address));
2829 -- <original declarations before the object renaming declaration
2832 -- Desired_Comp : Comp_Type := Expected_Comp;
2833 -- Comp : Comp_Type renames Desired_Comp;
2835 -- <original delarations after the object renaming declaration
2839 -- <original statements>
2840 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2841 -- (_Object.Comp'Address,
2842 -- Interfaces.Unsigned_N (Expected_Comp),
2843 -- Interfaces.Unsigned_N (Desired_Comp));
2848 -- Each return and raise statement of P is transformed into an atomic
2851 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2852 -- (_Object.Comp'Address,
2853 -- Interfaces.Unsigned_N (Expected_Comp),
2854 -- Interfaces.Unsigned_N (Desired_Comp));
2856 -- <original statement>
2861 -- Functions which meet the lock-free implementation requirements and
2862 -- reference a unique scalar component Comp are expanded in the following
2865 -- function F (...) return ... is
2866 -- <original declarations before the object renaming declaration
2869 -- Expected_Comp : constant Comp_Type :=
2871 -- (System.Atomic_Primitives.Lock_Free_Read_N
2872 -- (_Object.Comp'Address));
2873 -- Comp : Comp_Type renames Expected_Comp;
2875 -- <original delarations after the object renaming declaration of
2879 -- <original statements>
2882 function Build_Lock_Free_Unprotected_Subprogram_Body
2884 Prot_Typ
: Node_Id
) return Node_Id
2886 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
2887 -- Subprograms which meet the lock-free implementation criteria are
2888 -- allowed to reference only one unique component. Return the prival
2889 -- of the said component.
2891 --------------------------
2892 -- Referenced_Component --
2893 --------------------------
2895 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
2898 Source_Comp
: Entity_Id
:= Empty
;
2901 -- Find the unique source component which N references in its
2904 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
2906 Element
: Lock_Free_Subprogram
renames
2907 Lock_Free_Subprogram_Table
.Table
(Index
);
2909 if Element
.Sub_Body
= N
then
2910 Source_Comp
:= Element
.Comp_Id
;
2916 if No
(Source_Comp
) then
2920 -- Find the prival which corresponds to the source component within
2921 -- the declarations of N.
2923 Decl
:= First
(Declarations
(N
));
2924 while Present
(Decl
) loop
2926 -- Privals appear as object renamings
2928 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2929 Comp
:= Defining_Identifier
(Decl
);
2931 if Present
(Prival_Link
(Comp
))
2932 and then Prival_Link
(Comp
) = Source_Comp
2942 end Referenced_Component
;
2946 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
2947 Loc
: constant Source_Ptr
:= Sloc
(N
);
2948 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
2949 Decls
: List_Id
:= Declarations
(N
);
2951 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
2954 -- Add renamings for the protection object, discriminals, privals, and
2955 -- the entry index constant for use by debugger.
2957 Debug_Private_Data_Declarations
(Decls
);
2959 -- Perform the lock-free expansion when the subprogram references a
2960 -- protected component.
2962 if Present
(Comp
) then
2963 Protected_Component_Ref
: declare
2964 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
2965 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
2966 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
2968 Is_Procedure
: constant Boolean :=
2969 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
2970 -- Indicates if N is a protected procedure body
2972 Block_Decls
: List_Id
:= No_List
;
2973 Try_Write
: Entity_Id
;
2974 Desired_Comp
: Entity_Id
;
2977 Label_Id
: Entity_Id
:= Empty
;
2979 Expected_Comp
: Entity_Id
;
2982 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
2984 Unsigned
: Entity_Id
;
2986 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
2987 -- Transform a single node if it is a return statement, a raise
2988 -- statement or a reference to Comp.
2990 procedure Process_Stmts
(Stmts
: List_Id
);
2991 -- Given a statement sequence Stmts, wrap any return or raise
2992 -- statements in the following manner:
2994 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2995 -- (_Object.Comp'Address,
2996 -- Interfaces.Unsigned_N (Expected_Comp),
2997 -- Interfaces.Unsigned_N (Desired_Comp))
3008 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3010 procedure Wrap_Statement
(Stmt
: Node_Id
);
3011 -- Wrap an arbitrary statement inside an if statement where the
3012 -- condition does an atomic check on the state of the object.
3014 --------------------
3015 -- Wrap_Statement --
3016 --------------------
3018 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3020 -- The first time through, create the declaration of a label
3021 -- which is used to skip the remainder of source statements
3022 -- if the state of the object has changed.
3024 if No
(Label_Id
) then
3026 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3027 Set_Entity
(Label_Id
,
3028 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3032 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3033 -- (_Object.Comp'Address,
3034 -- Interfaces.Unsigned_N (Expected_Comp),
3035 -- Interfaces.Unsigned_N (Desired_Comp))
3043 Make_Implicit_If_Statement
(N
,
3045 Make_Function_Call
(Loc
,
3047 New_Occurrence_Of
(Try_Write
, Loc
),
3048 Parameter_Associations
=> New_List
(
3049 Make_Attribute_Reference
(Loc
,
3050 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3051 Attribute_Name
=> Name_Address
),
3053 Unchecked_Convert_To
(Unsigned
,
3054 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3056 Unchecked_Convert_To
(Unsigned
,
3057 New_Occurrence_Of
(Desired_Comp
, Loc
)))),
3059 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3061 Else_Statements
=> New_List
(
3062 Make_Goto_Statement
(Loc
,
3064 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3067 -- Start of processing for Process_Node
3070 -- Wrap each return and raise statement that appear inside a
3071 -- procedure. Skip the last return statement which is added by
3072 -- default since it is transformed into an exit statement.
3075 and then ((Nkind
(N
) = N_Simple_Return_Statement
3076 and then N
/= Last
(Stmts
))
3077 or else Nkind
(N
) = N_Extended_Return_Statement
3078 or else (Nkind_In
(N
, N_Raise_Constraint_Error
,
3079 N_Raise_Program_Error
,
3081 N_Raise_Storage_Error
)
3082 and then Comes_From_Source
(N
)))
3090 Set_Analyzed
(N
, False);
3095 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3101 procedure Process_Stmts
(Stmts
: List_Id
) is
3104 Stmt
:= First
(Stmts
);
3105 while Present
(Stmt
) loop
3106 Process_Nodes
(Stmt
);
3111 -- Start of processing for Protected_Component_Ref
3114 -- Get the type size
3116 if Known_Static_Esize
(Comp_Type
) then
3117 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3119 -- If the Esize (Object_Size) is unknown at compile time, look at
3120 -- the RM_Size (Value_Size) since it may have been set by an
3121 -- explicit representation clause.
3123 elsif Known_Static_RM_Size
(Comp_Type
) then
3124 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3126 -- Should not happen since this has already been checked in
3127 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3130 raise Program_Error
;
3133 -- Retrieve all relevant atomic routines and types
3137 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3138 Read
:= RTE
(RE_Lock_Free_Read_8
);
3139 Unsigned
:= RTE
(RE_Uint8
);
3142 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3143 Read
:= RTE
(RE_Lock_Free_Read_16
);
3144 Unsigned
:= RTE
(RE_Uint16
);
3147 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3148 Read
:= RTE
(RE_Lock_Free_Read_32
);
3149 Unsigned
:= RTE
(RE_Uint32
);
3152 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3153 Read
:= RTE
(RE_Lock_Free_Read_64
);
3154 Unsigned
:= RTE
(RE_Uint64
);
3157 raise Program_Error
;
3161 -- Expected_Comp : constant Comp_Type :=
3163 -- (System.Atomic_Primitives.Lock_Free_Read_N
3164 -- (_Object.Comp'Address));
3167 Make_Defining_Identifier
(Loc
,
3168 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3171 Make_Object_Declaration
(Loc
,
3172 Defining_Identifier
=> Expected_Comp
,
3173 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3174 Constant_Present
=> True,
3176 Unchecked_Convert_To
(Comp_Type
,
3177 Make_Function_Call
(Loc
,
3178 Name
=> New_Occurrence_Of
(Read
, Loc
),
3179 Parameter_Associations
=> New_List
(
3180 Make_Attribute_Reference
(Loc
,
3181 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3182 Attribute_Name
=> Name_Address
)))));
3184 -- Protected procedures
3186 if Is_Procedure
then
3187 -- Move the original declarations inside the generated block
3189 Block_Decls
:= Decls
;
3191 -- Reset the declarations list of the protected procedure to
3192 -- contain only Decl.
3194 Decls
:= New_List
(Decl
);
3197 -- Desired_Comp : Comp_Type := Expected_Comp;
3200 Make_Defining_Identifier
(Loc
,
3201 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3203 -- Insert the declarations of Expected_Comp and Desired_Comp in
3204 -- the block declarations right before the renaming of the
3205 -- protected component.
3207 Insert_Before
(Comp_Decl
,
3208 Make_Object_Declaration
(Loc
,
3209 Defining_Identifier
=> Desired_Comp
,
3210 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3212 New_Occurrence_Of
(Expected_Comp
, Loc
)));
3214 -- Protected function
3217 Desired_Comp
:= Expected_Comp
;
3219 -- Insert the declaration of Expected_Comp in the function
3220 -- declarations right before the renaming of the protected
3223 Insert_Before
(Comp_Decl
, Decl
);
3226 -- Rewrite the protected component renaming declaration to be a
3227 -- renaming of Desired_Comp.
3230 -- Comp : Comp_Type renames Desired_Comp;
3233 Make_Object_Renaming_Declaration
(Loc
,
3234 Defining_Identifier
=>
3235 Defining_Identifier
(Comp_Decl
),
3237 New_Occurrence_Of
(Comp_Type
, Loc
),
3239 New_Occurrence_Of
(Desired_Comp
, Loc
)));
3241 -- Wrap any return or raise statements in Stmts in same the manner
3242 -- described in Process_Stmts.
3244 Process_Stmts
(Stmts
);
3247 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3248 -- (_Object.Comp'Address,
3249 -- Interfaces.Unsigned_N (Expected_Comp),
3250 -- Interfaces.Unsigned_N (Desired_Comp))
3252 if Is_Procedure
then
3254 Make_Exit_Statement
(Loc
,
3256 Make_Function_Call
(Loc
,
3258 New_Occurrence_Of
(Try_Write
, Loc
),
3259 Parameter_Associations
=> New_List
(
3260 Make_Attribute_Reference
(Loc
,
3261 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3262 Attribute_Name
=> Name_Address
),
3264 Unchecked_Convert_To
(Unsigned
,
3265 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3267 Unchecked_Convert_To
(Unsigned
,
3268 New_Occurrence_Of
(Desired_Comp
, Loc
)))));
3270 -- Small optimization: transform the default return statement
3271 -- of a procedure into the atomic exit statement.
3273 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3274 Rewrite
(Last
(Stmts
), Stmt
);
3276 Append_To
(Stmts
, Stmt
);
3280 -- Create the declaration of the label used to skip the rest of
3281 -- the source statements when the object state changes.
3283 if Present
(Label_Id
) then
3284 Label
:= Make_Label
(Loc
, Label_Id
);
3286 Make_Implicit_Label_Declaration
(Loc
,
3287 Defining_Identifier
=> Entity
(Label_Id
),
3288 Label_Construct
=> Label
));
3289 Append_To
(Stmts
, Label
);
3301 if Is_Procedure
then
3304 Make_Loop_Statement
(Loc
,
3305 Statements
=> New_List
(
3306 Make_Block_Statement
(Loc
,
3307 Declarations
=> Block_Decls
,
3308 Handled_Statement_Sequence
=>
3309 Make_Handled_Sequence_Of_Statements
(Loc
,
3310 Statements
=> Stmts
))),
3311 End_Label
=> Empty
));
3315 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3316 end Protected_Component_Ref
;
3319 -- Make an unprotected version of the subprogram for use within the same
3320 -- object, with new name and extra parameter representing the object.
3323 Make_Subprogram_Body
(Loc
,
3325 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3326 Declarations
=> Decls
,
3327 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3328 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3330 -------------------------
3331 -- Build_Master_Entity --
3332 -------------------------
3334 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3335 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3337 Context_Id
: Entity_Id
;
3343 if Is_Itype
(Obj_Or_Typ
) then
3344 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3346 Par
:= Parent
(Obj_Or_Typ
);
3349 -- When creating a master for a record component which is either a task
3350 -- or access-to-task, the enclosing record is the master scope and the
3351 -- proper insertion point is the component list.
3353 if Is_Record_Type
(Current_Scope
) then
3355 Context_Id
:= Current_Scope
;
3356 Decls
:= List_Containing
(Context
);
3358 -- Default case for object declarations and access types. Note that the
3359 -- context is updated to the nearest enclosing body, block, package, or
3360 -- return statement.
3363 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3366 -- Nothing to do if the context already has a master
3368 if Has_Master_Entity
(Context_Id
) then
3371 -- Nothing to do if tasks or tasking hierarchies are prohibited
3373 elsif Restriction_Active
(No_Tasking
)
3374 or else Restriction_Active
(No_Task_Hierarchy
)
3379 -- Create a master, generate:
3380 -- _Master : constant Master_Id := Current_Master.all;
3383 Make_Object_Declaration
(Loc
,
3384 Defining_Identifier
=>
3385 Make_Defining_Identifier
(Loc
, Name_uMaster
),
3386 Constant_Present
=> True,
3387 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3389 Make_Explicit_Dereference
(Loc
,
3390 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
3392 -- The master is inserted at the start of the declarative list of the
3395 Prepend_To
(Decls
, Decl
);
3397 -- In certain cases where transient scopes are involved, the immediate
3398 -- scope is not always the proper master scope. Ensure that the master
3399 -- declaration and entity appear in the same context.
3401 if Context_Id
/= Current_Scope
then
3402 Push_Scope
(Context_Id
);
3409 -- Mark the enclosing scope and its associated construct as being task
3412 Set_Has_Master_Entity
(Context_Id
);
3414 while Present
(Context
)
3415 and then Nkind
(Context
) /= N_Compilation_Unit
3417 if Nkind_In
(Context
, N_Block_Statement
,
3421 Set_Is_Task_Master
(Context
);
3424 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3425 Context
:= Corresponding_Stub
(Parent
(Context
));
3428 Context
:= Parent
(Context
);
3430 end Build_Master_Entity
;
3432 ---------------------------
3433 -- Build_Master_Renaming --
3434 ---------------------------
3436 procedure Build_Master_Renaming
3437 (Ptr_Typ
: Entity_Id
;
3438 Ins_Nod
: Node_Id
:= Empty
)
3440 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3442 Master_Decl
: Node_Id
;
3443 Master_Id
: Entity_Id
;
3446 -- Nothing to do if tasks or tasking hierarchies are prohibited
3448 if Restriction_Active
(No_Tasking
)
3449 or else Restriction_Active
(No_Task_Hierarchy
)
3454 -- Determine the proper context to insert the master renaming
3456 if Present
(Ins_Nod
) then
3458 elsif Is_Itype
(Ptr_Typ
) then
3459 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3461 Context
:= Parent
(Ptr_Typ
);
3465 -- <Ptr_Typ>M : Master_Id renames _Master;
3468 Make_Defining_Identifier
(Loc
,
3469 New_External_Name
(Chars
(Ptr_Typ
), 'M'));
3472 Make_Object_Renaming_Declaration
(Loc
,
3473 Defining_Identifier
=> Master_Id
,
3474 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3475 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3477 Insert_Action
(Context
, Master_Decl
);
3479 -- The renamed master now services the access type
3481 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3482 end Build_Master_Renaming
;
3484 -----------------------------------------
3485 -- Build_Private_Protected_Declaration --
3486 -----------------------------------------
3488 function Build_Private_Protected_Declaration
3489 (N
: Node_Id
) return Entity_Id
3491 procedure Analyze_Pragmas
(From
: Node_Id
);
3492 -- Analyze all pragmas which follow arbitrary node From
3494 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
);
3495 -- Find all suitable source pragmas at the top of subprogram body From's
3496 -- declarations and insert them after arbitrary node To.
3498 ---------------------
3499 -- Analyze_Pragmas --
3500 ---------------------
3502 procedure Analyze_Pragmas
(From
: Node_Id
) is
3506 Decl
:= Next
(From
);
3507 while Present
(Decl
) loop
3508 if Nkind
(Decl
) = N_Pragma
then
3509 Analyze_Pragma
(Decl
);
3511 -- No candidate pragmas are available for analysis
3519 end Analyze_Pragmas
;
3525 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
) is
3527 Insert_Nod
: Node_Id
;
3528 Next_Decl
: Node_Id
;
3531 pragma Assert
(Nkind
(From
) = N_Subprogram_Body
);
3533 -- The pragmas are moved in an order-preserving fashion
3537 -- Inspect the declarations of the subprogram body and relocate all
3538 -- candidate pragmas.
3540 Decl
:= First
(Declarations
(From
));
3541 while Present
(Decl
) loop
3543 -- Preserve the following declaration for iteration purposes, due
3544 -- to possible relocation of a pragma.
3546 Next_Decl
:= Next
(Decl
);
3548 if Nkind
(Decl
) = N_Pragma
then
3550 Insert_After
(Insert_Nod
, Decl
);
3553 -- Skip internally generated code
3555 elsif not Comes_From_Source
(Decl
) then
3558 -- No candidate pragmas are available for relocation
3570 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3571 Loc
: constant Source_Ptr
:= Sloc
(N
);
3576 Spec_Id
: Entity_Id
;
3578 -- Start of processing for Build_Private_Protected_Declaration
3581 Formal
:= First_Formal
(Body_Id
);
3583 -- The protected operation always has at least one formal, namely the
3584 -- object itself, but it is only placed in the parameter list if
3585 -- expansion is enabled.
3587 if Present
(Formal
) or else Expander_Active
then
3588 Formals
:= Copy_Parameter_List
(Body_Id
);
3594 Make_Defining_Identifier
(Sloc
(Body_Id
),
3595 Chars
=> Chars
(Body_Id
));
3597 -- Indicate that the entity comes from source, to ensure that cross-
3598 -- reference information is properly generated. The body itself is
3599 -- rewritten during expansion, and the body entity will not appear in
3600 -- calls to the operation.
3602 Set_Comes_From_Source
(Spec_Id
, True);
3604 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
3606 Make_Procedure_Specification
(Loc
,
3607 Defining_Unit_Name
=> Spec_Id
,
3608 Parameter_Specifications
=> Formals
);
3611 Make_Function_Specification
(Loc
,
3612 Defining_Unit_Name
=> Spec_Id
,
3613 Parameter_Specifications
=> Formals
,
3614 Result_Definition
=>
3615 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
3618 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
);
3619 Set_Corresponding_Body
(Decl
, Body_Id
);
3620 Set_Corresponding_Spec
(N
, Spec_Id
);
3622 Insert_Before
(N
, Decl
);
3624 -- Associate all aspects and pragmas of the body with the spec. This
3625 -- ensures that these annotations apply to the initial declaration of
3626 -- the subprogram body.
3628 Move_Aspects
(From
=> N
, To
=> Decl
);
3629 Move_Pragmas
(From
=> N
, To
=> Decl
);
3633 -- The analysis of the spec may generate pragmas which require manual
3634 -- analysis. Since the generation of the spec and the relocation of the
3635 -- annotations is driven by the expansion of the stand-alone body, the
3636 -- pragmas will not be analyzed in a timely manner. Do this now.
3638 Analyze_Pragmas
(Decl
);
3640 Set_Convention
(Spec_Id
, Convention_Protected
);
3641 Set_Has_Completion
(Spec_Id
);
3644 end Build_Private_Protected_Declaration
;
3646 ---------------------------
3647 -- Build_Protected_Entry --
3648 ---------------------------
3650 function Build_Protected_Entry
3653 Pid
: Node_Id
) return Node_Id
3655 Bod_Decls
: constant List_Id
:= New_List
;
3656 Decls
: constant List_Id
:= Declarations
(N
);
3657 End_Lab
: constant Node_Id
:=
3658 End_Label
(Handled_Statement_Sequence
(N
));
3659 End_Loc
: constant Source_Ptr
:=
3660 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3661 -- Used for the generated call to Complete_Entry_Body
3663 Loc
: constant Source_Ptr
:= Sloc
(N
);
3667 Bod_Stmts
: List_Id
;
3670 Proc_Body
: Node_Id
;
3672 EH_Loc
: Source_Ptr
;
3673 -- Used for the exception handler, inserted at end of the body
3676 -- Set the source location on the exception handler only when debugging
3677 -- the expanded code (see Make_Implicit_Exception_Handler).
3679 if Debug_Generated_Code
then
3682 -- Otherwise the inserted code should not be visible to the debugger
3685 EH_Loc
:= No_Location
;
3689 Make_Defining_Identifier
(Loc
,
3690 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3691 Bod_Spec
:= Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Empty
);
3693 -- Add the following declarations:
3695 -- type poVP is access poV;
3696 -- _object : poVP := poVP (_O);
3698 -- where _O is the formal parameter associated with the concurrent
3699 -- object. These declarations are needed for Complete_Entry_Body.
3701 Add_Object_Pointer
(Loc
, Pid
, Bod_Decls
);
3703 -- Add renamings for all formals, the Protection object, discriminals,
3704 -- privals and the entry index constant for use by debugger.
3706 Add_Formal_Renamings
(Bod_Spec
, Bod_Decls
, Ent
, Loc
);
3707 Debug_Private_Data_Declarations
(Decls
);
3709 -- Put the declarations and the statements from the entry
3713 Make_Block_Statement
(Loc
,
3714 Declarations
=> Decls
,
3715 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
)));
3717 case Corresponding_Runtime_Package
(Pid
) is
3718 when System_Tasking_Protected_Objects_Entries
=>
3719 Append_To
(Bod_Stmts
,
3720 Make_Procedure_Call_Statement
(End_Loc
,
3722 New_Occurrence_Of
(RTE
(RE_Complete_Entry_Body
), Loc
),
3723 Parameter_Associations
=> New_List
(
3724 Make_Attribute_Reference
(End_Loc
,
3726 Make_Selected_Component
(End_Loc
,
3728 Make_Identifier
(End_Loc
, Name_uObject
),
3730 Make_Identifier
(End_Loc
, Name_uObject
)),
3731 Attribute_Name
=> Name_Unchecked_Access
))));
3733 when System_Tasking_Protected_Objects_Single_Entry
=>
3735 -- Historically, a call to Complete_Single_Entry_Body was
3736 -- inserted, but it was a null procedure.
3741 raise Program_Error
;
3744 -- When exceptions can not be propagated, we never need to call
3745 -- Exception_Complete_Entry_Body.
3747 if No_Exception_Handlers_Set
then
3749 Make_Subprogram_Body
(Loc
,
3750 Specification
=> Bod_Spec
,
3751 Declarations
=> Bod_Decls
,
3752 Handled_Statement_Sequence
=>
3753 Make_Handled_Sequence_Of_Statements
(Loc
,
3754 Statements
=> Bod_Stmts
,
3755 End_Label
=> End_Lab
));
3758 Ohandle
:= Make_Others_Choice
(Loc
);
3759 Set_All_Others
(Ohandle
);
3761 case Corresponding_Runtime_Package
(Pid
) is
3762 when System_Tasking_Protected_Objects_Entries
=>
3765 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
3767 when System_Tasking_Protected_Objects_Single_Entry
=>
3770 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
3773 raise Program_Error
;
3776 -- Establish link between subprogram body entity and source entry
3778 Set_Corresponding_Protected_Entry
(Bod_Id
, Ent
);
3780 -- Create body of entry procedure. The renaming declarations are
3781 -- placed ahead of the block that contains the actual entry body.
3784 Make_Subprogram_Body
(Loc
,
3785 Specification
=> Bod_Spec
,
3786 Declarations
=> Bod_Decls
,
3787 Handled_Statement_Sequence
=>
3788 Make_Handled_Sequence_Of_Statements
(Loc
,
3789 Statements
=> Bod_Stmts
,
3790 End_Label
=> End_Lab
,
3791 Exception_Handlers
=> New_List
(
3792 Make_Implicit_Exception_Handler
(EH_Loc
,
3793 Exception_Choices
=> New_List
(Ohandle
),
3795 Statements
=> New_List
(
3796 Make_Procedure_Call_Statement
(EH_Loc
,
3798 Parameter_Associations
=> New_List
(
3799 Make_Attribute_Reference
(EH_Loc
,
3801 Make_Selected_Component
(EH_Loc
,
3803 Make_Identifier
(EH_Loc
, Name_uObject
),
3805 Make_Identifier
(EH_Loc
, Name_uObject
)),
3806 Attribute_Name
=> Name_Unchecked_Access
),
3808 Make_Function_Call
(EH_Loc
,
3811 (RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
3813 Reset_Scopes_To
(Proc_Body
, Protected_Body_Subprogram
(Ent
));
3816 end Build_Protected_Entry
;
3818 -----------------------------------------
3819 -- Build_Protected_Entry_Specification --
3820 -----------------------------------------
3822 function Build_Protected_Entry_Specification
3825 Ent_Id
: Entity_Id
) return Node_Id
3827 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
3830 Set_Debug_Info_Needed
(Def_Id
);
3832 if Present
(Ent_Id
) then
3833 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
3837 Make_Procedure_Specification
(Loc
,
3838 Defining_Unit_Name
=> Def_Id
,
3839 Parameter_Specifications
=> New_List
(
3840 Make_Parameter_Specification
(Loc
,
3841 Defining_Identifier
=>
3842 Make_Defining_Identifier
(Loc
, Name_uO
),
3844 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3846 Make_Parameter_Specification
(Loc
,
3847 Defining_Identifier
=> P
,
3849 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3851 Make_Parameter_Specification
(Loc
,
3852 Defining_Identifier
=>
3853 Make_Defining_Identifier
(Loc
, Name_uE
),
3855 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))));
3856 end Build_Protected_Entry_Specification
;
3858 --------------------------
3859 -- Build_Protected_Spec --
3860 --------------------------
3862 function Build_Protected_Spec
3864 Obj_Type
: Entity_Id
;
3866 Unprotected
: Boolean := False) return List_Id
3868 Loc
: constant Source_Ptr
:= Sloc
(N
);
3871 New_Plist
: List_Id
;
3872 New_Param
: Node_Id
;
3875 New_Plist
:= New_List
;
3877 Formal
:= First_Formal
(Ident
);
3878 while Present
(Formal
) loop
3880 Make_Parameter_Specification
(Loc
,
3881 Defining_Identifier
=>
3882 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
3883 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
3884 In_Present
=> In_Present
(Parent
(Formal
)),
3885 Out_Present
=> Out_Present
(Parent
(Formal
)),
3886 Parameter_Type
=> New_Occurrence_Of
(Etype
(Formal
), Loc
));
3889 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
3892 Append
(New_Param
, New_Plist
);
3893 Next_Formal
(Formal
);
3896 -- If the subprogram is a procedure and the context is not an access
3897 -- to protected subprogram, the parameter is in-out. Otherwise it is
3901 Make_Parameter_Specification
(Loc
,
3902 Defining_Identifier
=>
3903 Make_Defining_Identifier
(Loc
, Name_uObject
),
3906 (Etype
(Ident
) = Standard_Void_Type
3907 and then not Is_RTE
(Obj_Type
, RE_Address
)),
3909 New_Occurrence_Of
(Obj_Type
, Loc
));
3910 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
3911 Prepend_To
(New_Plist
, Decl
);
3914 end Build_Protected_Spec
;
3916 ---------------------------------------
3917 -- Build_Protected_Sub_Specification --
3918 ---------------------------------------
3920 function Build_Protected_Sub_Specification
3922 Prot_Typ
: Entity_Id
;
3923 Mode
: Subprogram_Protection_Mode
) return Node_Id
3925 Loc
: constant Source_Ptr
:= Sloc
(N
);
3929 New_Plist
: List_Id
;
3932 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
3933 (Dispatching_Mode
=> ' ',
3934 Protected_Mode
=> 'P',
3935 Unprotected_Mode
=> 'N');
3938 if Ekind
(Defining_Unit_Name
(Specification
(N
))) = E_Subprogram_Body
3940 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
3945 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
3948 Build_Protected_Spec
3949 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
3950 Mode
= Unprotected_Mode
);
3952 Make_Defining_Identifier
(Loc
,
3953 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
3955 -- Reference the original nondispatching subprogram since the analysis
3956 -- of the object.operation notation may need its original name (see
3957 -- Sem_Ch4.Names_Match).
3959 if Mode
= Dispatching_Mode
then
3960 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
3961 Set_Original_Protected_Subprogram
(New_Id
, Def_Id
);
3964 -- Link the protected or unprotected version to the original subprogram
3967 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
3968 Set_Protected_Subprogram
(New_Id
, Def_Id
);
3970 -- The unprotected operation carries the user code, and debugging
3971 -- information must be generated for it, even though this spec does
3972 -- not come from source. It is also convenient to allow gdb to step
3973 -- into the protected operation, even though it only contains lock/
3976 Set_Debug_Info_Needed
(New_Id
);
3978 -- If a pragma Eliminate applies to the source entity, the internal
3979 -- subprograms will be eliminated as well.
3981 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
3983 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
3985 Make_Procedure_Specification
(Loc
,
3986 Defining_Unit_Name
=> New_Id
,
3987 Parameter_Specifications
=> New_Plist
);
3989 -- Create a new specification for the anonymous subprogram type
3993 Make_Function_Specification
(Loc
,
3994 Defining_Unit_Name
=> New_Id
,
3995 Parameter_Specifications
=> New_Plist
,
3996 Result_Definition
=>
3997 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
3999 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
4003 end Build_Protected_Sub_Specification
;
4005 -------------------------------------
4006 -- Build_Protected_Subprogram_Body --
4007 -------------------------------------
4009 function Build_Protected_Subprogram_Body
4012 N_Op_Spec
: Node_Id
) return Node_Id
4014 Exc_Safe
: constant Boolean := not Might_Raise
(N
);
4015 -- True if N cannot raise an exception
4017 Loc
: constant Source_Ptr
:= Sloc
(N
);
4018 Op_Spec
: constant Node_Id
:= Specification
(N
);
4019 P_Op_Spec
: constant Node_Id
:=
4020 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
4023 Lock_Name
: Node_Id
;
4024 Lock_Stmt
: Node_Id
;
4025 Object_Parm
: Node_Id
;
4028 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
4029 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
4033 Unprot_Call
: Node_Id
;
4036 -- Build a list of the formal parameters of the protected version of
4037 -- the subprogram to use as the actual parameters of the unprotected
4040 Uactuals
:= New_List
;
4041 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
4042 while Present
(Pformal
) loop
4043 Append_To
(Uactuals
,
4044 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
4048 -- Make a call to the unprotected version of the subprogram built above
4049 -- for use by the protected version built below.
4051 if Nkind
(Op_Spec
) = N_Function_Specification
then
4053 R
:= Make_Temporary
(Loc
, 'R');
4056 Make_Object_Declaration
(Loc
,
4057 Defining_Identifier
=> R
,
4058 Constant_Present
=> True,
4059 Object_Definition
=>
4060 New_Copy
(Result_Definition
(N_Op_Spec
)),
4062 Make_Function_Call
(Loc
,
4064 Make_Identifier
(Loc
,
4065 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4066 Parameter_Associations
=> Uactuals
));
4069 Make_Simple_Return_Statement
(Loc
,
4070 Expression
=> New_Occurrence_Of
(R
, Loc
));
4074 Make_Simple_Return_Statement
(Loc
,
4076 Make_Function_Call
(Loc
,
4078 Make_Identifier
(Loc
,
4079 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4080 Parameter_Associations
=> Uactuals
));
4083 Lock_Kind
:= RE_Lock_Read_Only
;
4087 Make_Procedure_Call_Statement
(Loc
,
4089 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4090 Parameter_Associations
=> Uactuals
);
4092 Lock_Kind
:= RE_Lock
;
4095 -- Wrap call in block that will be covered by an at_end handler
4097 if not Exc_Safe
then
4099 Make_Block_Statement
(Loc
,
4100 Handled_Statement_Sequence
=>
4101 Make_Handled_Sequence_Of_Statements
(Loc
,
4102 Statements
=> New_List
(Unprot_Call
)));
4105 -- Make the protected subprogram body. This locks the protected
4106 -- object and calls the unprotected version of the subprogram.
4108 case Corresponding_Runtime_Package
(Pid
) is
4109 when System_Tasking_Protected_Objects_Entries
=>
4110 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entries
), Loc
);
4112 when System_Tasking_Protected_Objects_Single_Entry
=>
4113 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entry
), Loc
);
4115 when System_Tasking_Protected_Objects
=>
4116 Lock_Name
:= New_Occurrence_Of
(RTE
(Lock_Kind
), Loc
);
4119 raise Program_Error
;
4123 Make_Attribute_Reference
(Loc
,
4125 Make_Selected_Component
(Loc
,
4126 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4127 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4128 Attribute_Name
=> Name_Unchecked_Access
);
4131 Make_Procedure_Call_Statement
(Loc
,
4133 Parameter_Associations
=> New_List
(Object_Parm
));
4135 if Abort_Allowed
then
4137 Build_Runtime_Call
(Loc
, RE_Abort_Defer
),
4141 Stmts
:= New_List
(Lock_Stmt
);
4144 if not Exc_Safe
then
4145 Append
(Unprot_Call
, Stmts
);
4147 if Nkind
(Op_Spec
) = N_Function_Specification
then
4149 Stmts
:= Empty_List
;
4151 Append
(Unprot_Call
, Stmts
);
4154 -- Historical note: Previously, call to the cleanup was inserted
4155 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4156 -- which is also shared by the 'not Exc_Safe' path.
4158 Build_Protected_Subprogram_Call_Cleanup
(Op_Spec
, Pid
, Loc
, Stmts
);
4160 if Nkind
(Op_Spec
) = N_Function_Specification
then
4161 Append_To
(Stmts
, Return_Stmt
);
4162 Append_To
(Pre_Stmts
,
4163 Make_Block_Statement
(Loc
,
4164 Declarations
=> New_List
(Unprot_Call
),
4165 Handled_Statement_Sequence
=>
4166 Make_Handled_Sequence_Of_Statements
(Loc
,
4167 Statements
=> Stmts
)));
4173 Make_Subprogram_Body
(Loc
,
4174 Declarations
=> Empty_List
,
4175 Specification
=> P_Op_Spec
,
4176 Handled_Statement_Sequence
=>
4177 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4179 -- Mark this subprogram as a protected subprogram body so that the
4180 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4181 -- path as otherwise the cleanup has already been inserted.
4183 if not Exc_Safe
then
4184 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4188 end Build_Protected_Subprogram_Body
;
4190 -------------------------------------
4191 -- Build_Protected_Subprogram_Call --
4192 -------------------------------------
4194 procedure Build_Protected_Subprogram_Call
4198 External
: Boolean := True)
4200 Loc
: constant Source_Ptr
:= Sloc
(N
);
4201 Sub
: constant Entity_Id
:= Entity
(Name
);
4207 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4210 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4213 if Present
(Parameter_Associations
(N
)) then
4214 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4219 -- If the type is an untagged derived type, convert to the root type,
4220 -- which is the one on which the operations are defined.
4222 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4223 and then not Is_Tagged_Type
(Etype
(Rec
))
4224 and then Is_Derived_Type
(Etype
(Rec
))
4226 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4227 Set_Subtype_Mark
(Rec
,
4228 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4231 Prepend
(Rec
, Params
);
4233 if Ekind
(Sub
) = E_Procedure
then
4235 Make_Procedure_Call_Statement
(Loc
,
4237 Parameter_Associations
=> Params
));
4240 pragma Assert
(Ekind
(Sub
) = E_Function
);
4242 Make_Function_Call
(Loc
,
4244 Parameter_Associations
=> Params
));
4246 -- Preserve type of call for subsequent processing (required for
4247 -- call to Wrap_Transient_Expression in the case of a shared passive
4250 Set_Etype
(N
, Etype
(New_Sub
));
4254 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
4255 and then Is_Entity_Name
(Expression
(Rec
))
4256 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
4258 Add_Shared_Var_Lock_Procs
(N
);
4260 end Build_Protected_Subprogram_Call
;
4262 ---------------------------------------------
4263 -- Build_Protected_Subprogram_Call_Cleanup --
4264 ---------------------------------------------
4266 procedure Build_Protected_Subprogram_Call_Cleanup
4275 -- If the associated protected object has entries, a protected
4276 -- procedure has to service entry queues. In this case generate:
4278 -- Service_Entries (_object._object'Access);
4280 if Nkind
(Op_Spec
) = N_Procedure_Specification
4281 and then Has_Entries
(Conc_Typ
)
4283 case Corresponding_Runtime_Package
(Conc_Typ
) is
4284 when System_Tasking_Protected_Objects_Entries
=>
4285 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entries
), Loc
);
4287 when System_Tasking_Protected_Objects_Single_Entry
=>
4288 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entry
), Loc
);
4291 raise Program_Error
;
4295 Make_Procedure_Call_Statement
(Loc
,
4297 Parameter_Associations
=> New_List
(
4298 Make_Attribute_Reference
(Loc
,
4300 Make_Selected_Component
(Loc
,
4301 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4302 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4303 Attribute_Name
=> Name_Unchecked_Access
))));
4307 -- Unlock (_object._object'Access);
4309 case Corresponding_Runtime_Package
(Conc_Typ
) is
4310 when System_Tasking_Protected_Objects_Entries
=>
4311 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entries
), Loc
);
4313 when System_Tasking_Protected_Objects_Single_Entry
=>
4314 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entry
), Loc
);
4316 when System_Tasking_Protected_Objects
=>
4317 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock
), Loc
);
4320 raise Program_Error
;
4324 Make_Procedure_Call_Statement
(Loc
,
4326 Parameter_Associations
=> New_List
(
4327 Make_Attribute_Reference
(Loc
,
4329 Make_Selected_Component
(Loc
,
4330 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4331 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4332 Attribute_Name
=> Name_Unchecked_Access
))));
4338 if Abort_Allowed
then
4339 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
4341 end Build_Protected_Subprogram_Call_Cleanup
;
4343 -------------------------
4344 -- Build_Selected_Name --
4345 -------------------------
4347 function Build_Selected_Name
4348 (Prefix
: Entity_Id
;
4349 Selector
: Entity_Id
;
4350 Append_Char
: Character := ' ') return Name_Id
4352 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4353 Select_Len
: Natural;
4356 Get_Name_String
(Chars
(Selector
));
4357 Select_Len
:= Name_Len
;
4358 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4359 Get_Name_String
(Chars
(Prefix
));
4361 -- If scope is anonymous type, discard suffix to recover name of
4362 -- single protected object. Otherwise use protected type name.
4364 if Name_Buffer
(Name_Len
) = 'T' then
4365 Name_Len
:= Name_Len
- 1;
4368 Add_Str_To_Name_Buffer
("__");
4369 for J
in 1 .. Select_Len
loop
4370 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4373 -- Now add the Append_Char if specified. The encoding to follow
4374 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4375 -- then the entity is associated to a protected type subprogram.
4376 -- Otherwise, it is a protected type entry. For each case, the
4377 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4379 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4381 if Append_Char
/= ' ' then
4382 if Append_Char
= 'P' or Append_Char
= 'N' then
4383 Add_Char_To_Name_Buffer
(Append_Char
);
4386 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4387 return New_External_Name
(Name_Find
, ' ', -1);
4392 end Build_Selected_Name
;
4394 -----------------------------
4395 -- Build_Simple_Entry_Call --
4396 -----------------------------
4398 -- A task entry call is converted to a call to Call_Simple
4401 -- P : parms := (parm, parm, parm);
4403 -- Call_Simple (acceptor-task, entry-index, P'Address);
4409 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4410 -- the parameters, and the constructed aggregate value contains either the
4411 -- parameters or, in the case of non-elementary types, references to these
4412 -- parameters. Then the address of this aggregate is passed to the runtime
4413 -- routine, along with the task id value and the task entry index value.
4414 -- Pnn is only required if parameters are present.
4416 -- The assignments after the call are present only in the case of in-out
4417 -- or out parameters for elementary types, and are used to assign back the
4418 -- resulting values of such parameters.
4420 -- Note: the reason that we insert a block here is that in the context
4421 -- of selects, conditional entry calls etc. the entry call statement
4422 -- appears on its own, not as an element of a list.
4424 -- A protected entry call is converted to a Protected_Entry_Call:
4427 -- P : E1_Params := (param, param, param);
4429 -- Bnn : Communications_Block;
4432 -- P : E1_Params := (param, param, param);
4433 -- Bnn : Communications_Block;
4436 -- Protected_Entry_Call (
4437 -- Object => po._object'Access,
4438 -- E => <entry index>;
4439 -- Uninterpreted_Data => P'Address;
4440 -- Mode => Simple_Call;
4447 procedure Build_Simple_Entry_Call
4456 -- If call has been inlined, nothing left to do
4458 if Nkind
(N
) = N_Block_Statement
then
4462 -- Convert entry call to Call_Simple call
4465 Loc
: constant Source_Ptr
:= Sloc
(N
);
4466 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4467 Stats
: constant List_Id
:= New_List
;
4470 Comm_Name
: Entity_Id
;
4474 Ent_Acc
: Entity_Id
;
4476 Iface_Tag
: Entity_Id
;
4477 Iface_Typ
: Entity_Id
;
4490 -- Simple entry and entry family cases merge here
4492 Ent
:= Entity
(Ename
);
4493 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4494 Conctyp
:= Etype
(Concval
);
4496 -- If prefix is an access type, dereference to obtain the task type
4498 if Is_Access_Type
(Conctyp
) then
4499 Conctyp
:= Designated_Type
(Conctyp
);
4502 -- Special case for protected subprogram calls
4504 if Is_Protected_Type
(Conctyp
)
4505 and then Is_Subprogram
(Entity
(Ename
))
4507 if not Is_Eliminated
(Entity
(Ename
)) then
4508 Build_Protected_Subprogram_Call
4509 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4516 -- First parameter is the Task_Id value from the task value or the
4517 -- Object from the protected object value, obtained by selecting
4518 -- the _Task_Id or _Object from the result of doing an unchecked
4519 -- conversion to convert the value to the corresponding record type.
4521 if Nkind
(Concval
) = N_Function_Call
4522 and then Is_Task_Type
(Conctyp
)
4523 and then Ada_Version
>= Ada_2005
4526 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4527 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4532 Make_Object_Declaration
(Loc
,
4533 Defining_Identifier
=> Obj
,
4534 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4535 Expression
=> ExpR
);
4536 Set_Etype
(Obj
, Conctyp
);
4537 Decls
:= New_List
(Decl
);
4538 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4545 Parm1
:= Concurrent_Ref
(Concval
);
4547 -- Second parameter is the entry index, computed by the routine
4548 -- provided for this purpose. The value of this expression is
4549 -- assigned to an intermediate variable to assure that any entry
4550 -- family index expressions are evaluated before the entry
4553 if not Is_Protected_Type
(Conctyp
)
4555 Corresponding_Runtime_Package
(Conctyp
) =
4556 System_Tasking_Protected_Objects_Entries
4558 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4561 Make_Object_Declaration
(Loc
,
4562 Defining_Identifier
=> X
,
4563 Object_Definition
=>
4564 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
4565 Expression
=> Actual_Index_Expression
(
4566 Loc
, Entity
(Ename
), Index
, Concval
));
4568 Append_To
(Decls
, Xdecl
);
4569 Parm2
:= New_Occurrence_Of
(X
, Loc
);
4576 -- The third parameter is the packaged parameters. If there are
4577 -- none, then it is just the null address, since nothing is passed.
4580 Parm3
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
4583 -- Case of parameters present, where third argument is the address
4584 -- of a packaged record containing the required parameter values.
4587 -- First build a list of parameter values, which are references to
4588 -- objects of the parameter types.
4592 Actual
:= First_Actual
(N
);
4593 Formal
:= First_Formal
(Ent
);
4594 while Present
(Actual
) loop
4596 -- If it is a by-copy type, copy it to a new variable. The
4597 -- packaged record has a field that points to this variable.
4599 if Is_By_Copy_Type
(Etype
(Actual
)) then
4601 Make_Object_Declaration
(Loc
,
4602 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4603 Aliased_Present
=> True,
4604 Object_Definition
=>
4605 New_Occurrence_Of
(Etype
(Formal
), Loc
));
4607 -- Mark the object as not needing initialization since the
4608 -- initialization is performed separately, avoiding errors
4609 -- on cases such as formals of null-excluding access types.
4611 Set_No_Initialization
(N_Node
);
4613 -- We must make a separate assignment statement for the
4614 -- case of limited types. We cannot assign it unless the
4615 -- Assignment_OK flag is set first. An out formal of an
4616 -- access type or whose type has a Default_Value must also
4617 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4618 -- but no constraint, predicate, or null-exclusion check is
4619 -- applied before the call.
4621 if Ekind
(Formal
) /= E_Out_Parameter
4622 or else Is_Access_Type
(Etype
(Formal
))
4624 (Is_Scalar_Type
(Etype
(Formal
))
4626 Present
(Default_Aspect_Value
(Etype
(Formal
))))
4629 New_Occurrence_Of
(Defining_Identifier
(N_Node
), Loc
);
4630 Set_Assignment_OK
(N_Var
);
4632 Make_Assignment_Statement
(Loc
,
4634 Expression
=> Relocate_Node
(Actual
)));
4636 -- Mark the object as internal, so we don't later reset
4637 -- No_Initialization flag in Default_Initialize_Object,
4638 -- which would lead to needless default initialization.
4639 -- We don't set this outside the if statement, because
4640 -- out scalar parameters without Default_Value do require
4641 -- default initialization if Initialize_Scalars applies.
4643 Set_Is_Internal
(Defining_Identifier
(N_Node
));
4645 -- If actual is an out parameter of a null-excluding
4646 -- access type, there is access check on entry, so set
4647 -- Suppress_Assignment_Checks on the generated statement
4648 -- that assigns the actual to the parameter block.
4650 Set_Suppress_Assignment_Checks
(Last
(Stats
));
4653 Append
(N_Node
, Decls
);
4656 Make_Attribute_Reference
(Loc
,
4657 Attribute_Name
=> Name_Unchecked_Access
,
4660 (Defining_Identifier
(N_Node
), Loc
)));
4663 -- Interface class-wide formal
4665 if Ada_Version
>= Ada_2005
4666 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4667 and then Is_Interface
(Etype
(Formal
))
4669 Iface_Typ
:= Etype
(Etype
(Formal
));
4672 -- formal_iface_type! (actual.iface_tag)'reference
4675 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4676 pragma Assert
(Present
(Iface_Tag
));
4679 Make_Reference
(Loc
,
4680 Unchecked_Convert_To
(Iface_Typ
,
4681 Make_Selected_Component
(Loc
,
4683 Relocate_Node
(Actual
),
4685 New_Occurrence_Of
(Iface_Tag
, Loc
)))));
4691 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4695 Next_Actual
(Actual
);
4696 Next_Formal_With_Extras
(Formal
);
4699 -- Now build the declaration of parameters initialized with the
4700 -- aggregate containing this constructed parameter list.
4702 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4705 Make_Object_Declaration
(Loc
,
4706 Defining_Identifier
=> P
,
4707 Object_Definition
=>
4708 New_Occurrence_Of
(Designated_Type
(Ent_Acc
), Loc
),
4710 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4713 Make_Attribute_Reference
(Loc
,
4714 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4715 Attribute_Name
=> Name_Address
);
4717 Append
(Pdecl
, Decls
);
4720 -- Now we can create the call, case of protected type
4722 if Is_Protected_Type
(Conctyp
) then
4723 case Corresponding_Runtime_Package
(Conctyp
) is
4724 when System_Tasking_Protected_Objects_Entries
=>
4726 -- Change the type of the index declaration
4728 Set_Object_Definition
(Xdecl
,
4729 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
));
4731 -- Some additional declarations for protected entry calls
4737 -- Bnn : Communications_Block;
4739 Comm_Name
:= Make_Temporary
(Loc
, 'B');
4742 Make_Object_Declaration
(Loc
,
4743 Defining_Identifier
=> Comm_Name
,
4744 Object_Definition
=>
4746 (RTE
(RE_Communication_Block
), Loc
)));
4748 -- Some additional statements for protected entry calls
4750 -- Protected_Entry_Call
4751 -- (Object => po._object'Access,
4752 -- E => <entry index>;
4753 -- Uninterpreted_Data => P'Address;
4754 -- Mode => Simple_Call;
4758 Make_Procedure_Call_Statement
(Loc
,
4760 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
4762 Parameter_Associations
=> New_List
(
4763 Make_Attribute_Reference
(Loc
,
4764 Attribute_Name
=> Name_Unchecked_Access
,
4768 New_Occurrence_Of
(RTE
(RE_Simple_Call
), Loc
),
4769 New_Occurrence_Of
(Comm_Name
, Loc
)));
4771 when System_Tasking_Protected_Objects_Single_Entry
=>
4773 -- Protected_Single_Entry_Call
4774 -- (Object => po._object'Access,
4775 -- Uninterpreted_Data => P'Address);
4778 Make_Procedure_Call_Statement
(Loc
,
4781 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
4783 Parameter_Associations
=> New_List
(
4784 Make_Attribute_Reference
(Loc
,
4785 Attribute_Name
=> Name_Unchecked_Access
,
4790 raise Program_Error
;
4793 -- Case of task type
4797 Make_Procedure_Call_Statement
(Loc
,
4799 New_Occurrence_Of
(RTE
(RE_Call_Simple
), Loc
),
4800 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
4804 Append_To
(Stats
, Call
);
4806 -- If there are out or in/out parameters by copy add assignment
4807 -- statements for the result values.
4809 if Present
(Parms
) then
4810 Actual
:= First_Actual
(N
);
4811 Formal
:= First_Formal
(Ent
);
4813 Set_Assignment_OK
(Actual
);
4814 while Present
(Actual
) loop
4815 if Is_By_Copy_Type
(Etype
(Actual
))
4816 and then Ekind
(Formal
) /= E_In_Parameter
4819 Make_Assignment_Statement
(Loc
,
4820 Name
=> New_Copy
(Actual
),
4822 Make_Explicit_Dereference
(Loc
,
4823 Make_Selected_Component
(Loc
,
4824 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4826 Make_Identifier
(Loc
, Chars
(Formal
)))));
4828 -- In all cases (including limited private types) we want
4829 -- the assignment to be valid.
4831 Set_Assignment_OK
(Name
(N_Node
));
4833 -- If the call is the triggering alternative in an
4834 -- asynchronous select, or the entry_call alternative of a
4835 -- conditional entry call, the assignments for in-out
4836 -- parameters are incorporated into the statement list that
4837 -- follows, so that there are executed only if the entry
4840 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
4841 and then N
= Triggering_Statement
(Parent
(N
)))
4843 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
4844 and then N
= Entry_Call_Statement
(Parent
(N
)))
4846 if No
(Statements
(Parent
(N
))) then
4847 Set_Statements
(Parent
(N
), New_List
);
4850 Prepend
(N_Node
, Statements
(Parent
(N
)));
4853 Insert_After
(Call
, N_Node
);
4857 Next_Actual
(Actual
);
4858 Next_Formal_With_Extras
(Formal
);
4862 -- Finally, create block and analyze it
4865 Make_Block_Statement
(Loc
,
4866 Declarations
=> Decls
,
4867 Handled_Statement_Sequence
=>
4868 Make_Handled_Sequence_Of_Statements
(Loc
,
4869 Statements
=> Stats
)));
4873 end Build_Simple_Entry_Call
;
4875 --------------------------------
4876 -- Build_Task_Activation_Call --
4877 --------------------------------
4879 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
4880 function Activation_Call_Loc
return Source_Ptr
;
4881 -- Find a suitable source location for the activation call
4883 -------------------------
4884 -- Activation_Call_Loc --
4885 -------------------------
4887 function Activation_Call_Loc
return Source_Ptr
is
4889 -- The activation call must carry the location of the "end" keyword
4890 -- when the context is a package declaration.
4892 if Nkind
(N
) = N_Package_Declaration
then
4893 return End_Keyword_Location
(N
);
4895 -- Otherwise the activation call must carry the location of the
4899 return Begin_Keyword_Location
(N
);
4901 end Activation_Call_Loc
;
4912 -- Start of processing for Build_Task_Activation_Call
4915 -- For sequential elaboration policy, all the tasks will be activated at
4916 -- the end of the elaboration.
4918 if Partition_Elaboration_Policy
= 'S' then
4921 -- Do not create an activation call for a package spec if the package
4922 -- has a completing body. The activation call will be inserted after
4923 -- the "begin" of the body.
4925 elsif Nkind
(N
) = N_Package_Declaration
4926 and then Present
(Corresponding_Body
(N
))
4931 -- Obtain the activation chain entity. Block statements, entry bodies,
4932 -- subprogram bodies, and task bodies keep the entity in their nodes.
4933 -- Package bodies on the other hand store it in the declaration of the
4934 -- corresponding package spec.
4938 if Nkind
(Owner
) = N_Package_Body
then
4939 Owner
:= Unit_Declaration_Node
(Corresponding_Spec
(Owner
));
4942 Chain
:= Activation_Chain_Entity
(Owner
);
4944 -- Nothing to do when there are no tasks to activate. This is indicated
4945 -- by a missing activation chain entity.
4951 -- The location of the activation call must be as close as possible to
4952 -- the intended semantic location of the activation because the ABE
4953 -- mechanism relies heavily on accurate locations.
4955 Loc
:= Activation_Call_Loc
;
4957 if Restricted_Profile
then
4958 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Restricted_Tasks
), Loc
);
4960 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
);
4964 Make_Procedure_Call_Statement
(Loc
,
4966 Parameter_Associations
=>
4967 New_List
(Make_Attribute_Reference
(Loc
,
4968 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
4969 Attribute_Name
=> Name_Unchecked_Access
)));
4971 if Nkind
(N
) = N_Package_Declaration
then
4972 if Present
(Private_Declarations
(Specification
(N
))) then
4973 Append
(Call
, Private_Declarations
(Specification
(N
)));
4975 Append
(Call
, Visible_Declarations
(Specification
(N
)));
4979 -- The call goes at the start of the statement sequence after the
4980 -- start of exception range label if one is present.
4982 if Present
(Handled_Statement_Sequence
(N
)) then
4983 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
4985 -- A special case, skip exception range label if one is present
4986 -- (from front end zcx processing).
4988 if Nkind
(Stmt
) = N_Label
and then Exception_Junk
(Stmt
) then
4992 -- Another special case, if the first statement is a block from
4993 -- optimization of a local raise to a goto, then the call goes
4994 -- inside this block.
4996 if Nkind
(Stmt
) = N_Block_Statement
4997 and then Exception_Junk
(Stmt
)
4999 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
5002 -- Insertion point is after any exception label pushes, since we
5003 -- want it covered by any local handlers.
5005 while Nkind
(Stmt
) in N_Push_xxx_Label
loop
5009 -- Now we have the proper insertion point
5011 Insert_Before
(Stmt
, Call
);
5014 Set_Handled_Statement_Sequence
(N
,
5015 Make_Handled_Sequence_Of_Statements
(Loc
,
5016 Statements
=> New_List
(Call
)));
5022 if Legacy_Elaboration_Checks
then
5023 Check_Task_Activation
(N
);
5025 end Build_Task_Activation_Call
;
5027 -------------------------------
5028 -- Build_Task_Allocate_Block --
5029 -------------------------------
5031 procedure Build_Task_Allocate_Block
5036 T
: constant Entity_Id
:= Entity
(Expression
(N
));
5037 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
5038 Loc
: constant Source_Ptr
:= Sloc
(N
);
5039 Chain
: constant Entity_Id
:=
5040 Make_Defining_Identifier
(Loc
, Name_uChain
);
5041 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5046 Make_Block_Statement
(Loc
,
5047 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5048 Declarations
=> New_List
(
5050 -- _Chain : Activation_Chain;
5052 Make_Object_Declaration
(Loc
,
5053 Defining_Identifier
=> Chain
,
5054 Aliased_Present
=> True,
5055 Object_Definition
=>
5056 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5058 Handled_Statement_Sequence
=>
5059 Make_Handled_Sequence_Of_Statements
(Loc
,
5061 Statements
=> New_List
(
5065 Make_Procedure_Call_Statement
(Loc
,
5066 Name
=> New_Occurrence_Of
(Init
, Loc
),
5067 Parameter_Associations
=> Args
),
5069 -- Activate_Tasks (_Chain);
5071 Make_Procedure_Call_Statement
(Loc
,
5072 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5073 Parameter_Associations
=> New_List
(
5074 Make_Attribute_Reference
(Loc
,
5075 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5076 Attribute_Name
=> Name_Unchecked_Access
))))),
5078 Has_Created_Identifier
=> True,
5079 Is_Task_Allocation_Block
=> True);
5082 Make_Implicit_Label_Declaration
(Loc
,
5083 Defining_Identifier
=> Blkent
,
5084 Label_Construct
=> Block
));
5086 Append_To
(Actions
, Block
);
5088 Set_Activation_Chain_Entity
(Block
, Chain
);
5089 end Build_Task_Allocate_Block
;
5091 -----------------------------------------------
5092 -- Build_Task_Allocate_Block_With_Init_Stmts --
5093 -----------------------------------------------
5095 procedure Build_Task_Allocate_Block_With_Init_Stmts
5098 Init_Stmts
: List_Id
)
5100 Loc
: constant Source_Ptr
:= Sloc
(N
);
5101 Chain
: constant Entity_Id
:=
5102 Make_Defining_Identifier
(Loc
, Name_uChain
);
5103 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5107 Append_To
(Init_Stmts
,
5108 Make_Procedure_Call_Statement
(Loc
,
5109 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5110 Parameter_Associations
=> New_List
(
5111 Make_Attribute_Reference
(Loc
,
5112 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5113 Attribute_Name
=> Name_Unchecked_Access
))));
5116 Make_Block_Statement
(Loc
,
5117 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5118 Declarations
=> New_List
(
5120 -- _Chain : Activation_Chain;
5122 Make_Object_Declaration
(Loc
,
5123 Defining_Identifier
=> Chain
,
5124 Aliased_Present
=> True,
5125 Object_Definition
=>
5126 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5128 Handled_Statement_Sequence
=>
5129 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5131 Has_Created_Identifier
=> True,
5132 Is_Task_Allocation_Block
=> True);
5135 Make_Implicit_Label_Declaration
(Loc
,
5136 Defining_Identifier
=> Blkent
,
5137 Label_Construct
=> Block
));
5139 Append_To
(Actions
, Block
);
5141 Set_Activation_Chain_Entity
(Block
, Chain
);
5142 end Build_Task_Allocate_Block_With_Init_Stmts
;
5144 -----------------------------------
5145 -- Build_Task_Proc_Specification --
5146 -----------------------------------
5148 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5149 Loc
: constant Source_Ptr
:= Sloc
(T
);
5150 Spec_Id
: Entity_Id
;
5153 -- Case of explicit task type, suffix TB
5155 if Comes_From_Source
(T
) then
5157 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), "TB"));
5159 -- Case of anonymous task type, suffix B
5163 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), 'B'));
5166 Set_Is_Internal
(Spec_Id
);
5168 -- Associate the procedure with the task, if this is the declaration
5169 -- (and not the body) of the procedure.
5171 if No
(Task_Body_Procedure
(T
)) then
5172 Set_Task_Body_Procedure
(T
, Spec_Id
);
5176 Make_Procedure_Specification
(Loc
,
5177 Defining_Unit_Name
=> Spec_Id
,
5178 Parameter_Specifications
=> New_List
(
5179 Make_Parameter_Specification
(Loc
,
5180 Defining_Identifier
=>
5181 Make_Defining_Identifier
(Loc
, Name_uTask
),
5183 Make_Access_Definition
(Loc
,
5185 New_Occurrence_Of
(Corresponding_Record_Type
(T
), Loc
)))));
5186 end Build_Task_Proc_Specification
;
5188 ---------------------------------------
5189 -- Build_Unprotected_Subprogram_Body --
5190 ---------------------------------------
5192 function Build_Unprotected_Subprogram_Body
5194 Pid
: Node_Id
) return Node_Id
5196 Decls
: constant List_Id
:= Declarations
(N
);
5199 -- Add renamings for the Protection object, discriminals, privals, and
5200 -- the entry index constant for use by debugger.
5202 Debug_Private_Data_Declarations
(Decls
);
5204 -- Make an unprotected version of the subprogram for use within the same
5205 -- object, with a new name and an additional parameter representing the
5209 Make_Subprogram_Body
(Sloc
(N
),
5211 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5212 Declarations
=> Decls
,
5213 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5214 end Build_Unprotected_Subprogram_Body
;
5216 ----------------------------
5217 -- Collect_Entry_Families --
5218 ----------------------------
5220 procedure Collect_Entry_Families
5223 Current_Node
: in out Node_Id
;
5224 Conctyp
: Entity_Id
)
5227 Efam_Decl
: Node_Id
;
5228 Efam_Type
: Entity_Id
;
5231 Efam
:= First_Entity
(Conctyp
);
5232 while Present
(Efam
) loop
5233 if Ekind
(Efam
) = E_Entry_Family
then
5234 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5239 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
5241 Bas_Decl
: Node_Id
:= Empty
;
5246 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
5248 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
5249 Bas
:= Make_Temporary
(Loc
, 'B');
5252 Make_Subtype_Declaration
(Loc
,
5253 Defining_Identifier
=> Bas
,
5254 Subtype_Indication
=>
5255 Make_Subtype_Indication
(Loc
,
5257 New_Occurrence_Of
(Standard_Integer
, Loc
),
5259 Make_Range_Constraint
(Loc
,
5260 Range_Expression
=> Make_Range
(Loc
,
5261 Make_Integer_Literal
5262 (Loc
, -Entry_Family_Bound
),
5263 Make_Integer_Literal
5264 (Loc
, Entry_Family_Bound
- 1)))));
5266 Insert_After
(Current_Node
, Bas_Decl
);
5267 Current_Node
:= Bas_Decl
;
5272 Make_Full_Type_Declaration
(Loc
,
5273 Defining_Identifier
=> Efam_Type
,
5275 Make_Unconstrained_Array_Definition
(Loc
,
5277 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
5279 Component_Definition
=>
5280 Make_Component_Definition
(Loc
,
5281 Aliased_Present
=> False,
5282 Subtype_Indication
=>
5283 New_Occurrence_Of
(Standard_Character
, Loc
))));
5286 Insert_After
(Current_Node
, Efam_Decl
);
5287 Current_Node
:= Efam_Decl
;
5288 Analyze
(Efam_Decl
);
5291 Make_Component_Declaration
(Loc
,
5292 Defining_Identifier
=>
5293 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5295 Component_Definition
=>
5296 Make_Component_Definition
(Loc
,
5297 Aliased_Present
=> False,
5298 Subtype_Indication
=>
5299 Make_Subtype_Indication
(Loc
,
5301 New_Occurrence_Of
(Efam_Type
, Loc
),
5304 Make_Index_Or_Discriminant_Constraint
(Loc
,
5305 Constraints
=> New_List
(
5307 (Etype
(Discrete_Subtype_Definition
5308 (Parent
(Efam
))), Loc
)))))));
5314 end Collect_Entry_Families
;
5316 -----------------------
5317 -- Concurrent_Object --
5318 -----------------------
5320 function Concurrent_Object
5321 (Spec_Id
: Entity_Id
;
5322 Conc_Typ
: Entity_Id
) return Entity_Id
5325 -- Parameter _O or _object
5327 if Is_Protected_Type
(Conc_Typ
) then
5328 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5333 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5334 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5336 end Concurrent_Object
;
5338 ----------------------
5339 -- Copy_Result_Type --
5340 ----------------------
5342 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5343 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5348 -- If the result type is an access_to_subprogram, we must create new
5349 -- entities for its spec.
5351 if Nkind
(New_Res
) = N_Access_Definition
5352 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5354 -- Provide new entities for the formals
5356 Par_Spec
:= First
(Parameter_Specifications
5357 (Access_To_Subprogram_Definition
(New_Res
)));
5358 while Present
(Par_Spec
) loop
5359 Formal
:= Defining_Identifier
(Par_Spec
);
5360 Set_Defining_Identifier
(Par_Spec
,
5361 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5367 end Copy_Result_Type
;
5369 --------------------
5370 -- Concurrent_Ref --
5371 --------------------
5373 -- The expression returned for a reference to a concurrent object has the
5376 -- taskV!(name)._Task_Id
5380 -- objectV!(name)._Object
5382 -- for a protected object. For the case of an access to a concurrent
5383 -- object, there is an extra explicit dereference:
5385 -- taskV!(name.all)._Task_Id
5386 -- objectV!(name.all)._Object
5388 -- here taskV and objectV are the types for the associated records, which
5389 -- contain the required _Task_Id and _Object fields for tasks and protected
5390 -- objects, respectively.
5392 -- For the case of a task type name, the expression is
5396 -- i.e. a call to the Self function which returns precisely this Task_Id
5398 -- For the case of a protected type name, the expression is
5402 -- which is a renaming of the _object field of the current object
5403 -- record, passed into protected operations as a parameter.
5405 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5406 Loc
: constant Source_Ptr
:= Sloc
(N
);
5407 Ntyp
: constant Entity_Id
:= Etype
(N
);
5411 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5412 -- Check whether the reference is to the immediately enclosing task
5413 -- type, or to an outer one (rare but legal).
5415 ---------------------
5416 -- Is_Current_Task --
5417 ---------------------
5419 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5423 Scop
:= Current_Scope
;
5424 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
5428 elsif Is_Task_Type
(Scop
) then
5431 -- If this is a procedure nested within the task type, we must
5432 -- assume that it can be called from an inner task, and therefore
5433 -- cannot treat it as a local reference.
5435 elsif Is_Overloadable
(Scop
) and then In_Open_Scopes
(T
) then
5439 Scop
:= Scope
(Scop
);
5443 -- We know that we are within the task body, so should have found it
5446 raise Program_Error
;
5447 end Is_Current_Task
;
5449 -- Start of processing for Concurrent_Ref
5452 if Is_Access_Type
(Ntyp
) then
5453 Dtyp
:= Designated_Type
(Ntyp
);
5455 if Is_Protected_Type
(Dtyp
) then
5456 Sel
:= Name_uObject
;
5458 Sel
:= Name_uTask_Id
;
5462 Make_Selected_Component
(Loc
,
5464 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5465 Make_Explicit_Dereference
(Loc
, N
)),
5466 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5468 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5469 if Is_Task_Type
(Entity
(N
)) then
5471 if Is_Current_Task
(Entity
(N
)) then
5473 Make_Function_Call
(Loc
,
5474 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
));
5479 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5480 T_Body
: constant Node_Id
:=
5481 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5485 Make_Object_Declaration
(Loc
,
5486 Defining_Identifier
=> T_Self
,
5487 Object_Definition
=>
5488 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5490 Make_Function_Call
(Loc
,
5491 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
)));
5492 Prepend
(Decl
, Declarations
(T_Body
));
5494 Set_Scope
(T_Self
, Entity
(N
));
5495 return New_Occurrence_Of
(T_Self
, Loc
);
5500 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5503 New_Occurrence_Of
(Find_Protection_Object
(Current_Scope
), Loc
);
5507 if Is_Protected_Type
(Ntyp
) then
5508 Sel
:= Name_uObject
;
5509 elsif Is_Task_Type
(Ntyp
) then
5510 Sel
:= Name_uTask_Id
;
5512 raise Program_Error
;
5516 Make_Selected_Component
(Loc
,
5518 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5520 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5524 ------------------------
5525 -- Convert_Concurrent --
5526 ------------------------
5528 function Convert_Concurrent
5530 Typ
: Entity_Id
) return Node_Id
5533 if not Is_Concurrent_Type
(Typ
) then
5537 Unchecked_Convert_To
5538 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5540 end Convert_Concurrent
;
5542 -------------------------------------
5543 -- Create_Secondary_Stack_For_Task --
5544 -------------------------------------
5546 function Create_Secondary_Stack_For_Task
(T
: Node_Id
) return Boolean is
5549 (Restriction_Active
(No_Implicit_Heap_Allocations
)
5550 or else Restriction_Active
(No_Implicit_Task_Allocations
))
5551 and then not Restriction_Active
(No_Secondary_Stack
)
5552 and then Has_Rep_Pragma
5553 (T
, Name_Secondary_Stack_Size
, Check_Parents
=> False);
5554 end Create_Secondary_Stack_For_Task
;
5556 -------------------------------------
5557 -- Debug_Private_Data_Declarations --
5558 -------------------------------------
5560 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5561 Debug_Nod
: Node_Id
;
5565 Decl
:= First
(Decls
);
5566 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5568 -- Declaration for concurrent entity _object and its access type,
5569 -- along with the entry index subtype:
5570 -- type prot_typVP is access prot_typV;
5571 -- _object : prot_typVP := prot_typV (_O);
5572 -- subtype Jnn is <Type of Index> range Low .. High;
5574 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
5575 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5577 -- Declaration for the Protection object, discriminals, privals, and
5578 -- entry index constant:
5579 -- conc_typR : protection_typ renames _object._object;
5580 -- discr_nameD : discr_typ renames _object.discr_name;
5581 -- discr_nameD : discr_typ renames _task.discr_name;
5582 -- prival_name : comp_typ renames _object.comp_name;
5583 -- J : constant Jnn :=
5584 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5586 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5587 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5588 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5590 if Present
(Debug_Nod
) then
5591 Insert_After
(Decl
, Debug_Nod
);
5597 end Debug_Private_Data_Declarations
;
5599 ------------------------------
5600 -- Ensure_Statement_Present --
5601 ------------------------------
5603 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5607 if Opt
.Suppress_Control_Flow_Optimizations
5608 and then Is_Empty_List
(Statements
(Alt
))
5610 Stmt
:= Make_Null_Statement
(Loc
);
5612 -- Mark NULL statement as coming from source so that it is not
5613 -- eliminated by GIGI.
5615 -- Another covert channel. If this is a requirement, it must be
5616 -- documented in sinfo/einfo ???
5618 Set_Comes_From_Source
(Stmt
, True);
5620 Set_Statements
(Alt
, New_List
(Stmt
));
5622 end Ensure_Statement_Present
;
5624 ----------------------------
5625 -- Entry_Index_Expression --
5626 ----------------------------
5628 function Entry_Index_Expression
5632 Ttyp
: Entity_Id
) return Node_Id
5642 -- The queues of entries and entry families appear in textual order in
5643 -- the associated record. The entry index is computed as the sum of the
5644 -- number of queues for all entries that precede the designated one, to
5645 -- which is added the index expression, if this expression denotes a
5646 -- member of a family.
5648 -- The following is a place holder for the count of simple entries
5650 Num
:= Make_Integer_Literal
(Sloc
, 1);
5652 -- We construct an expression which is a series of addition operations.
5653 -- The first operand is the number of single entries that precede this
5654 -- one, the second operand is the index value relative to the start of
5655 -- the referenced family, and the remaining operands are the lengths of
5656 -- the entry families that precede this entry, i.e. the constructed
5659 -- number_simple_entries +
5660 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5661 -- family'length + ...
5663 -- where index-value is the given index value, and s is the index
5664 -- subtype (we have to use pos because the subtype might be an
5665 -- enumeration type preventing direct subtraction). Note that the task
5666 -- entry array is one-indexed.
5668 -- The upper bound of the entry family may be a discriminant, so we
5669 -- retrieve the lower bound explicitly to compute offset, rather than
5670 -- using the index subtype which may mention a discriminant.
5672 if Present
(Index
) then
5673 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
5681 Make_Attribute_Reference
(Sloc
,
5682 Attribute_Name
=> Name_Pos
,
5683 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
5684 Expressions
=> New_List
(Relocate_Node
(Index
))),
5692 -- Now add lengths of preceding entries and entry families
5694 Prev
:= First_Entity
(Ttyp
);
5695 while Chars
(Prev
) /= Chars
(Ent
)
5696 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5697 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5699 if Ekind
(Prev
) = E_Entry
then
5700 Set_Intval
(Num
, Intval
(Num
) + 1);
5702 elsif Ekind
(Prev
) = E_Entry_Family
then
5703 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
5704 Lo
:= Type_Low_Bound
(S
);
5705 Hi
:= Type_High_Bound
(S
);
5710 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5712 -- Other components are anonymous types to be ignored
5722 end Entry_Index_Expression
;
5724 ---------------------------
5725 -- Establish_Task_Master --
5726 ---------------------------
5728 procedure Establish_Task_Master
(N
: Node_Id
) is
5732 if Restriction_Active
(No_Task_Hierarchy
) = False then
5733 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5735 -- The block may have no declarations (and nevertheless be a task
5736 -- master) if it contains a call that may return an object that
5739 if No
(Declarations
(N
)) then
5740 Set_Declarations
(N
, New_List
(Call
));
5742 Prepend_To
(Declarations
(N
), Call
);
5747 end Establish_Task_Master
;
5749 --------------------------------
5750 -- Expand_Accept_Declarations --
5751 --------------------------------
5753 -- Part of the expansion of an accept statement involves the creation of
5754 -- a declaration that can be referenced from the statement sequence of
5759 -- This declaration is inserted immediately before the accept statement
5760 -- and it is important that it be inserted before the statements of the
5761 -- statement sequence are analyzed. Thus it would be too late to create
5762 -- this declaration in the Expand_N_Accept_Statement routine, which is
5763 -- why there is a separate procedure to be called directly from Sem_Ch9.
5765 -- Ann is used to hold the address of the record containing the parameters
5766 -- (see Expand_N_Entry_Call for more details on how this record is built).
5767 -- References to the parameters do an unchecked conversion of this address
5768 -- to a pointer to the required record type, and then access the field that
5769 -- holds the value of the required parameter. The entity for the address
5770 -- variable is held as the top stack element (i.e. the last element) of the
5771 -- Accept_Address stack in the corresponding entry entity, and this element
5772 -- must be set in place before the statements are processed.
5774 -- The above description applies to the case of a stand alone accept
5775 -- statement, i.e. one not appearing as part of a select alternative.
5777 -- For the case of an accept that appears as part of a select alternative
5778 -- of a selective accept, we must still create the declaration right away,
5779 -- since Ann is needed immediately, but there is an important difference:
5781 -- The declaration is inserted before the selective accept, not before
5782 -- the accept statement (which is not part of a list anyway, and so would
5783 -- not accommodate inserted declarations)
5785 -- We only need one address variable for the entire selective accept. So
5786 -- the Ann declaration is created only for the first accept alternative,
5787 -- and subsequent accept alternatives reference the same Ann variable.
5789 -- We can distinguish the two cases by seeing whether the accept statement
5790 -- is part of a list. If not, then it must be in an accept alternative.
5792 -- To expand the requeue statement, a label is provided at the end of the
5793 -- accept statement or alternative of which it is a part, so that the
5794 -- statement can be skipped after the requeue is complete. This label is
5795 -- created here rather than during the expansion of the accept statement,
5796 -- because it will be needed by any requeue statements within the accept,
5797 -- which are expanded before the accept.
5799 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
5800 Loc
: constant Source_Ptr
:= Sloc
(N
);
5801 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5802 Ann
: Entity_Id
:= Empty
;
5809 if Expander_Active
then
5811 -- If we have no handled statement sequence, we may need to build
5812 -- a dummy sequence consisting of a null statement. This can be
5813 -- skipped if the trivial accept optimization is permitted.
5815 if not Trivial_Accept_OK
5816 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
5818 Set_Handled_Statement_Sequence
(N
,
5819 Make_Handled_Sequence_Of_Statements
(Loc
,
5820 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5823 -- Create and declare two labels to be placed at the end of the
5824 -- accept statement. The first label is used to allow requeues to
5825 -- skip the remainder of entry processing. The second label is used
5826 -- to skip the remainder of entry processing if the rendezvous
5827 -- completes in the middle of the accept body.
5829 if Present
(Handled_Statement_Sequence
(N
)) then
5834 Ent
:= Make_Temporary
(Loc
, 'L');
5835 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5837 Make_Implicit_Label_Declaration
(Loc
,
5838 Defining_Identifier
=> Ent
,
5839 Label_Construct
=> Lab
);
5840 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5842 Ent
:= Make_Temporary
(Loc
, 'L');
5843 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5845 Make_Implicit_Label_Declaration
(Loc
,
5846 Defining_Identifier
=> Ent
,
5847 Label_Construct
=> Lab
);
5848 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5856 -- Case of stand alone accept statement
5858 if Is_List_Member
(N
) then
5860 if Present
(Handled_Statement_Sequence
(N
)) then
5861 Ann
:= Make_Temporary
(Loc
, 'A');
5864 Make_Object_Declaration
(Loc
,
5865 Defining_Identifier
=> Ann
,
5866 Object_Definition
=>
5867 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5869 Insert_Before_And_Analyze
(N
, Adecl
);
5870 Insert_Before_And_Analyze
(N
, Ldecl
);
5871 Insert_Before_And_Analyze
(N
, Ldecl2
);
5874 -- Case of accept statement which is in an accept alternative
5878 Acc_Alt
: constant Node_Id
:= Parent
(N
);
5879 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
5883 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
5884 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
5886 -- ??? Consider a single label for select statements
5888 if Present
(Handled_Statement_Sequence
(N
)) then
5890 Statements
(Handled_Statement_Sequence
(N
)));
5894 Statements
(Handled_Statement_Sequence
(N
)));
5898 -- Find first accept alternative of the selective accept. A
5899 -- valid selective accept must have at least one accept in it.
5901 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
5903 while Nkind
(Alt
) /= N_Accept_Alternative
loop
5907 -- If this is the first accept statement, then we have to
5908 -- create the Ann variable, as for the stand alone case, except
5909 -- that it is inserted before the selective accept. Similarly,
5910 -- a label for requeue expansion must be declared.
5912 if N
= Accept_Statement
(Alt
) then
5913 Ann
:= Make_Temporary
(Loc
, 'A');
5915 Make_Object_Declaration
(Loc
,
5916 Defining_Identifier
=> Ann
,
5917 Object_Definition
=>
5918 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5920 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
5922 -- If this is not the first accept statement, then find the Ann
5923 -- variable allocated by the first accept and use it.
5927 Node
(Last_Elmt
(Accept_Address
5928 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
5933 -- Merge here with Ann either created or referenced, and Adecl
5934 -- pointing to the corresponding declaration. Remaining processing
5935 -- is the same for the two cases.
5937 if Present
(Ann
) then
5938 Append_Elmt
(Ann
, Accept_Address
(Ent
));
5939 Set_Debug_Info_Needed
(Ann
);
5942 -- Create renaming declarations for the entry formals. Each reference
5943 -- to a formal becomes a dereference of a component of the parameter
5944 -- block, whose address is held in Ann. These declarations are
5945 -- eventually inserted into the accept block, and analyzed there so
5946 -- that they have the proper scope for gdb and do not conflict with
5947 -- other declarations.
5949 if Present
(Parameter_Specifications
(N
))
5950 and then Present
(Handled_Statement_Sequence
(N
))
5957 Renamed_Formal
: Node_Id
;
5961 Formal
:= First_Formal
(Ent
);
5963 while Present
(Formal
) loop
5964 Comp
:= Entry_Component
(Formal
);
5965 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
5967 Set_Etype
(New_F
, Etype
(Formal
));
5968 Set_Scope
(New_F
, Ent
);
5970 -- Now we set debug info needed on New_F even though it does
5971 -- not come from source, so that the debugger will get the
5972 -- right information for these generated names.
5974 Set_Debug_Info_Needed
(New_F
);
5976 if Ekind
(Formal
) = E_In_Parameter
then
5977 Set_Ekind
(New_F
, E_Constant
);
5979 Set_Ekind
(New_F
, E_Variable
);
5980 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
5983 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
5986 Make_Selected_Component
(Loc
,
5988 Unchecked_Convert_To
(
5989 Entry_Parameters_Type
(Ent
),
5990 New_Occurrence_Of
(Ann
, Loc
)),
5992 New_Occurrence_Of
(Comp
, Loc
));
5995 Build_Renamed_Formal_Declaration
5996 (New_F
, Formal
, Comp
, Renamed_Formal
);
5998 if No
(Declarations
(N
)) then
5999 Set_Declarations
(N
, New_List
);
6002 Append
(Decl
, Declarations
(N
));
6003 Set_Renamed_Object
(Formal
, New_F
);
6004 Next_Formal
(Formal
);
6011 end Expand_Accept_Declarations
;
6013 ---------------------------------------------
6014 -- Expand_Access_Protected_Subprogram_Type --
6015 ---------------------------------------------
6017 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
6018 Loc
: constant Source_Ptr
:= Sloc
(N
);
6019 T
: constant Entity_Id
:= Defining_Identifier
(N
);
6020 D_T
: constant Entity_Id
:= Designated_Type
(T
);
6021 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
6022 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
6023 P_List
: constant List_Id
:=
6024 Build_Protected_Spec
(N
, RTE
(RE_Address
), D_T
, False);
6032 -- Create access to subprogram with full signature
6034 if Etype
(D_T
) /= Standard_Void_Type
then
6036 Make_Access_Function_Definition
(Loc
,
6037 Parameter_Specifications
=> P_List
,
6038 Result_Definition
=>
6039 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
6043 Make_Access_Procedure_Definition
(Loc
,
6044 Parameter_Specifications
=> P_List
);
6048 Make_Full_Type_Declaration
(Loc
,
6049 Defining_Identifier
=> D_T2
,
6050 Type_Definition
=> Def1
);
6052 -- Declare the new types before the original one since the latter will
6053 -- refer to them through the Equivalent_Type slot.
6055 Insert_Before_And_Analyze
(N
, Decl1
);
6057 -- Associate the access to subprogram with its original access to
6058 -- protected subprogram type. Needed by the backend to know that this
6059 -- type corresponds with an access to protected subprogram type.
6061 Set_Original_Access_Type
(D_T2
, T
);
6063 -- Create Equivalent_Type, a record with two components for an access to
6064 -- object and an access to subprogram.
6067 Make_Component_Declaration
(Loc
,
6068 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
6069 Component_Definition
=>
6070 Make_Component_Definition
(Loc
,
6071 Aliased_Present
=> False,
6072 Subtype_Indication
=>
6073 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
6075 Make_Component_Declaration
(Loc
,
6076 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
6077 Component_Definition
=>
6078 Make_Component_Definition
(Loc
,
6079 Aliased_Present
=> False,
6080 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
6083 Make_Full_Type_Declaration
(Loc
,
6084 Defining_Identifier
=> E_T
,
6086 Make_Record_Definition
(Loc
,
6088 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
6090 Insert_Before_And_Analyze
(N
, Decl2
);
6091 Set_Equivalent_Type
(T
, E_T
);
6092 end Expand_Access_Protected_Subprogram_Type
;
6094 --------------------------
6095 -- Expand_Entry_Barrier --
6096 --------------------------
6098 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
6099 Cond
: constant Node_Id
:= Condition
(Entry_Body_Formal_Part
(N
));
6100 Prot
: constant Entity_Id
:= Scope
(Ent
);
6101 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
6103 Func_Id
: Entity_Id
:= Empty
;
6104 -- The entity of the barrier function
6106 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
;
6107 -- Check whether entity in Barrier is external to protected type.
6108 -- If so, barrier may not be properly synchronized.
6110 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
;
6111 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6114 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean;
6115 -- Check whether entity name N denotes a component of the protected
6116 -- object. This is used to check the Simple_Barrier restriction.
6118 ----------------------
6119 -- Is_Global_Entity --
6120 ----------------------
6122 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
is
6127 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
6131 if Ekind
(E
) = E_Variable
then
6133 -- If the variable is local to the barrier function generated
6134 -- during expansion, it is ok. If expansion is not performed,
6135 -- then Func is Empty so this test cannot succeed.
6137 if Scope
(E
) = Func_Id
then
6140 -- A protected call from a barrier to another object is ok
6142 elsif Ekind
(Etype
(E
)) = E_Protected_Type
then
6145 -- If the variable is within the package body we consider
6146 -- this safe. This is a common (if dubious) idiom.
6148 elsif S
= Scope
(Prot
)
6149 and then Ekind_In
(S
, E_Package
, E_Generic_Package
)
6150 and then Nkind
(Parent
(E
)) = N_Object_Declaration
6151 and then Nkind
(Parent
(Parent
(E
))) = N_Package_Body
6156 Error_Msg_N
("potentially unsynchronized barrier??", N
);
6157 Error_Msg_N
("\& should be private component of type??", N
);
6163 end Is_Global_Entity
;
6165 procedure Check_Unprotected_Barrier
is
6166 new Traverse_Proc
(Is_Global_Entity
);
6168 ----------------------------
6169 -- Is_Simple_Barrier_Name --
6170 ----------------------------
6172 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean is
6176 -- Check if the name is a component of the protected object. If
6177 -- the expander is active, the component has been transformed into a
6178 -- renaming of _object.all.component. Original_Node is needed in case
6179 -- validity checking is enabled, in which case the simple object
6180 -- reference will have been rewritten.
6182 if Expander_Active
then
6184 -- The expanded name may have been constant folded in which case
6185 -- the original node is not necessarily an entity name (e.g. an
6186 -- indexed component).
6188 if not Is_Entity_Name
(Original_Node
(N
)) then
6192 Renamed
:= Renamed_Object
(Entity
(Original_Node
(N
)));
6196 and then Nkind
(Renamed
) = N_Selected_Component
6197 and then Chars
(Prefix
(Prefix
(Renamed
))) = Name_uObject
;
6199 return Is_Protected_Component
(Entity
(N
));
6201 end Is_Simple_Barrier_Name
;
6203 ---------------------
6204 -- Is_Pure_Barrier --
6205 ---------------------
6207 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
is
6210 when N_Expanded_Name
6213 if No
(Entity
(N
)) then
6216 elsif Is_Universal_Numeric_Type
(Entity
(N
)) then
6220 case Ekind
(Entity
(N
)) is
6223 | E_Enumeration_Literal
6233 if Is_Simple_Barrier_Name
(N
) then
6239 -- The count attribute has been transformed into run-time
6242 if Is_RTE
(Entity
(N
), RE_Protected_Count
)
6243 or else Is_RTE
(Entity
(N
), RE_Protected_Count_Entry
)
6252 when N_Function_Call
=>
6254 -- Function call checks are carried out as part of the analysis
6255 -- of the function call name.
6259 when N_Character_Literal
6268 if Ekind
(Entity
(N
)) = E_Operator
then
6272 when N_Short_Circuit
=>
6275 when N_Indexed_Component
6276 | N_Selected_Component
6278 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
6282 when N_Type_Conversion
=>
6284 -- Conversions to Universal_Integer will not raise constraint
6287 if Cannot_Raise_Constraint_Error
(N
)
6288 or else Etype
(N
) = Universal_Integer
6293 when N_Unchecked_Type_Conversion
=>
6301 end Is_Pure_Barrier
;
6303 function Check_Pure_Barriers
is new Traverse_Func
(Is_Pure_Barrier
);
6307 Cond_Id
: Entity_Id
;
6308 Entry_Body
: Node_Id
;
6309 Func_Body
: Node_Id
:= Empty
;
6311 -- Start of processing for Expand_Entry_Barrier
6314 if No_Run_Time_Mode
then
6315 Error_Msg_CRT
("entry barrier", N
);
6319 -- The body of the entry barrier must be analyzed in the context of the
6320 -- protected object, but its scope is external to it, just as any other
6321 -- unprotected version of a protected operation. The specification has
6322 -- been produced when the protected type declaration was elaborated. We
6323 -- build the body, insert it in the enclosing scope, but analyze it in
6324 -- the current context. A more uniform approach would be to treat the
6325 -- barrier just as a protected function, and discard the protected
6326 -- version of it because it is never called.
6328 if Expander_Active
then
6329 Func_Body
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6330 Func_Id
:= Barrier_Function
(Ent
);
6331 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
6333 Entry_Body
:= Parent
(Corresponding_Body
(Spec_Decl
));
6335 if Nkind
(Parent
(Entry_Body
)) = N_Subunit
then
6336 Entry_Body
:= Corresponding_Stub
(Parent
(Entry_Body
));
6339 Insert_Before_And_Analyze
(Entry_Body
, Func_Body
);
6341 Set_Discriminals
(Spec_Decl
);
6342 Set_Scope
(Func_Id
, Scope
(Prot
));
6345 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6348 -- Check Pure_Barriers restriction
6350 if Check_Pure_Barriers
(Cond
) = Abandon
then
6351 Check_Restriction
(Pure_Barriers
, Cond
);
6354 -- The Ravenscar profile restricts barriers to simple variables declared
6355 -- within the protected object. We also allow Boolean constants, since
6356 -- these appear in several published examples and are also allowed by
6359 -- Note that after analysis variables in this context will be replaced
6360 -- by the corresponding prival, that is to say a renaming of a selected
6361 -- component of the form _Object.Var. If expansion is disabled, as
6362 -- within a generic, we check that the entity appears in the current
6365 if Is_Entity_Name
(Cond
) then
6366 Cond_Id
:= Entity
(Cond
);
6368 -- Perform a small optimization of simple barrier functions. If the
6369 -- scope of the condition's entity is not the barrier function, then
6370 -- the condition does not depend on any of the generated renamings.
6371 -- If this is the case, eliminate the renamings as they are useless.
6372 -- This optimization is not performed when the condition was folded
6373 -- and validity checks are in effect because the original condition
6374 -- may have produced at least one check that depends on the generated
6378 and then Scope
(Cond_Id
) /= Func_Id
6379 and then not Validity_Check_Operands
6381 Set_Declarations
(Func_Body
, Empty_List
);
6384 if Cond_Id
= Standard_False
or else Cond_Id
= Standard_True
then
6387 elsif Is_Simple_Barrier_Name
(Cond
) then
6392 -- It is not a boolean variable or literal, so check the restriction.
6393 -- Note that it is safe to be calling Check_Restriction from here, even
6394 -- though this is part of the expander, since Expand_Entry_Barrier is
6395 -- called from Sem_Ch9 even in -gnatc mode.
6397 Check_Restriction
(Simple_Barriers
, Cond
);
6399 -- Emit warning if barrier contains global entities and is thus
6400 -- potentially unsynchronized.
6402 Check_Unprotected_Barrier
(Cond
);
6403 end Expand_Entry_Barrier
;
6405 ------------------------------
6406 -- Expand_N_Abort_Statement --
6407 ------------------------------
6409 -- Expand abort T1, T2, .. Tn; into:
6410 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6412 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6413 Loc
: constant Source_Ptr
:= Sloc
(N
);
6414 Tlist
: constant List_Id
:= Names
(N
);
6420 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6423 Tasknm
:= First
(Tlist
);
6425 while Present
(Tasknm
) loop
6428 -- A task interface class-wide type object is being aborted. Retrieve
6429 -- its _task_id by calling a dispatching routine.
6431 if Ada_Version
>= Ada_2005
6432 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6433 and then Is_Interface
(Etype
(Tasknm
))
6434 and then Is_Task_Interface
(Etype
(Tasknm
))
6436 Append_To
(Component_Associations
(Aggr
),
6437 Make_Component_Association
(Loc
,
6438 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6441 -- Task_Id (Tasknm._disp_get_task_id)
6443 Make_Unchecked_Type_Conversion
(Loc
,
6445 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6447 Make_Selected_Component
(Loc
,
6448 Prefix
=> New_Copy_Tree
(Tasknm
),
6450 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6453 Append_To
(Component_Associations
(Aggr
),
6454 Make_Component_Association
(Loc
,
6455 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6456 Expression
=> Concurrent_Ref
(Tasknm
)));
6463 Make_Procedure_Call_Statement
(Loc
,
6464 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Tasks
), Loc
),
6465 Parameter_Associations
=> New_List
(
6466 Make_Qualified_Expression
(Loc
,
6467 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_List
), Loc
),
6468 Expression
=> Aggr
))));
6471 end Expand_N_Abort_Statement
;
6473 -------------------------------
6474 -- Expand_N_Accept_Statement --
6475 -------------------------------
6477 -- This procedure handles expansion of accept statements that stand alone,
6478 -- i.e. they are not part of an accept alternative. The expansion of
6479 -- accept statement in accept alternatives is handled by the routines
6480 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6481 -- following description applies only to stand alone accept statements.
6483 -- If there is no handled statement sequence, or only null statements, then
6484 -- this is called a trivial accept, and the expansion is:
6486 -- Accept_Trivial (entry-index)
6488 -- If there is a handled statement sequence, then the expansion is:
6495 -- Accept_Call (entry-index, Ann);
6496 -- Renaming_Declarations for formals
6497 -- <statement sequence from N_Accept_Statement node>
6498 -- Complete_Rendezvous;
6503 -- <exception handler from N_Accept_Statement node>
6504 -- Complete_Rendezvous;
6506 -- <exception handler from N_Accept_Statement node>
6507 -- Complete_Rendezvous;
6512 -- when all others =>
6513 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6516 -- The first three declarations were already inserted ahead of the accept
6517 -- statement by the Expand_Accept_Declarations procedure, which was called
6518 -- directly from the semantics during analysis of the accept statement,
6519 -- before analyzing its contained statements.
6521 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6522 -- from possible expansion activity (the original source of course does
6523 -- not have any declarations associated with the accept statement, since
6524 -- an accept statement has no declarative part). In particular, if the
6525 -- expander is active, the first such declaration is the declaration of
6526 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6528 -- The two blocks are merged into a single block if the inner block has
6529 -- no exception handlers, but otherwise two blocks are required, since
6530 -- exceptions might be raised in the exception handlers of the inner
6531 -- block, and Exceptional_Complete_Rendezvous must be called.
6533 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6534 Loc
: constant Source_Ptr
:= Sloc
(N
);
6535 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6536 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6537 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6538 Eent
: constant Entity_Id
:= Entity
(Ename
);
6539 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6540 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6541 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6547 -- If the accept statement is not part of a list, then its parent must
6548 -- be an accept alternative, and, as described above, we do not do any
6549 -- expansion for such accept statements at this level.
6551 if not Is_List_Member
(N
) then
6552 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6555 -- Trivial accept case (no statement sequence, or null statements).
6556 -- If the accept statement has declarations, then just insert them
6557 -- before the procedure call.
6559 elsif Trivial_Accept_OK
6560 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6562 -- Remove declarations for renamings, because the parameter block
6563 -- will not be assigned.
6570 D
:= First
(Declarations
(N
));
6571 while Present
(D
) loop
6573 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6581 if Present
(Declarations
(N
)) then
6582 Insert_Actions
(N
, Declarations
(N
));
6586 Make_Procedure_Call_Statement
(Loc
,
6587 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Trivial
), Loc
),
6588 Parameter_Associations
=> New_List
(
6589 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6593 -- Discard Entry_Address that was created for it, so it will not be
6594 -- emitted if this accept statement is in the statement part of a
6595 -- delay alternative.
6597 if Present
(Stats
) then
6598 Remove_Last_Elmt
(Acstack
);
6601 -- Case of statement sequence present
6604 -- Construct the block, using the declarations from the accept
6605 -- statement if any to initialize the declarations of the block.
6607 Blkent
:= Make_Temporary
(Loc
, 'A');
6608 Set_Ekind
(Blkent
, E_Block
);
6609 Set_Etype
(Blkent
, Standard_Void_Type
);
6610 Set_Scope
(Blkent
, Current_Scope
);
6613 Make_Block_Statement
(Loc
,
6614 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
6615 Declarations
=> Declarations
(N
),
6616 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6618 -- For the analysis of the generated declarations, the parent node
6619 -- must be properly set.
6621 Set_Parent
(Block
, Parent
(N
));
6623 -- Prepend call to Accept_Call to main statement sequence If the
6624 -- accept has exception handlers, the statement sequence is wrapped
6625 -- in a block. Insert call and renaming declarations in the
6626 -- declarations of the block, so they are elaborated before the
6630 Make_Procedure_Call_Statement
(Loc
,
6631 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Call
), Loc
),
6632 Parameter_Associations
=> New_List
(
6633 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6634 New_Occurrence_Of
(Ann
, Loc
)));
6636 if Parent
(Stats
) = N
then
6637 Prepend
(Call
, Statements
(Stats
));
6639 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6644 Push_Scope
(Blkent
);
6652 D
:= First
(Declarations
(N
));
6653 while Present
(D
) loop
6656 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6658 -- The renaming declarations for the formals were created
6659 -- during analysis of the accept statement, and attached to
6660 -- the list of declarations. Place them now in the context
6661 -- of the accept block or subprogram.
6664 Typ
:= Entity
(Subtype_Mark
(D
));
6665 Insert_After
(Call
, D
);
6668 -- If the formal is class_wide, it does not have an actual
6669 -- subtype. The analysis of the renaming declaration creates
6670 -- one, but we need to retain the class-wide nature of the
6673 if Is_Class_Wide_Type
(Typ
) then
6674 Set_Etype
(Defining_Identifier
(D
), Typ
);
6685 -- Replace the accept statement by the new block
6690 -- Last step is to unstack the Accept_Address value
6692 Remove_Last_Elmt
(Acstack
);
6694 end Expand_N_Accept_Statement
;
6696 ----------------------------------
6697 -- Expand_N_Asynchronous_Select --
6698 ----------------------------------
6700 -- This procedure assumes that the trigger statement is an entry call or
6701 -- a dispatching procedure call. A delay alternative should already have
6702 -- been expanded into an entry call to the appropriate delay object Wait
6705 -- If the trigger is a task entry call, the select is implemented with
6706 -- a Task_Entry_Call:
6711 -- P : parms := (parm, parm, parm);
6713 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6715 -- procedure _clean is
6718 -- Cancel_Task_Entry_Call (C);
6725 -- (<acceptor-task>, -- Acceptor
6726 -- <entry-index>, -- E
6727 -- P'Address, -- Uninterpreted_Data
6728 -- Asynchronous_Call, -- Mode
6729 -- B); -- Rendezvous_Successful
6736 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6739 -- when Abort_Signal => Abort_Undefer;
6746 -- <triggered-statements>
6750 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6751 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6755 -- P : parms := (parm, parm, parm);
6757 -- Call_Simple (acceptor-task, entry-index, P'Address);
6763 -- so the task at hand is to convert the latter expansion into the former
6765 -- If the trigger is a protected entry call, the select is implemented
6766 -- with Protected_Entry_Call:
6769 -- P : E1_Params := (param, param, param);
6770 -- Bnn : Communications_Block;
6775 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6777 -- procedure _clean is
6780 -- if Enqueued (Bnn) then
6781 -- Cancel_Protected_Entry_Call (Bnn);
6788 -- Protected_Entry_Call
6789 -- (po._object'Access, -- Object
6790 -- <entry index>, -- E
6791 -- P'Address, -- Uninterpreted_Data
6792 -- Asynchronous_Call, -- Mode
6795 -- if Enqueued (Bnn) then
6799 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6802 -- when Abort_Signal => Abort_Undefer;
6805 -- if not Cancelled (Bnn) then
6806 -- <triggered-statements>
6810 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6814 -- P : E1_Params := (param, param, param);
6815 -- Bnn : Communications_Block;
6818 -- Protected_Entry_Call
6819 -- (po._object'Access, -- Object
6820 -- <entry index>, -- E
6821 -- P'Address, -- Uninterpreted_Data
6822 -- Simple_Call, -- Mode
6829 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6833 -- B : Boolean := False;
6834 -- Bnn : Communication_Block;
6835 -- C : Ada.Tags.Prim_Op_Kind;
6836 -- D : System.Storage_Elements.Dummy_Communication_Block;
6837 -- K : Ada.Tags.Tagged_Kind :=
6838 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6839 -- P : Parameters := (Param1 .. ParamN);
6844 -- if K = Ada.Tags.TK_Limited_Tagged
6845 -- or else K = Ada.Tags.TK_Tagged
6847 -- <dispatching-call>;
6848 -- <triggering-statements>;
6852 -- Ada.Tags.Get_Offset_Index
6853 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6855 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6857 -- if C = POK_Protected_Entry then
6859 -- procedure _clean is
6861 -- if Enqueued (Bnn) then
6862 -- Cancel_Protected_Entry_Call (Bnn);
6868 -- _Disp_Asynchronous_Select
6869 -- (<object>, S, P'Address, D, B);
6870 -- Bnn := Communication_Block (D);
6872 -- Param1 := P.Param1;
6874 -- ParamN := P.ParamN;
6876 -- if Enqueued (Bnn) then
6877 -- <abortable-statements>
6880 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6883 -- when Abort_Signal => Abort_Undefer;
6886 -- if not Cancelled (Bnn) then
6887 -- <triggering-statements>
6890 -- elsif C = POK_Task_Entry then
6892 -- procedure _clean is
6894 -- Cancel_Task_Entry_Call (U);
6900 -- _Disp_Asynchronous_Select
6901 -- (<object>, S, P'Address, D, B);
6902 -- Bnn := Communication_Bloc (D);
6904 -- Param1 := P.Param1;
6906 -- ParamN := P.ParamN;
6911 -- <abortable-statements>
6913 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6916 -- when Abort_Signal => Abort_Undefer;
6920 -- <triggering-statements>
6925 -- <dispatching-call>;
6926 -- <triggering-statements>
6931 -- The job is to convert this to the asynchronous form
6933 -- If the trigger is a delay statement, it will have been expanded into
6934 -- a call to one of the GNARL delay procedures. This routine will convert
6935 -- this into a protected entry call on a delay object and then continue
6936 -- processing as for a protected entry call trigger. This requires
6937 -- declaring a Delay_Block object and adding a pointer to this object to
6938 -- the parameter list of the delay procedure to form the parameter list of
6939 -- the entry call. This object is used by the runtime to queue the delay
6942 -- For a description of the use of P and the assignments after the call,
6943 -- see Expand_N_Entry_Call_Statement.
6945 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
6946 Loc
: constant Source_Ptr
:= Sloc
(N
);
6947 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
6948 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
6950 Abort_Block_Ent
: Entity_Id
;
6951 Abortable_Block
: Node_Id
;
6954 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6955 Blk_Typ
: Entity_Id
;
6957 Call_Ent
: Entity_Id
;
6958 Cancel_Param
: Entity_Id
;
6959 Cleanup_Block
: Node_Id
;
6960 Cleanup_Block_Ent
: Entity_Id
;
6961 Cleanup_Stmts
: List_Id
;
6962 Conc_Typ_Stmts
: List_Id
;
6964 Dblock_Ent
: Entity_Id
;
6969 Enqueue_Call
: Node_Id
;
6972 Handler_Stmt
: Node_Id
;
6974 Lim_Typ_Stmts
: List_Id
;
6980 ProtE_Stmts
: List_Id
;
6981 ProtP_Stmts
: List_Id
;
6984 TaskE_Stmts
: List_Id
;
6987 B
: Entity_Id
; -- Call status flag
6988 Bnn
: Entity_Id
; -- Communication block
6989 C
: Entity_Id
; -- Call kind
6990 K
: Entity_Id
; -- Tagged kind
6991 P
: Entity_Id
; -- Parameter block
6992 S
: Entity_Id
; -- Primitive operation slot
6993 T
: Entity_Id
; -- Additional status flag
6995 procedure Rewrite_Abortable_Part
;
6996 -- If the trigger is a dispatching call, the expansion inserts multiple
6997 -- copies of the abortable part. This is both inefficient, and may lead
6998 -- to duplicate definitions that the back-end will reject, when the
6999 -- abortable part includes loops. This procedure rewrites the abortable
7000 -- part into a call to a generated procedure.
7002 ----------------------------
7003 -- Rewrite_Abortable_Part --
7004 ----------------------------
7006 procedure Rewrite_Abortable_Part
is
7007 Proc
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7012 Make_Subprogram_Body
(Loc
,
7014 Make_Procedure_Specification
(Loc
, Defining_Unit_Name
=> Proc
),
7015 Declarations
=> New_List
,
7016 Handled_Statement_Sequence
=>
7017 Make_Handled_Sequence_Of_Statements
(Loc
, Astats
));
7018 Insert_Before
(N
, Decl
);
7021 -- Rewrite abortable part into a call to this procedure
7025 Make_Procedure_Call_Statement
(Loc
,
7026 Name
=> New_Occurrence_Of
(Proc
, Loc
)));
7027 end Rewrite_Abortable_Part
;
7029 -- Start of processing for Expand_N_Asynchronous_Select
7032 -- Asynchronous select is not supported on restricted runtimes. Don't
7035 if Restricted_Profile
then
7039 Process_Statements_For_Controlled_Objects
(Trig
);
7040 Process_Statements_For_Controlled_Objects
(Abrt
);
7042 Ecall
:= Triggering_Statement
(Trig
);
7044 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
7046 -- Retrieve Astats and Tstats now because the finalization machinery may
7047 -- wrap them in blocks.
7049 Astats
:= Statements
(Abrt
);
7050 Tstats
:= Statements
(Trig
);
7052 -- The arguments in the call may require dynamic allocation, and the
7053 -- call statement may have been transformed into a block. The block
7054 -- may contain additional declarations for internal entities, and the
7055 -- original call is found by sequential search.
7057 if Nkind
(Ecall
) = N_Block_Statement
then
7058 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
7059 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
7060 N_Entry_Call_Statement
)
7066 -- This is either a dispatching call or a delay statement used as a
7067 -- trigger which was expanded into a procedure call.
7069 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
7070 if Ada_Version
>= Ada_2005
7072 (No
(Original_Node
(Ecall
))
7073 or else not Nkind_In
(Original_Node
(Ecall
),
7074 N_Delay_Relative_Statement
,
7075 N_Delay_Until_Statement
))
7077 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
7079 Rewrite_Abortable_Part
;
7083 -- Call status flag processing, generate:
7084 -- B : Boolean := False;
7086 B
:= Build_B
(Loc
, Decls
);
7088 -- Communication block processing, generate:
7089 -- Bnn : Communication_Block;
7091 Bnn
:= Make_Temporary
(Loc
, 'B');
7093 Make_Object_Declaration
(Loc
,
7094 Defining_Identifier
=> Bnn
,
7095 Object_Definition
=>
7096 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
7098 -- Call kind processing, generate:
7099 -- C : Ada.Tags.Prim_Op_Kind;
7101 C
:= Build_C
(Loc
, Decls
);
7103 -- Tagged kind processing, generate:
7104 -- K : Ada.Tags.Tagged_Kind :=
7105 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7107 -- Dummy communication block, generate:
7108 -- D : Dummy_Communication_Block;
7111 Make_Object_Declaration
(Loc
,
7112 Defining_Identifier
=>
7113 Make_Defining_Identifier
(Loc
, Name_uD
),
7114 Object_Definition
=>
7116 (RTE
(RE_Dummy_Communication_Block
), Loc
)));
7118 K
:= Build_K
(Loc
, Decls
, Obj
);
7120 -- Parameter block processing
7122 Blk_Typ
:= Build_Parameter_Block
7123 (Loc
, Actuals
, Formals
, Decls
);
7124 P
:= Parameter_Block_Pack
7125 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7127 -- Dispatch table slot processing, generate:
7130 S
:= Build_S
(Loc
, Decls
);
7132 -- Additional status flag processing, generate:
7135 T
:= Make_Temporary
(Loc
, 'T');
7137 Make_Object_Declaration
(Loc
,
7138 Defining_Identifier
=> T
,
7139 Object_Definition
=>
7140 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7142 ------------------------------
7143 -- Protected entry handling --
7144 ------------------------------
7147 -- Param1 := P.Param1;
7149 -- ParamN := P.ParamN;
7151 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7154 -- Bnn := Communication_Block (D);
7156 Prepend_To
(Cleanup_Stmts
,
7157 Make_Assignment_Statement
(Loc
,
7158 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
7160 Make_Unchecked_Type_Conversion
(Loc
,
7162 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7163 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7166 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7168 Prepend_To
(Cleanup_Stmts
,
7169 Make_Procedure_Call_Statement
(Loc
,
7173 (Etype
(Etype
(Obj
)), Name_uDisp_Asynchronous_Select
),
7175 Parameter_Associations
=>
7177 New_Copy_Tree
(Obj
), -- <object>
7178 New_Occurrence_Of
(S
, Loc
), -- S
7179 Make_Attribute_Reference
(Loc
, -- P'Address
7180 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7181 Attribute_Name
=> Name_Address
),
7182 Make_Identifier
(Loc
, Name_uD
), -- D
7183 New_Occurrence_Of
(B
, Loc
)))); -- B
7186 -- if Enqueued (Bnn) then
7187 -- <abortable-statements>
7190 Append_To
(Cleanup_Stmts
,
7191 Make_Implicit_If_Statement
(N
,
7193 Make_Function_Call
(Loc
,
7195 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7196 Parameter_Associations
=>
7197 New_List
(New_Occurrence_Of
(Bnn
, Loc
))),
7200 New_Copy_List_Tree
(Astats
)));
7202 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7203 -- will then generate a _clean for the communication block Bnn.
7207 -- procedure _clean is
7209 -- if Enqueued (Bnn) then
7210 -- Cancel_Protected_Entry_Call (Bnn);
7219 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7221 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
7223 -- Wrap the cleanup block in an exception handling block
7229 -- when Abort_Signal => Abort_Undefer;
7232 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7235 Make_Implicit_Label_Declaration
(Loc
,
7236 Defining_Identifier
=> Abort_Block_Ent
),
7239 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7242 -- if not Cancelled (Bnn) then
7243 -- <triggering-statements>
7246 Append_To
(ProtE_Stmts
,
7247 Make_Implicit_If_Statement
(N
,
7251 Make_Function_Call
(Loc
,
7253 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7254 Parameter_Associations
=>
7255 New_List
(New_Occurrence_Of
(Bnn
, Loc
)))),
7258 New_Copy_List_Tree
(Tstats
)));
7260 -------------------------
7261 -- Task entry handling --
7262 -------------------------
7265 -- Param1 := P.Param1;
7267 -- ParamN := P.ParamN;
7269 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7272 -- Bnn := Communication_Block (D);
7274 Append_To
(TaskE_Stmts
,
7275 Make_Assignment_Statement
(Loc
,
7277 New_Occurrence_Of
(Bnn
, Loc
),
7279 Make_Unchecked_Type_Conversion
(Loc
,
7281 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7282 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7285 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7287 Prepend_To
(TaskE_Stmts
,
7288 Make_Procedure_Call_Statement
(Loc
,
7291 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7292 Name_uDisp_Asynchronous_Select
),
7295 Parameter_Associations
=> New_List
(
7296 New_Copy_Tree
(Obj
), -- <object>
7297 New_Occurrence_Of
(S
, Loc
), -- S
7298 Make_Attribute_Reference
(Loc
, -- P'Address
7299 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7300 Attribute_Name
=> Name_Address
),
7301 Make_Identifier
(Loc
, Name_uD
), -- D
7302 New_Occurrence_Of
(B
, Loc
)))); -- B
7307 Prepend_To
(TaskE_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7311 -- <abortable-statements>
7313 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
7316 (Cleanup_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7318 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7319 -- will generate a _clean for the additional status flag.
7323 -- procedure _clean is
7325 -- Cancel_Task_Entry_Call (U);
7333 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7335 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
7337 -- Wrap the cleanup block in an exception handling block
7343 -- when Abort_Signal => Abort_Undefer;
7346 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7348 Append_To
(TaskE_Stmts
,
7349 Make_Implicit_Label_Declaration
(Loc
,
7350 Defining_Identifier
=> Abort_Block_Ent
));
7352 Append_To
(TaskE_Stmts
,
7354 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7358 -- <triggering-statements>
7361 Append_To
(TaskE_Stmts
,
7362 Make_Implicit_If_Statement
(N
,
7364 Make_Op_Not
(Loc
, Right_Opnd
=> New_Occurrence_Of
(T
, Loc
)),
7367 New_Copy_List_Tree
(Tstats
)));
7369 ----------------------------------
7370 -- Protected procedure handling --
7371 ----------------------------------
7374 -- <dispatching-call>;
7375 -- <triggering-statements>
7377 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7378 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7381 -- S := Ada.Tags.Get_Offset_Index
7382 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7385 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7388 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7390 Append_To
(Conc_Typ_Stmts
,
7391 Make_Procedure_Call_Statement
(Loc
,
7394 (Find_Prim_Op
(Etype
(Etype
(Obj
)),
7395 Name_uDisp_Get_Prim_Op_Kind
),
7397 Parameter_Associations
=>
7399 New_Copy_Tree
(Obj
),
7400 New_Occurrence_Of
(S
, Loc
),
7401 New_Occurrence_Of
(C
, Loc
))));
7404 -- if C = POK_Procedure_Entry then
7406 -- elsif C = POK_Task_Entry then
7412 Append_To
(Conc_Typ_Stmts
,
7413 Make_Implicit_If_Statement
(N
,
7417 New_Occurrence_Of
(C
, Loc
),
7419 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7426 Make_Elsif_Part
(Loc
,
7430 New_Occurrence_Of
(C
, Loc
),
7432 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
)),
7441 -- <dispatching-call>;
7442 -- <triggering-statements>
7444 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7445 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7448 -- if K = Ada.Tags.TK_Limited_Tagged
7449 -- or else K = Ada.Tags.TK_Tagged
7457 Make_Implicit_If_Statement
(N
,
7458 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
7459 Then_Statements
=> Lim_Typ_Stmts
,
7460 Else_Statements
=> Conc_Typ_Stmts
));
7463 Make_Block_Statement
(Loc
,
7466 Handled_Statement_Sequence
=>
7467 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7472 -- Delay triggering statement processing
7475 -- Add a Delay_Block object to the parameter list of the delay
7476 -- procedure to form the parameter list of the Wait entry call.
7478 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7480 Pdef
:= Entity
(Name
(Ecall
));
7482 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7484 New_Occurrence_Of
(RTE
(RE_Enqueue_Duration
), Loc
);
7486 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7488 New_Occurrence_Of
(RTE
(RE_Enqueue_Calendar
), Loc
);
7490 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7491 Enqueue_Call
:= New_Occurrence_Of
(RTE
(RE_Enqueue_RT
), Loc
);
7494 Append_To
(Parameter_Associations
(Ecall
),
7495 Make_Attribute_Reference
(Loc
,
7496 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7497 Attribute_Name
=> Name_Unchecked_Access
));
7499 -- Create the inner block to protect the abortable part
7501 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7503 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7506 Make_Block_Statement
(Loc
,
7507 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7508 Handled_Statement_Sequence
=>
7509 Make_Handled_Sequence_Of_Statements
(Loc
,
7510 Statements
=> Astats
),
7511 Has_Created_Identifier
=> True,
7512 Is_Asynchronous_Call_Block
=> True);
7514 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7517 Make_Implicit_If_Statement
(N
,
7519 Make_Function_Call
(Loc
,
7520 Name
=> Enqueue_Call
,
7521 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7523 New_List
(Make_Block_Statement
(Loc
,
7524 Handled_Statement_Sequence
=>
7525 Make_Handled_Sequence_Of_Statements
(Loc
,
7526 Statements
=> New_List
(
7527 Make_Implicit_Label_Declaration
(Loc
,
7528 Defining_Identifier
=> Blk_Ent
,
7529 Label_Construct
=> Abortable_Block
),
7531 Exception_Handlers
=> Hdle
)))));
7533 Stmts
:= New_List
(Ecall
);
7535 -- Construct statement sequence for new block
7538 Make_Implicit_If_Statement
(N
,
7540 Make_Function_Call
(Loc
,
7541 Name
=> New_Occurrence_Of
(
7542 RTE
(RE_Timed_Out
), Loc
),
7543 Parameter_Associations
=> New_List
(
7544 Make_Attribute_Reference
(Loc
,
7545 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7546 Attribute_Name
=> Name_Unchecked_Access
))),
7547 Then_Statements
=> Tstats
));
7549 -- The result is the new block
7551 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7554 Make_Block_Statement
(Loc
,
7555 Declarations
=> New_List
(
7556 Make_Object_Declaration
(Loc
,
7557 Defining_Identifier
=> Dblock_Ent
,
7558 Aliased_Present
=> True,
7559 Object_Definition
=>
7560 New_Occurrence_Of
(RTE
(RE_Delay_Block
), Loc
))),
7562 Handled_Statement_Sequence
=>
7563 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7573 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7574 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7576 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7577 Decls
:= Declarations
(Ecall
);
7579 if Is_Protected_Type
(Etype
(Concval
)) then
7581 -- Get the declarations of the block expanded from the entry call
7583 Decl
:= First
(Decls
);
7584 while Present
(Decl
)
7585 and then (Nkind
(Decl
) /= N_Object_Declaration
7586 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7587 RE_Communication_Block
))
7592 pragma Assert
(Present
(Decl
));
7593 Cancel_Param
:= Defining_Identifier
(Decl
);
7595 -- Change the mode of the Protected_Entry_Call call
7597 -- Protected_Entry_Call (
7598 -- Object => po._object'Access,
7599 -- E => <entry index>;
7600 -- Uninterpreted_Data => P'Address;
7601 -- Mode => Asynchronous_Call;
7604 -- Skip assignments to temporaries created for in-out parameters
7606 -- This makes unwarranted assumptions about the shape of the expanded
7607 -- tree for the call, and should be cleaned up ???
7609 Stmt
:= First
(Stmts
);
7610 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7616 Param
:= First
(Parameter_Associations
(Call
));
7617 while Present
(Param
)
7618 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7623 pragma Assert
(Present
(Param
));
7624 Rewrite
(Param
, New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7627 -- Append an if statement to execute the abortable part
7630 -- if Enqueued (Bnn) then
7633 Make_Implicit_If_Statement
(N
,
7635 Make_Function_Call
(Loc
,
7636 Name
=> New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7637 Parameter_Associations
=> New_List
(
7638 New_Occurrence_Of
(Cancel_Param
, Loc
))),
7639 Then_Statements
=> Astats
));
7642 Make_Block_Statement
(Loc
,
7643 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7644 Handled_Statement_Sequence
=>
7645 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7646 Has_Created_Identifier
=> True,
7647 Is_Asynchronous_Call_Block
=> True);
7649 -- Aborts are not deferred at beginning of exception handlers in
7652 if ZCX_Exceptions
then
7653 Handler_Stmt
:= Make_Null_Statement
(Loc
);
7656 Handler_Stmt
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
7660 Make_Block_Statement
(Loc
,
7661 Handled_Statement_Sequence
=>
7662 Make_Handled_Sequence_Of_Statements
(Loc
,
7663 Statements
=> New_List
(
7664 Make_Implicit_Label_Declaration
(Loc
,
7665 Defining_Identifier
=> Blk_Ent
,
7666 Label_Construct
=> Abortable_Block
),
7671 Exception_Handlers
=> New_List
(
7672 Make_Implicit_Exception_Handler
(Loc
,
7674 -- when Abort_Signal =>
7675 -- Abort_Undefer.all;
7677 Exception_Choices
=>
7678 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
7679 Statements
=> New_List
(Handler_Stmt
))))),
7681 -- if not Cancelled (Bnn) then
7682 -- triggered statements
7685 Make_Implicit_If_Statement
(N
,
7686 Condition
=> Make_Op_Not
(Loc
,
7688 Make_Function_Call
(Loc
,
7689 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7690 Parameter_Associations
=> New_List
(
7691 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7692 Then_Statements
=> Tstats
));
7694 -- Asynchronous task entry call
7701 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7703 -- Insert declaration of B in declarations of existing block
7706 Make_Object_Declaration
(Loc
,
7707 Defining_Identifier
=> B
,
7708 Object_Definition
=>
7709 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7711 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7713 -- Insert the declaration of C in the declarations of the existing
7714 -- block. The variable is initialized to something (True or False,
7715 -- does not matter) to prevent CodePeer from complaining about a
7716 -- possible read of an uninitialized variable.
7719 Make_Object_Declaration
(Loc
,
7720 Defining_Identifier
=> Cancel_Param
,
7721 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7722 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
7723 Has_Init_Expression
=> True));
7725 -- Remove and save the call to Call_Simple
7727 Stmt
:= First
(Stmts
);
7729 -- Skip assignments to temporaries created for in-out parameters.
7730 -- This makes unwarranted assumptions about the shape of the expanded
7731 -- tree for the call, and should be cleaned up ???
7733 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7739 -- Create the inner block to protect the abortable part
7741 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7743 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7746 Make_Block_Statement
(Loc
,
7747 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7748 Handled_Statement_Sequence
=>
7749 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7750 Has_Created_Identifier
=> True,
7751 Is_Asynchronous_Call_Block
=> True);
7754 Make_Block_Statement
(Loc
,
7755 Handled_Statement_Sequence
=>
7756 Make_Handled_Sequence_Of_Statements
(Loc
,
7757 Statements
=> New_List
(
7758 Make_Implicit_Label_Declaration
(Loc
,
7759 Defining_Identifier
=> Blk_Ent
,
7760 Label_Construct
=> Abortable_Block
),
7762 Exception_Handlers
=> Hdle
)));
7764 -- Create new call statement
7766 Params
:= Parameter_Associations
(Call
);
7769 New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7770 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
7773 Make_Procedure_Call_Statement
(Loc
,
7774 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
7775 Parameter_Associations
=> Params
));
7777 -- Construct statement sequence for new block
7780 Make_Implicit_If_Statement
(N
,
7782 Make_Op_Not
(Loc
, New_Occurrence_Of
(Cancel_Param
, Loc
)),
7783 Then_Statements
=> Tstats
));
7785 -- Protected the call against abort
7787 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7790 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7792 -- The result is the new block
7795 Make_Block_Statement
(Loc
,
7796 Declarations
=> Decls
,
7797 Handled_Statement_Sequence
=>
7798 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7801 end Expand_N_Asynchronous_Select
;
7803 -------------------------------------
7804 -- Expand_N_Conditional_Entry_Call --
7805 -------------------------------------
7807 -- The conditional task entry call is converted to a call to
7812 -- P : parms := (parm, parm, parm);
7816 -- (<acceptor-task>, -- Acceptor
7817 -- <entry-index>, -- E
7818 -- P'Address, -- Uninterpreted_Data
7819 -- Conditional_Call, -- Mode
7820 -- B); -- Rendezvous_Successful
7825 -- normal-statements
7831 -- For a description of the use of P and the assignments after the call,
7832 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7833 -- conditional entry call has already been expanded (by the Expand_N_Entry
7834 -- _Call_Statement procedure) as follows:
7837 -- P : parms := (parm, parm, parm);
7839 -- ... info for in-out parameters
7840 -- Call_Simple (acceptor-task, entry-index, P'Address);
7846 -- so the task at hand is to convert the latter expansion into the former
7848 -- The conditional protected entry call is converted to a call to
7849 -- Protected_Entry_Call:
7852 -- P : parms := (parm, parm, parm);
7853 -- Bnn : Communications_Block;
7856 -- Protected_Entry_Call
7857 -- (po._object'Access, -- Object
7858 -- <entry index>, -- E
7859 -- P'Address, -- Uninterpreted_Data
7860 -- Conditional_Call, -- Mode
7865 -- if Cancelled (Bnn) then
7868 -- normal-statements
7872 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7876 -- B : Boolean := False;
7877 -- C : Ada.Tags.Prim_Op_Kind;
7878 -- K : Ada.Tags.Tagged_Kind :=
7879 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7880 -- P : Parameters := (Param1 .. ParamN);
7884 -- if K = Ada.Tags.TK_Limited_Tagged
7885 -- or else K = Ada.Tags.TK_Tagged
7887 -- <dispatching-call>;
7888 -- <triggering-statements>
7892 -- Ada.Tags.Get_Offset_Index
7893 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7895 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7897 -- if C = POK_Protected_Entry
7898 -- or else C = POK_Task_Entry
7900 -- Param1 := P.Param1;
7902 -- ParamN := P.ParamN;
7906 -- if C = POK_Procedure
7907 -- or else C = POK_Protected_Procedure
7908 -- or else C = POK_Task_Procedure
7910 -- <dispatching-call>;
7913 -- <triggering-statements>
7915 -- <else-statements>
7920 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
7921 Loc
: constant Source_Ptr
:= Sloc
(N
);
7922 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
7923 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
7926 Blk_Typ
: Entity_Id
;
7928 Call_Ent
: Entity_Id
;
7929 Conc_Typ_Stmts
: List_Id
;
7933 Lim_Typ_Stmts
: List_Id
;
7940 Transient_Blk
: Node_Id
;
7943 B
: Entity_Id
; -- Call status flag
7944 C
: Entity_Id
; -- Call kind
7945 K
: Entity_Id
; -- Tagged kind
7946 P
: Entity_Id
; -- Parameter block
7947 S
: Entity_Id
; -- Primitive operation slot
7950 Process_Statements_For_Controlled_Objects
(N
);
7952 if Ada_Version
>= Ada_2005
7953 and then Nkind
(Blk
) = N_Procedure_Call_Statement
7955 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
7960 -- Call status flag processing, generate:
7961 -- B : Boolean := False;
7963 B
:= Build_B
(Loc
, Decls
);
7965 -- Call kind processing, generate:
7966 -- C : Ada.Tags.Prim_Op_Kind;
7968 C
:= Build_C
(Loc
, Decls
);
7970 -- Tagged kind processing, generate:
7971 -- K : Ada.Tags.Tagged_Kind :=
7972 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7974 K
:= Build_K
(Loc
, Decls
, Obj
);
7976 -- Parameter block processing
7978 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
7979 P
:= Parameter_Block_Pack
7980 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7982 -- Dispatch table slot processing, generate:
7985 S
:= Build_S
(Loc
, Decls
);
7988 -- S := Ada.Tags.Get_Offset_Index
7989 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7992 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7995 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7997 Append_To
(Conc_Typ_Stmts
,
7998 Make_Procedure_Call_Statement
(Loc
,
8001 Find_Prim_Op
(Etype
(Etype
(Obj
)),
8002 Name_uDisp_Conditional_Select
),
8004 Parameter_Associations
=>
8006 New_Copy_Tree
(Obj
), -- <object>
8007 New_Occurrence_Of
(S
, Loc
), -- S
8008 Make_Attribute_Reference
(Loc
, -- P'Address
8009 Prefix
=> New_Occurrence_Of
(P
, Loc
),
8010 Attribute_Name
=> Name_Address
),
8011 New_Occurrence_Of
(C
, Loc
), -- C
8012 New_Occurrence_Of
(B
, Loc
)))); -- B
8015 -- if C = POK_Protected_Entry
8016 -- or else C = POK_Task_Entry
8018 -- Param1 := P.Param1;
8020 -- ParamN := P.ParamN;
8023 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
8025 -- Generate the if statement only when the packed parameters need
8026 -- explicit assignments to their corresponding actuals.
8028 if Present
(Unpack
) then
8029 Append_To
(Conc_Typ_Stmts
,
8030 Make_Implicit_If_Statement
(N
,
8036 New_Occurrence_Of
(C
, Loc
),
8038 New_Occurrence_Of
(RTE
(
8039 RE_POK_Protected_Entry
), Loc
)),
8044 New_Occurrence_Of
(C
, Loc
),
8046 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
8048 Then_Statements
=> Unpack
));
8053 -- if C = POK_Procedure
8054 -- or else C = POK_Protected_Procedure
8055 -- or else C = POK_Task_Procedure
8057 -- <dispatching-call>
8059 -- <normal-statements>
8061 -- <else-statements>
8064 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
8066 Prepend_To
(N_Stats
,
8067 Make_Implicit_If_Statement
(N
,
8073 New_Occurrence_Of
(C
, Loc
),
8075 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
8082 New_Occurrence_Of
(C
, Loc
),
8084 New_Occurrence_Of
(RTE
(
8085 RE_POK_Protected_Procedure
), Loc
)),
8090 New_Occurrence_Of
(C
, Loc
),
8092 New_Occurrence_Of
(RTE
(
8093 RE_POK_Task_Procedure
), Loc
)))),
8098 Append_To
(Conc_Typ_Stmts
,
8099 Make_Implicit_If_Statement
(N
,
8100 Condition
=> New_Occurrence_Of
(B
, Loc
),
8101 Then_Statements
=> N_Stats
,
8102 Else_Statements
=> Else_Statements
(N
)));
8105 -- <dispatching-call>;
8106 -- <triggering-statements>
8108 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
8109 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
8112 -- if K = Ada.Tags.TK_Limited_Tagged
8113 -- or else K = Ada.Tags.TK_Tagged
8121 Make_Implicit_If_Statement
(N
,
8122 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
8123 Then_Statements
=> Lim_Typ_Stmts
,
8124 Else_Statements
=> Conc_Typ_Stmts
));
8127 Make_Block_Statement
(Loc
,
8130 Handled_Statement_Sequence
=>
8131 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8133 -- As described above, the entry alternative is transformed into a
8134 -- block that contains the gnulli call, and possibly assignment
8135 -- statements for in-out parameters. The gnulli call may itself be
8136 -- rewritten into a transient block if some unconstrained parameters
8137 -- require it. We need to retrieve the call to complete its parameter
8142 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
8144 if Present
(Transient_Blk
)
8145 and then Nkind
(Transient_Blk
) = N_Block_Statement
8147 Blk
:= Transient_Blk
;
8150 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
8151 Stmt
:= First
(Stmts
);
8152 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
8157 Params
:= Parameter_Associations
(Call
);
8159 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
8161 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8163 Param
:= First
(Params
);
8164 while Present
(Param
)
8165 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
8170 pragma Assert
(Present
(Param
));
8172 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8176 -- Find the Communication_Block parameter for the call to the
8177 -- Cancelled function.
8179 Decl
:= First
(Declarations
(Blk
));
8180 while Present
(Decl
)
8181 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
8182 RE_Communication_Block
)
8187 -- Add an if statement to execute the else part if the call
8188 -- does not succeed (as indicated by the Cancelled predicate).
8191 Make_Implicit_If_Statement
(N
,
8192 Condition
=> Make_Function_Call
(Loc
,
8193 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
8194 Parameter_Associations
=> New_List
(
8195 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))),
8196 Then_Statements
=> Else_Statements
(N
),
8197 Else_Statements
=> Statements
(Alt
)));
8200 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8202 -- Insert declaration of B in declarations of existing block
8204 if No
(Declarations
(Blk
)) then
8205 Set_Declarations
(Blk
, New_List
);
8208 Prepend_To
(Declarations
(Blk
),
8209 Make_Object_Declaration
(Loc
,
8210 Defining_Identifier
=> B
,
8211 Object_Definition
=>
8212 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8214 -- Create new call statement
8217 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8218 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
8221 Make_Procedure_Call_Statement
(Loc
,
8222 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
8223 Parameter_Associations
=> Params
));
8225 -- Construct statement sequence for new block
8228 Make_Implicit_If_Statement
(N
,
8229 Condition
=> New_Occurrence_Of
(B
, Loc
),
8230 Then_Statements
=> Statements
(Alt
),
8231 Else_Statements
=> Else_Statements
(N
)));
8234 -- The result is the new block
8237 Make_Block_Statement
(Loc
,
8238 Declarations
=> Declarations
(Blk
),
8239 Handled_Statement_Sequence
=>
8240 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8245 Reset_Scopes_To
(N
, Entity
(Identifier
(N
)));
8246 end Expand_N_Conditional_Entry_Call
;
8248 ---------------------------------------
8249 -- Expand_N_Delay_Relative_Statement --
8250 ---------------------------------------
8252 -- Delay statement is implemented as a procedure call to Delay_For
8253 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8254 -- simple delays imposed by the use of Protected Objects.
8256 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
8257 Loc
: constant Source_Ptr
:= Sloc
(N
);
8261 -- Try to use System.Relative_Delays.Delay_For only if available. This
8262 -- is the implementation used on restricted platforms when Ada.Calendar
8263 -- is not available.
8265 if RTE_Available
(RO_RD_Delay_For
) then
8266 Proc
:= RTE
(RO_RD_Delay_For
);
8268 -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error
8269 -- message if not available.
8272 Proc
:= RTE
(RO_CA_Delay_For
);
8276 Make_Procedure_Call_Statement
(Loc
,
8277 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8278 Parameter_Associations
=> New_List
(Expression
(N
))));
8280 end Expand_N_Delay_Relative_Statement
;
8282 ------------------------------------
8283 -- Expand_N_Delay_Until_Statement --
8284 ------------------------------------
8286 -- Delay Until statement is implemented as a procedure call to
8287 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8289 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
8290 Loc
: constant Source_Ptr
:= Sloc
(N
);
8294 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
8295 Typ
:= RTE
(RO_CA_Delay_Until
);
8297 Typ
:= RTE
(RO_RT_Delay_Until
);
8301 Make_Procedure_Call_Statement
(Loc
,
8302 Name
=> New_Occurrence_Of
(Typ
, Loc
),
8303 Parameter_Associations
=> New_List
(Expression
(N
))));
8306 end Expand_N_Delay_Until_Statement
;
8308 -------------------------
8309 -- Expand_N_Entry_Body --
8310 -------------------------
8312 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
8314 -- Associate discriminals with the next protected operation body to be
8317 if Present
(Next_Protected_Operation
(N
)) then
8318 Set_Discriminals
(Parent
(Current_Scope
));
8320 end Expand_N_Entry_Body
;
8322 -----------------------------------
8323 -- Expand_N_Entry_Call_Statement --
8324 -----------------------------------
8326 -- An entry call is expanded into GNARLI calls to implement a simple entry
8327 -- call (see Build_Simple_Entry_Call).
8329 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
8335 if No_Run_Time_Mode
then
8336 Error_Msg_CRT
("entry call", N
);
8340 -- If this entry call is part of an asynchronous select, don't expand it
8341 -- here; it will be expanded with the select statement. Don't expand
8342 -- timed entry calls either, as they are translated into asynchronous
8345 -- ??? This whole approach is questionable; it may be better to go back
8346 -- to allowing the expansion to take place and then attempting to fix it
8347 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8348 -- whether the expanded call is on a task or protected entry.
8350 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
8351 or else N
/= Triggering_Statement
(Parent
(N
)))
8352 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8353 or else N
/= Entry_Call_Statement
(Parent
(N
))
8354 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8356 Extract_Entry
(N
, Concval
, Ename
, Index
);
8357 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8359 end Expand_N_Entry_Call_Statement
;
8361 --------------------------------
8362 -- Expand_N_Entry_Declaration --
8363 --------------------------------
8365 -- If there are parameters, then first, each of the formals is marked by
8366 -- setting Is_Entry_Formal. Next a record type is built which is used to
8367 -- hold the parameter values. The name of this record type is entryP where
8368 -- entry is the name of the entry, with an additional corresponding access
8369 -- type called entryPA. The record type has matching components for each
8370 -- formal (the component names are the same as the formal names). For
8371 -- elementary types, the component type matches the formal type. For
8372 -- composite types, an access type is declared (with the name formalA)
8373 -- which designates the formal type, and the type of the component is this
8374 -- access type. Finally the Entry_Component of each formal is set to
8375 -- reference the corresponding record component.
8377 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8378 Loc
: constant Source_Ptr
:= Sloc
(N
);
8379 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8380 Components
: List_Id
;
8383 Last_Decl
: Node_Id
;
8384 Component
: Entity_Id
;
8387 Rec_Ent
: Entity_Id
;
8388 Acc_Ent
: Entity_Id
;
8391 Formal
:= First_Formal
(Entry_Ent
);
8394 -- Most processing is done only if parameters are present
8396 if Present
(Formal
) then
8397 Components
:= New_List
;
8399 -- Loop through formals
8401 while Present
(Formal
) loop
8402 Set_Is_Entry_Formal
(Formal
);
8404 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8405 Set_Entry_Component
(Formal
, Component
);
8406 Set_Entry_Formal
(Component
, Formal
);
8407 Ftype
:= Etype
(Formal
);
8409 -- Declare new access type and then append
8411 Ctype
:= Make_Temporary
(Loc
, 'A');
8412 Set_Is_Param_Block_Component_Type
(Ctype
);
8415 Make_Full_Type_Declaration
(Loc
,
8416 Defining_Identifier
=> Ctype
,
8418 Make_Access_To_Object_Definition
(Loc
,
8419 All_Present
=> True,
8420 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8421 Subtype_Indication
=> New_Occurrence_Of
(Ftype
, Loc
)));
8423 Insert_After
(Last_Decl
, Decl
);
8426 Append_To
(Components
,
8427 Make_Component_Declaration
(Loc
,
8428 Defining_Identifier
=> Component
,
8429 Component_Definition
=>
8430 Make_Component_Definition
(Loc
,
8431 Aliased_Present
=> False,
8432 Subtype_Indication
=> New_Occurrence_Of
(Ctype
, Loc
))));
8434 Next_Formal_With_Extras
(Formal
);
8437 -- Create the Entry_Parameter_Record declaration
8439 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8442 Make_Full_Type_Declaration
(Loc
,
8443 Defining_Identifier
=> Rec_Ent
,
8445 Make_Record_Definition
(Loc
,
8447 Make_Component_List
(Loc
,
8448 Component_Items
=> Components
)));
8450 Insert_After
(Last_Decl
, Decl
);
8453 -- Construct and link in the corresponding access type
8455 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8457 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8460 Make_Full_Type_Declaration
(Loc
,
8461 Defining_Identifier
=> Acc_Ent
,
8463 Make_Access_To_Object_Definition
(Loc
,
8464 All_Present
=> True,
8465 Subtype_Indication
=> New_Occurrence_Of
(Rec_Ent
, Loc
)));
8467 Insert_After
(Last_Decl
, Decl
);
8469 end Expand_N_Entry_Declaration
;
8471 -----------------------------
8472 -- Expand_N_Protected_Body --
8473 -----------------------------
8475 -- Protected bodies are expanded to the completion of the subprograms
8476 -- created for the corresponding protected type. These are a protected and
8477 -- unprotected version of each protected subprogram in the object, a
8478 -- function to calculate each entry barrier, and a procedure to execute the
8479 -- sequence of statements of each protected entry body. For example, for
8480 -- protected type ptype:
8483 -- (O : System.Address;
8484 -- E : Protected_Entry_Index)
8487 -- <discriminant renamings>
8488 -- <private object renamings>
8490 -- return <barrier expression>;
8493 -- procedure pprocN (_object : in out poV;...) is
8494 -- <discriminant renamings>
8495 -- <private object renamings>
8497 -- <sequence of statements>
8500 -- procedure pprocP (_object : in out poV;...) is
8501 -- procedure _clean is
8504 -- ptypeS (_object, Pn);
8505 -- Unlock (_object._object'Access);
8506 -- Abort_Undefer.all;
8511 -- Lock (_object._object'Access);
8512 -- pprocN (_object;...);
8517 -- function pfuncN (_object : poV;...) return Return_Type is
8518 -- <discriminant renamings>
8519 -- <private object renamings>
8521 -- <sequence of statements>
8524 -- function pfuncP (_object : poV) return Return_Type is
8525 -- procedure _clean is
8527 -- Unlock (_object._object'Access);
8528 -- Abort_Undefer.all;
8533 -- Lock (_object._object'Access);
8534 -- return pfuncN (_object);
8541 -- (O : System.Address;
8542 -- P : System.Address;
8543 -- E : Protected_Entry_Index)
8545 -- <discriminant renamings>
8546 -- <private object renamings>
8547 -- type poVP is access poV;
8548 -- _Object : ptVP := ptVP!(O);
8552 -- <statement sequence>
8553 -- Complete_Entry_Body (_Object._Object);
8555 -- when all others =>
8556 -- Exceptional_Complete_Entry_Body (
8557 -- _Object._Object, Get_GNAT_Exception);
8561 -- The type poV is the record created for the protected type to hold
8562 -- the state of the protected object.
8564 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8565 Loc
: constant Source_Ptr
:= Sloc
(N
);
8566 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8568 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8569 -- This flag indicates whether the lock free implementation is active
8571 Current_Node
: Node_Id
;
8572 Disp_Op_Body
: Node_Id
;
8573 New_Op_Body
: Node_Id
;
8577 function Build_Dispatching_Subprogram_Body
8580 Prot_Bod
: Node_Id
) return Node_Id
;
8581 -- Build a dispatching version of the protected subprogram body. The
8582 -- newly generated subprogram contains a call to the original protected
8583 -- body. The following code is generated:
8585 -- function <protected-function-name> (Param1 .. ParamN) return
8588 -- return <protected-function-name>P (Param1 .. ParamN);
8589 -- end <protected-function-name>;
8593 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8595 -- <protected-procedure-name>P (Param1 .. ParamN);
8596 -- end <protected-procedure-name>
8598 ---------------------------------------
8599 -- Build_Dispatching_Subprogram_Body --
8600 ---------------------------------------
8602 function Build_Dispatching_Subprogram_Body
8605 Prot_Bod
: Node_Id
) return Node_Id
8607 Loc
: constant Source_Ptr
:= Sloc
(N
);
8614 -- Generate a specification without a letter suffix in order to
8615 -- override an interface function or procedure.
8617 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8619 -- The formal parameters become the actuals of the protected function
8620 -- or procedure call.
8622 Actuals
:= New_List
;
8623 Formal
:= First
(Parameter_Specifications
(Spec
));
8624 while Present
(Formal
) loop
8626 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8630 if Nkind
(Spec
) = N_Procedure_Specification
then
8633 Make_Procedure_Call_Statement
(Loc
,
8635 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8636 Parameter_Associations
=> Actuals
));
8639 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8643 Make_Simple_Return_Statement
(Loc
,
8645 Make_Function_Call
(Loc
,
8647 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8648 Parameter_Associations
=> Actuals
)));
8652 Make_Subprogram_Body
(Loc
,
8653 Declarations
=> Empty_List
,
8654 Specification
=> Spec
,
8655 Handled_Statement_Sequence
=>
8656 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8657 end Build_Dispatching_Subprogram_Body
;
8659 -- Start of processing for Expand_N_Protected_Body
8662 if No_Run_Time_Mode
then
8663 Error_Msg_CRT
("protected body", N
);
8667 -- This is the proper body corresponding to a stub. The declarations
8668 -- must be inserted at the point of the stub, which in turn is in the
8669 -- declarative part of the parent unit.
8671 if Nkind
(Parent
(N
)) = N_Subunit
then
8672 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8677 Op_Body
:= First
(Declarations
(N
));
8679 -- The protected body is replaced with the bodies of its protected
8680 -- operations, and the declarations for internal objects that may
8681 -- have been created for entry family bounds.
8683 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8686 while Present
(Op_Body
) loop
8687 case Nkind
(Op_Body
) is
8688 when N_Subprogram_Declaration
=>
8691 when N_Subprogram_Body
=>
8693 -- Do not create bodies for eliminated operations
8695 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8696 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8698 if Lock_Free_Active
then
8700 Build_Lock_Free_Unprotected_Subprogram_Body
8704 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8707 Insert_After
(Current_Node
, New_Op_Body
);
8708 Current_Node
:= New_Op_Body
;
8709 Analyze
(New_Op_Body
);
8711 -- Build the corresponding protected operation. It may
8712 -- appear that this is needed only if this is a visible
8713 -- operation of the type, or if it is an interrupt handler,
8714 -- and this was the strategy used previously in GNAT.
8716 -- However, the operation may be exported through a 'Access
8717 -- to an external caller. This is the common idiom in code
8718 -- that uses the Ada 2005 Timing_Events package. As a result
8719 -- we need to produce the protected body for both visible
8720 -- and private operations, as well as operations that only
8721 -- have a body in the source, and for which we create a
8722 -- declaration in the protected body itself.
8724 if Present
(Corresponding_Spec
(Op_Body
)) then
8725 if Lock_Free_Active
then
8727 Build_Lock_Free_Protected_Subprogram_Body
8728 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8731 Build_Protected_Subprogram_Body
8732 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8735 Insert_After
(Current_Node
, New_Op_Body
);
8736 Analyze
(New_Op_Body
);
8738 Current_Node
:= New_Op_Body
;
8740 -- Generate an overriding primitive operation body for
8741 -- this subprogram if the protected type implements an
8744 if Ada_Version
>= Ada_2005
8746 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
8749 Build_Dispatching_Subprogram_Body
8750 (Op_Body
, Pid
, New_Op_Body
);
8752 Insert_After
(Current_Node
, Disp_Op_Body
);
8753 Analyze
(Disp_Op_Body
);
8755 Current_Node
:= Disp_Op_Body
;
8760 when N_Entry_Body
=>
8761 Op_Id
:= Defining_Identifier
(Op_Body
);
8762 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8764 Insert_After
(Current_Node
, New_Op_Body
);
8765 Current_Node
:= New_Op_Body
;
8766 Analyze
(New_Op_Body
);
8768 when N_Implicit_Label_Declaration
=>
8774 New_Op_Body
:= New_Copy
(Op_Body
);
8775 Insert_After
(Current_Node
, New_Op_Body
);
8776 Current_Node
:= New_Op_Body
;
8778 when N_Freeze_Entity
=>
8779 New_Op_Body
:= New_Copy
(Op_Body
);
8781 if Present
(Entity
(Op_Body
))
8782 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8784 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8787 Insert_After
(Current_Node
, New_Op_Body
);
8788 Current_Node
:= New_Op_Body
;
8789 Analyze
(New_Op_Body
);
8792 New_Op_Body
:= New_Copy
(Op_Body
);
8793 Insert_After
(Current_Node
, New_Op_Body
);
8794 Current_Node
:= New_Op_Body
;
8795 Analyze
(New_Op_Body
);
8797 when N_Object_Declaration
=>
8798 pragma Assert
(not Comes_From_Source
(Op_Body
));
8799 New_Op_Body
:= New_Copy
(Op_Body
);
8800 Insert_After
(Current_Node
, New_Op_Body
);
8801 Current_Node
:= New_Op_Body
;
8802 Analyze
(New_Op_Body
);
8805 raise Program_Error
;
8811 -- Finally, create the body of the function that maps an entry index
8812 -- into the corresponding body index, except when there is no entry, or
8813 -- in a Ravenscar-like profile.
8815 if Corresponding_Runtime_Package
(Pid
) =
8816 System_Tasking_Protected_Objects_Entries
8818 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8819 Insert_After
(Current_Node
, New_Op_Body
);
8820 Current_Node
:= New_Op_Body
;
8821 Analyze
(New_Op_Body
);
8824 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8825 -- protected body. At this point all wrapper specs have been created,
8826 -- frozen and included in the dispatch table for the protected type.
8828 if Ada_Version
>= Ada_2005
then
8829 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8831 end Expand_N_Protected_Body
;
8833 -----------------------------------------
8834 -- Expand_N_Protected_Type_Declaration --
8835 -----------------------------------------
8837 -- First we create a corresponding record type declaration used to
8838 -- represent values of this protected type.
8839 -- The general form of this type declaration is
8841 -- type poV (discriminants) is record
8842 -- _Object : aliased <kind>Protection
8843 -- [(<entry count> [, <handler count>])];
8844 -- [entry_family : array (bounds) of Void;]
8845 -- <private data fields>
8848 -- The discriminants are present only if the corresponding protected type
8849 -- has discriminants, and they exactly mirror the protected type
8850 -- discriminants. The private data fields similarly mirror the private
8851 -- declarations of the protected type.
8853 -- The Object field is always present. It contains RTS specific data used
8854 -- to control the protected object. It is declared as Aliased so that it
8855 -- can be passed as a pointer to the RTS. This allows the protected record
8856 -- to be referenced within RTS data structures. An appropriate Protection
8857 -- type and discriminant are generated.
8859 -- The Service field is present for protected objects with entries. It
8860 -- contains sufficient information to allow the entry service procedure for
8861 -- this object to be called when the object is not known till runtime.
8863 -- One entry_family component is present for each entry family in the
8864 -- task definition (see Expand_N_Task_Type_Declaration).
8866 -- When a protected object is declared, an instance of the protected type
8867 -- value record is created. The elaboration of this declaration creates the
8868 -- correct bounds for the entry families, and also evaluates the priority
8869 -- expression if needed. The initialization routine for the protected type
8870 -- itself then calls Initialize_Protection with appropriate parameters to
8871 -- initialize the value of the Task_Id field. Install_Handlers may be also
8872 -- called if a pragma Attach_Handler applies.
8874 -- Note: this record is passed to the subprograms created by the expansion
8875 -- of protected subprograms and entries. It is an in parameter to protected
8876 -- functions and an in out parameter to procedures and entry bodies. The
8877 -- Entity_Id for this created record type is placed in the
8878 -- Corresponding_Record_Type field of the associated protected type entity.
8880 -- Next we create a procedure specifications for protected subprograms and
8881 -- entry bodies. For each protected subprograms two subprograms are
8882 -- created, an unprotected and a protected version. The unprotected version
8883 -- is called from within other operations of the same protected object.
8885 -- We also build the call to register the procedure if a pragma
8886 -- Interrupt_Handler applies.
8888 -- A single subprogram is created to service all entry bodies; it has an
8889 -- additional boolean out parameter indicating that the previous entry call
8890 -- made by the current task was serviced immediately, i.e. not by proxy.
8891 -- The O parameter contains a pointer to a record object of the type
8892 -- described above. An untyped interface is used here to allow this
8893 -- procedure to be called in places where the type of the object to be
8894 -- serviced is not known. This must be done, for example, when a call that
8895 -- may have been requeued is cancelled; the corresponding object must be
8896 -- serviced, but which object that is not known till runtime.
8899 -- (O : System.Address; P : out Boolean);
8900 -- procedure pprocN (_object : in out poV);
8901 -- procedure pproc (_object : in out poV);
8902 -- function pfuncN (_object : poV);
8903 -- function pfunc (_object : poV);
8906 -- Note that this must come after the record type declaration, since
8907 -- the specs refer to this type.
8909 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
8910 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
8911 Loc
: constant Source_Ptr
:= Sloc
(N
);
8912 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
8914 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
8915 -- This flag indicates whether the lock free implementation is active
8917 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
8918 -- This contains two lists; one for visible and one for private decls
8920 Current_Node
: Node_Id
:= N
;
8922 Entries_Aggr
: Node_Id
;
8924 procedure Check_Inlining
(Subp
: Entity_Id
);
8925 -- If the original operation has a pragma Inline, propagate the flag
8926 -- to the internal body, for possible inlining later on. The source
8927 -- operation is invisible to the back-end and is never actually called.
8929 procedure Expand_Entry_Declaration
(Decl
: Node_Id
);
8930 -- Create the entry barrier and the procedure body for entry declaration
8931 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
8933 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
8934 -- When compiling under the Ravenscar profile, private components must
8935 -- have a static size, or else a protected object will require heap
8936 -- allocation, violating the corresponding restriction. It is preferable
8937 -- to make this check here, because it provides a better error message
8938 -- than the back-end, which refers to the object as a whole.
8940 procedure Register_Handler
;
8941 -- For a protected operation that is an interrupt handler, add the
8942 -- freeze action that will register it as such.
8944 --------------------
8945 -- Check_Inlining --
8946 --------------------
8948 procedure Check_Inlining
(Subp
: Entity_Id
) is
8950 if Is_Inlined
(Subp
) then
8951 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
8952 Set_Is_Inlined
(Subp
, False);
8956 ---------------------------
8957 -- Static_Component_Size --
8958 ---------------------------
8960 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
8961 Typ
: constant Entity_Id
:= Etype
(Comp
);
8965 if Is_Scalar_Type
(Typ
) then
8968 elsif Is_Array_Type
(Typ
) then
8969 return Compile_Time_Known_Bounds
(Typ
);
8971 elsif Is_Record_Type
(Typ
) then
8972 C
:= First_Component
(Typ
);
8973 while Present
(C
) loop
8974 if not Static_Component_Size
(C
) then
8983 -- Any other type will be checked by the back-end
8988 end Static_Component_Size
;
8990 ------------------------------
8991 -- Expand_Entry_Declaration --
8992 ------------------------------
8994 procedure Expand_Entry_Declaration
(Decl
: Node_Id
) is
8995 Ent_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
9001 E_Count
:= E_Count
+ 1;
9003 -- Create the protected body subprogram
9006 Make_Defining_Identifier
(Loc
,
9007 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'E'));
9008 Set_Protected_Body_Subprogram
(Ent_Id
, Bod_Id
);
9011 Make_Subprogram_Declaration
(Loc
,
9013 Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Ent_Id
));
9015 Insert_After
(Current_Node
, Subp
);
9016 Current_Node
:= Subp
;
9020 -- Build a wrapper procedure to handle contract cases, preconditions,
9021 -- and postconditions.
9023 Build_Contract_Wrapper
(Ent_Id
, N
);
9025 -- Create the barrier function
9028 Make_Defining_Identifier
(Loc
,
9029 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'B'));
9030 Set_Barrier_Function
(Ent_Id
, Bar_Id
);
9033 Make_Subprogram_Declaration
(Loc
,
9035 Build_Barrier_Function_Specification
(Loc
, Bar_Id
));
9036 Set_Is_Entry_Barrier_Function
(Subp
);
9038 Insert_After
(Current_Node
, Subp
);
9039 Current_Node
:= Subp
;
9043 Set_Protected_Body_Subprogram
(Bar_Id
, Bar_Id
);
9044 Set_Scope
(Bar_Id
, Scope
(Ent_Id
));
9046 -- Collect pointers to the protected subprogram and the barrier
9047 -- of the current entry, for insertion into Entry_Bodies_Array.
9049 Append_To
(Expressions
(Entries_Aggr
),
9050 Make_Aggregate
(Loc
,
9051 Expressions
=> New_List
(
9052 Make_Attribute_Reference
(Loc
,
9053 Prefix
=> New_Occurrence_Of
(Bar_Id
, Loc
),
9054 Attribute_Name
=> Name_Unrestricted_Access
),
9055 Make_Attribute_Reference
(Loc
,
9056 Prefix
=> New_Occurrence_Of
(Bod_Id
, Loc
),
9057 Attribute_Name
=> Name_Unrestricted_Access
))));
9058 end Expand_Entry_Declaration
;
9060 ----------------------
9061 -- Register_Handler --
9062 ----------------------
9064 procedure Register_Handler
is
9066 -- All semantic checks already done in Sem_Prag
9068 Prot_Proc
: constant Entity_Id
:=
9069 Defining_Unit_Name
(Specification
(Current_Node
));
9071 Proc_Address
: constant Node_Id
:=
9072 Make_Attribute_Reference
(Loc
,
9074 New_Occurrence_Of
(Prot_Proc
, Loc
),
9075 Attribute_Name
=> Name_Address
);
9077 RTS_Call
: constant Entity_Id
:=
9078 Make_Procedure_Call_Statement
(Loc
,
9081 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
9082 Parameter_Associations
=> New_List
(Proc_Address
));
9084 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
9085 end Register_Handler
;
9090 Body_Id
: Entity_Id
;
9096 Object_Comp
: Node_Id
;
9101 -- Start of processing for Expand_N_Protected_Type_Declaration
9104 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
9107 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
9110 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
9112 Qualify_Entity_Names
(N
);
9114 -- If the type has discriminants, their occurrences in the declaration
9115 -- have been replaced by the corresponding discriminals. For components
9116 -- that are constrained by discriminants, their homologues in the
9117 -- corresponding record type must refer to the discriminants of that
9118 -- record, so we must apply a new renaming to subtypes_indications:
9120 -- protected discriminant => discriminal => record discriminant
9122 -- This replacement is not applied to default expressions, for which
9123 -- the discriminal is correct.
9125 if Has_Discriminants
(Prot_Typ
) then
9131 Disc
:= First_Discriminant
(Prot_Typ
);
9132 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
9133 while Present
(Disc
) loop
9134 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
9135 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
9136 Next_Discriminant
(Disc
);
9142 -- Fill in the component declarations
9144 -- Add components for entry families. For each entry family, create an
9145 -- anonymous type declaration with the same size, and analyze the type.
9147 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
9149 pragma Assert
(Present
(Pdef
));
9151 Insert_After
(Current_Node
, Rec_Decl
);
9152 Current_Node
:= Rec_Decl
;
9154 -- Add private field components
9156 if Present
(Private_Declarations
(Pdef
)) then
9157 Priv
:= First
(Private_Declarations
(Pdef
));
9158 while Present
(Priv
) loop
9159 if Nkind
(Priv
) = N_Component_Declaration
then
9160 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
9162 -- When compiling for a restricted profile, the private
9163 -- components must have a static size. If not, this is an
9164 -- error for a single protected declaration, and rates a
9165 -- warning on a protected type declaration.
9167 if not Comes_From_Source
(Prot_Typ
) then
9169 -- It's ok to be checking this restriction at expansion
9170 -- time, because this is only for the restricted profile,
9171 -- which is not subject to strict RM conformance, so it
9172 -- is OK to miss this check in -gnatc mode.
9174 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
9176 (No_Implicit_Protected_Object_Allocations
, Priv
);
9178 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
9179 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9181 -- Any object of the type will be non-static
9183 Error_Msg_N
("component has non-static size??", Priv
);
9185 ("\creation of protected object of type& will "
9186 & "violate restriction "
9187 & "No_Implicit_Heap_Allocations??", Priv
, Prot_Typ
);
9189 -- Object will be non-static if discriminants are
9192 ("creation of protected object of type& with "
9193 & "non-static discriminants will violate "
9194 & "restriction No_Implicit_Heap_Allocations??",
9198 -- Likewise for No_Implicit_Protected_Object_Allocations
9200 elsif Restriction_Active
9201 (No_Implicit_Protected_Object_Allocations
)
9203 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9205 -- Any object of the type will be non-static
9207 Error_Msg_N
("component has non-static size??", Priv
);
9209 ("\creation of protected object of type& will "
9210 & "violate restriction "
9211 & "No_Implicit_Protected_Object_Allocations??",
9214 -- Object will be non-static if discriminants are
9217 ("creation of protected object of type& with "
9218 & "non-static discriminants will violate "
9220 & "No_Implicit_Protected_Object_Allocations??",
9226 -- The component definition consists of a subtype indication,
9227 -- or (in Ada 2005) an access definition. Make a copy of the
9228 -- proper definition.
9231 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
9232 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
9233 Nent
: constant Entity_Id
:=
9234 Make_Defining_Identifier
(Sloc
(Oent
),
9235 Chars
=> Chars
(Oent
));
9239 if Present
(Subtype_Indication
(Old_Comp
)) then
9241 Make_Component_Definition
(Sloc
(Oent
),
9242 Aliased_Present
=> False,
9243 Subtype_Indication
=>
9245 (Subtype_Indication
(Old_Comp
), Discr_Map
));
9248 Make_Component_Definition
(Sloc
(Oent
),
9249 Aliased_Present
=> False,
9250 Access_Definition
=>
9252 (Access_Definition
(Old_Comp
), Discr_Map
));
9256 Make_Component_Declaration
(Loc
,
9257 Defining_Identifier
=> Nent
,
9258 Component_Definition
=> New_Comp
,
9259 Expression
=> Expression
(Priv
));
9261 Set_Has_Per_Object_Constraint
(Nent
,
9262 Has_Per_Object_Constraint
(Oent
));
9264 Append_To
(Cdecls
, New_Priv
);
9267 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
9269 -- Make the unprotected version of the subprogram available
9270 -- for expansion of intra object calls. There is need for
9271 -- a protected version only if the subprogram is an interrupt
9272 -- handler, otherwise this operation can only be called from
9276 Make_Subprogram_Declaration
(Loc
,
9278 Build_Protected_Sub_Specification
9279 (Priv
, Prot_Typ
, Unprotected_Mode
));
9281 Insert_After
(Current_Node
, Sub
);
9284 Set_Protected_Body_Subprogram
9285 (Defining_Unit_Name
(Specification
(Priv
)),
9286 Defining_Unit_Name
(Specification
(Sub
)));
9287 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
9288 Current_Node
:= Sub
;
9291 Make_Subprogram_Declaration
(Loc
,
9293 Build_Protected_Sub_Specification
9294 (Priv
, Prot_Typ
, Protected_Mode
));
9296 Insert_After
(Current_Node
, Sub
);
9298 Current_Node
:= Sub
;
9300 if Is_Interrupt_Handler
9301 (Defining_Unit_Name
(Specification
(Priv
)))
9303 if not Restricted_Profile
then
9313 -- Except for the lock-free implementation, append the _Object field
9314 -- with the right type to the component list. We need to compute the
9315 -- number of entries, and in some cases the number of Attach_Handler
9318 if not Lock_Free_Active
then
9320 Entry_Count_Expr
: constant Node_Id
:=
9321 Build_Entry_Count_Expression
9322 (Prot_Typ
, Cdecls
, Loc
);
9323 Num_Attach_Handler
: Nat
:= 0;
9324 Protection_Subtype
: Node_Id
;
9328 if Has_Attach_Handler
(Prot_Typ
) then
9329 Ritem
:= First_Rep_Item
(Prot_Typ
);
9330 while Present
(Ritem
) loop
9331 if Nkind
(Ritem
) = N_Pragma
9332 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
9334 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
9337 Next_Rep_Item
(Ritem
);
9341 -- Determine the proper protection type. There are two special
9342 -- cases: 1) when the protected type has dynamic interrupt
9343 -- handlers, and 2) when it has static handlers and we use a
9344 -- restricted profile.
9346 if Has_Attach_Handler
(Prot_Typ
)
9347 and then not Restricted_Profile
9349 Protection_Subtype
:=
9350 Make_Subtype_Indication
(Loc
,
9353 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
9355 Make_Index_Or_Discriminant_Constraint
(Loc
,
9356 Constraints
=> New_List
(
9358 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
9360 elsif Has_Interrupt_Handler
(Prot_Typ
)
9361 and then not Restriction_Active
(No_Dynamic_Attachment
)
9363 Protection_Subtype
:=
9364 Make_Subtype_Indication
(Loc
,
9367 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
9369 Make_Index_Or_Discriminant_Constraint
(Loc
,
9370 Constraints
=> New_List
(Entry_Count_Expr
)));
9373 case Corresponding_Runtime_Package
(Prot_Typ
) is
9374 when System_Tasking_Protected_Objects_Entries
=>
9375 Protection_Subtype
:=
9376 Make_Subtype_Indication
(Loc
,
9379 (RTE
(RE_Protection_Entries
), Loc
),
9381 Make_Index_Or_Discriminant_Constraint
(Loc
,
9382 Constraints
=> New_List
(Entry_Count_Expr
)));
9384 when System_Tasking_Protected_Objects_Single_Entry
=>
9385 Protection_Subtype
:=
9386 New_Occurrence_Of
(RTE
(RE_Protection_Entry
), Loc
);
9388 when System_Tasking_Protected_Objects
=>
9389 Protection_Subtype
:=
9390 New_Occurrence_Of
(RTE
(RE_Protection
), Loc
);
9393 raise Program_Error
;
9398 Make_Component_Declaration
(Loc
,
9399 Defining_Identifier
=>
9400 Make_Defining_Identifier
(Loc
, Name_uObject
),
9401 Component_Definition
=>
9402 Make_Component_Definition
(Loc
,
9403 Aliased_Present
=> True,
9404 Subtype_Indication
=> Protection_Subtype
));
9407 -- Put the _Object component after the private component so that it
9408 -- be finalized early as required by 9.4 (20)
9410 Append_To
(Cdecls
, Object_Comp
);
9413 -- Analyze the record declaration immediately after construction,
9414 -- because the initialization procedure is needed for single object
9415 -- declarations before the next entity is analyzed (the freeze call
9416 -- that generates this initialization procedure is found below).
9418 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
9420 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9421 -- the corresponding record is frozen. If any wrappers are generated,
9422 -- Current_Node is updated accordingly.
9424 if Ada_Version
>= Ada_2005
then
9425 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
9428 -- Collect pointers to entry bodies and their barriers, to be placed
9429 -- in the Entry_Bodies_Array for the type. For each entry/family we
9430 -- add an expression to the aggregate which is the initial value of
9431 -- this array. The array is declared after all protected subprograms.
9433 if Has_Entries
(Prot_Typ
) then
9434 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
9436 Entries_Aggr
:= Empty
;
9439 -- Build two new procedure specifications for each protected subprogram;
9440 -- one to call from outside the object and one to call from inside.
9441 -- Build a barrier function and an entry body action procedure
9442 -- specification for each protected entry. Initialize the entry body
9443 -- array. If subprogram is flagged as eliminated, do not generate any
9444 -- internal operations.
9447 Comp
:= First
(Visible_Declarations
(Pdef
));
9448 while Present
(Comp
) loop
9449 if Nkind
(Comp
) = N_Subprogram_Declaration
then
9451 Make_Subprogram_Declaration
(Loc
,
9453 Build_Protected_Sub_Specification
9454 (Comp
, Prot_Typ
, Unprotected_Mode
));
9456 Insert_After
(Current_Node
, Sub
);
9459 Set_Protected_Body_Subprogram
9460 (Defining_Unit_Name
(Specification
(Comp
)),
9461 Defining_Unit_Name
(Specification
(Sub
)));
9462 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
9464 -- Make the protected version of the subprogram available for
9465 -- expansion of external calls.
9467 Current_Node
:= Sub
;
9470 Make_Subprogram_Declaration
(Loc
,
9472 Build_Protected_Sub_Specification
9473 (Comp
, Prot_Typ
, Protected_Mode
));
9475 Insert_After
(Current_Node
, Sub
);
9478 Current_Node
:= Sub
;
9480 -- Generate an overriding primitive operation specification for
9481 -- this subprogram if the protected type implements an interface
9482 -- and Build_Wrapper_Spec did not generate its wrapper.
9484 if Ada_Version
>= Ada_2005
9486 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9489 Found
: Boolean := False;
9490 Prim_Elmt
: Elmt_Id
;
9496 (Primitive_Operations
9497 (Corresponding_Record_Type
(Prot_Typ
)));
9499 while Present
(Prim_Elmt
) loop
9500 Prim_Op
:= Node
(Prim_Elmt
);
9502 if Is_Primitive_Wrapper
(Prim_Op
)
9503 and then Wrapped_Entity
(Prim_Op
) =
9504 Defining_Entity
(Specification
(Comp
))
9510 Next_Elmt
(Prim_Elmt
);
9515 Make_Subprogram_Declaration
(Loc
,
9517 Build_Protected_Sub_Specification
9518 (Comp
, Prot_Typ
, Dispatching_Mode
));
9520 Insert_After
(Current_Node
, Sub
);
9523 Current_Node
:= Sub
;
9528 -- If a pragma Interrupt_Handler applies, build and add a call to
9529 -- Register_Interrupt_Handler to the freezing actions of the
9530 -- protected version (Current_Node) of the subprogram:
9532 -- system.interrupts.register_interrupt_handler
9533 -- (prot_procP'address);
9535 if not Restricted_Profile
9536 and then Is_Interrupt_Handler
9537 (Defining_Unit_Name
(Specification
(Comp
)))
9542 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9543 Expand_Entry_Declaration
(Comp
);
9549 -- If there are some private entry declarations, expand it as if they
9550 -- were visible entries.
9552 if Present
(Private_Declarations
(Pdef
)) then
9553 Comp
:= First
(Private_Declarations
(Pdef
));
9554 while Present
(Comp
) loop
9555 if Nkind
(Comp
) = N_Entry_Declaration
then
9556 Expand_Entry_Declaration
(Comp
);
9563 -- Create the declaration of an array object which contains the values
9564 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9565 -- type. This object is later passed to the appropriate protected object
9566 -- initialization routine.
9568 if Has_Entries
(Prot_Typ
)
9569 and then Corresponding_Runtime_Package
(Prot_Typ
) =
9570 System_Tasking_Protected_Objects_Entries
9577 Maxes_Id
: Entity_Id
;
9578 Need_Array
: Boolean := False;
9581 -- First check if there is any Max_Queue_Length pragma
9583 Item
:= First_Entity
(Prot_Typ
);
9584 while Present
(Item
) loop
9585 if Is_Entry
(Item
) and then Has_Max_Queue_Length
(Item
) then
9593 -- Gather the Max_Queue_Length values of all entries in a list. A
9594 -- value of zero indicates that the entry has no limitation on its
9599 Item
:= First_Entity
(Prot_Typ
);
9601 while Present
(Item
) loop
9602 if Is_Entry
(Item
) then
9605 Make_Integer_Literal
9606 (Loc
, Get_Max_Queue_Length
(Item
)));
9612 -- Create the declaration of the array object. Generate:
9614 -- Maxes_Id : aliased constant
9615 -- Protected_Entry_Queue_Max_Array
9616 -- (1 .. Count) := (..., ...);
9619 Make_Defining_Identifier
(Loc
,
9620 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'B'));
9623 Make_Object_Declaration
(Loc
,
9624 Defining_Identifier
=> Maxes_Id
,
9625 Aliased_Present
=> True,
9626 Constant_Present
=> True,
9627 Object_Definition
=>
9628 Make_Subtype_Indication
(Loc
,
9631 (RTE
(RE_Protected_Entry_Queue_Max_Array
), Loc
),
9633 Make_Index_Or_Discriminant_Constraint
(Loc
,
9634 Constraints
=> New_List
(
9636 Make_Integer_Literal
(Loc
, 1),
9637 Make_Integer_Literal
(Loc
, Count
))))),
9638 Expression
=> Make_Aggregate
(Loc
, Maxes
));
9640 -- A pointer to this array will be placed in the corresponding
9641 -- record by its initialization procedure so this needs to be
9644 Insert_After
(Current_Node
, Max_Vals
);
9645 Current_Node
:= Max_Vals
;
9648 Set_Entry_Max_Queue_Lengths_Array
(Prot_Typ
, Maxes_Id
);
9653 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9654 -- all protected subprograms have been collected.
9656 if Has_Entries
(Prot_Typ
) then
9658 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9659 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9661 case Corresponding_Runtime_Package
(Prot_Typ
) is
9662 when System_Tasking_Protected_Objects_Entries
=>
9663 Expr
:= Entries_Aggr
;
9665 Make_Subtype_Indication
(Loc
,
9668 (RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9670 Make_Index_Or_Discriminant_Constraint
(Loc
,
9671 Constraints
=> New_List
(
9673 Make_Integer_Literal
(Loc
, 1),
9674 Make_Integer_Literal
(Loc
, E_Count
)))));
9676 when System_Tasking_Protected_Objects_Single_Entry
=>
9677 Expr
:= Remove_Head
(Expressions
(Entries_Aggr
));
9678 Obj_Def
:= New_Occurrence_Of
(RTE
(RE_Entry_Body
), Loc
);
9681 raise Program_Error
;
9685 Make_Object_Declaration
(Loc
,
9686 Defining_Identifier
=> Body_Id
,
9687 Aliased_Present
=> True,
9688 Constant_Present
=> True,
9689 Object_Definition
=> Obj_Def
,
9690 Expression
=> Expr
);
9692 -- A pointer to this array will be placed in the corresponding record
9693 -- by its initialization procedure so this needs to be analyzed here.
9695 Insert_After
(Current_Node
, Body_Arr
);
9696 Current_Node
:= Body_Arr
;
9699 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9701 -- Finally, build the function that maps an entry index into the
9702 -- corresponding body. A pointer to this function is placed in each
9703 -- object of the type. Except for a ravenscar-like profile (no abort,
9704 -- no entry queue, 1 entry)
9706 if Corresponding_Runtime_Package
(Prot_Typ
) =
9707 System_Tasking_Protected_Objects_Entries
9710 Make_Subprogram_Declaration
(Loc
,
9711 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9713 Insert_After
(Current_Node
, Sub
);
9717 end Expand_N_Protected_Type_Declaration
;
9719 --------------------------------
9720 -- Expand_N_Requeue_Statement --
9721 --------------------------------
9723 -- A nondispatching requeue statement is expanded into one of four GNARLI
9724 -- operations, depending on the source and destination (task or protected
9725 -- object). A dispatching requeue statement is expanded into a call to the
9726 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9727 -- jump around the remainder of processing for the original entry and, if
9728 -- the destination is (different) protected object, to attempt to service
9729 -- it. The following illustrates the various cases:
9732 -- (O : System.Address;
9733 -- P : System.Address;
9734 -- E : Protected_Entry_Index)
9736 -- <discriminant renamings>
9737 -- <private object renamings>
9738 -- type poVP is access poV;
9739 -- _object : ptVP := ptVP!(O);
9743 -- <start of statement sequence for entry>
9745 -- -- Requeue from one protected entry body to another protected
9748 -- Requeue_Protected_Entry (
9749 -- _object._object'Access,
9750 -- new._object'Access,
9755 -- <some more of the statement sequence for entry>
9757 -- -- Requeue from an entry body to a task entry
9759 -- Requeue_Protected_To_Task_Entry (
9765 -- <rest of statement sequence for entry>
9766 -- Complete_Entry_Body (_object._object);
9769 -- when all others =>
9770 -- Exceptional_Complete_Entry_Body (
9771 -- _object._object, Get_GNAT_Exception);
9775 -- Requeue of a task entry call to a task entry
9777 -- Accept_Call (E, Ann);
9778 -- <start of statement sequence for accept statement>
9779 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9781 -- <rest of statement sequence for accept statement>
9783 -- Complete_Rendezvous;
9786 -- when all others =>
9787 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9789 -- Requeue of a task entry call to a protected entry
9791 -- Accept_Call (E, Ann);
9792 -- <start of statement sequence for accept statement>
9793 -- Requeue_Task_To_Protected_Entry (
9794 -- new._object'Access,
9799 -- <rest of statement sequence for accept statement>
9801 -- Complete_Rendezvous;
9804 -- when all others =>
9805 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9807 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9808 -- marked by pragma Implemented (XXX, By_Entry).
9810 -- The requeue is inside a protected entry:
9813 -- (O : System.Address;
9814 -- P : System.Address;
9815 -- E : Protected_Entry_Index)
9817 -- <discriminant renamings>
9818 -- <private object renamings>
9819 -- type poVP is access poV;
9820 -- _object : ptVP := ptVP!(O);
9824 -- <start of statement sequence for entry>
9827 -- (<interface class-wide object>,
9830 -- Ada.Tags.Get_Offset_Index
9832 -- <interface dispatch table index of target entry>),
9836 -- <rest of statement sequence for entry>
9837 -- Complete_Entry_Body (_object._object);
9840 -- when all others =>
9841 -- Exceptional_Complete_Entry_Body (
9842 -- _object._object, Get_GNAT_Exception);
9846 -- The requeue is inside a task entry:
9848 -- Accept_Call (E, Ann);
9849 -- <start of statement sequence for accept statement>
9851 -- (<interface class-wide object>,
9854 -- Ada.Tags.Get_Offset_Index
9856 -- <interface dispatch table index of target entrt>),
9860 -- <rest of statement sequence for accept statement>
9862 -- Complete_Rendezvous;
9865 -- when all others =>
9866 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9868 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9869 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9870 -- statement is replaced by a dispatching call with actual parameters taken
9871 -- from the inner-most accept statement or entry body.
9873 -- Target.Primitive (Param1, ..., ParamN);
9875 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9876 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9880 -- S : constant Offset_Index :=
9881 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9882 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9885 -- if C = POK_Protected_Entry
9886 -- or else C = POK_Task_Entry
9888 -- <statements for dispatching requeue>
9890 -- elsif C = POK_Protected_Procedure then
9891 -- <dispatching call equivalent>
9894 -- raise Program_Error;
9898 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
9899 Loc
: constant Source_Ptr
:= Sloc
(N
);
9900 Conc_Typ
: Entity_Id
;
9904 Old_Typ
: Entity_Id
;
9906 function Build_Dispatching_Call_Equivalent
return Node_Id
;
9907 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9908 -- the form Concval.Ename. It is statically known that Ename is allowed
9909 -- to be implemented by a protected procedure. Create a dispatching call
9910 -- equivalent of Concval.Ename taking the actual parameters from the
9911 -- inner-most accept statement or entry body.
9913 function Build_Dispatching_Requeue
return Node_Id
;
9914 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9915 -- the form Concval.Ename. It is statically known that Ename is allowed
9916 -- to be implemented by a protected or a task entry. Create a call to
9917 -- primitive _Disp_Requeue which handles the low-level actions.
9919 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
9920 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9921 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9922 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9923 -- determines at runtime whether Ename denotes an entry or a procedure
9924 -- and perform the appropriate kind of dispatching select.
9926 function Build_Normal_Requeue
return Node_Id
;
9927 -- N denotes a nondispatching requeue statement to either a task or a
9928 -- protected entry. Build the appropriate runtime call to perform the
9931 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
9932 -- For a protected entry, create a return statement to skip the rest of
9933 -- the entry body. Otherwise, create a goto statement to skip the rest
9934 -- of a task accept statement. The lookup for the enclosing entry body
9935 -- or accept statement starts from Search.
9937 ---------------------------------------
9938 -- Build_Dispatching_Call_Equivalent --
9939 ---------------------------------------
9941 function Build_Dispatching_Call_Equivalent
return Node_Id
is
9942 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
9943 Obj
: constant Node_Id
:= Original_Node
(Concval
);
9950 -- Climb the parent chain looking for the inner-most entry body or
9951 -- accept statement.
9954 while Present
(Acc_Ent
)
9955 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
9958 Acc_Ent
:= Parent
(Acc_Ent
);
9961 -- A requeue statement should be housed inside an entry body or an
9962 -- accept statement at some level. If this is not the case, then the
9963 -- tree is malformed.
9965 pragma Assert
(Present
(Acc_Ent
));
9967 -- Recover the list of formal parameters
9969 if Nkind
(Acc_Ent
) = N_Entry_Body
then
9970 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
9973 Formals
:= Parameter_Specifications
(Acc_Ent
);
9975 -- Create the actual parameters for the dispatching call. These are
9976 -- simply copies of the entry body or accept statement formals in the
9977 -- same order as they appear.
9981 if Present
(Formals
) then
9982 Actuals
:= New_List
;
9983 Formal
:= First
(Formals
);
9984 while Present
(Formal
) loop
9986 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
9992 -- Obj.Call_Ent (Actuals);
9995 Make_Procedure_Call_Statement
(Loc
,
9997 Make_Selected_Component
(Loc
,
9998 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
9999 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
10001 Parameter_Associations
=> Actuals
);
10002 end Build_Dispatching_Call_Equivalent
;
10004 -------------------------------
10005 -- Build_Dispatching_Requeue --
10006 -------------------------------
10008 function Build_Dispatching_Requeue
return Node_Id
is
10009 Params
: constant List_Id
:= New_List
;
10012 -- Process the "with abort" parameter
10014 Prepend_To
(Params
,
10015 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10017 -- Process the entry wrapper's position in the primary dispatch
10018 -- table parameter. Generate:
10020 -- Ada.Tags.Get_Entry_Index
10021 -- (T => To_Tag_Ptr (Obj'Address).all,
10023 -- Ada.Tags.Get_Offset_Index
10024 -- (Ada.Tags.Tag (Concval),
10025 -- <interface dispatch table position of Ename>));
10027 -- Note that Obj'Address is recursively expanded into a call to
10028 -- Base_Address (Obj).
10030 if Tagged_Type_Expansion
then
10031 Prepend_To
(Params
,
10032 Make_Function_Call
(Loc
,
10033 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10034 Parameter_Associations
=> New_List
(
10036 Make_Explicit_Dereference
(Loc
,
10037 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
10038 Make_Attribute_Reference
(Loc
,
10039 Prefix
=> New_Copy_Tree
(Concval
),
10040 Attribute_Name
=> Name_Address
))),
10042 Make_Function_Call
(Loc
,
10043 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10044 Parameter_Associations
=> New_List
(
10045 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
10046 Make_Integer_Literal
(Loc
,
10047 DT_Position
(Entity
(Ename
))))))));
10052 Prepend_To
(Params
,
10053 Make_Function_Call
(Loc
,
10054 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10055 Parameter_Associations
=> New_List
(
10057 Make_Attribute_Reference
(Loc
,
10059 Attribute_Name
=> Name_Tag
),
10061 Make_Function_Call
(Loc
,
10062 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10064 Parameter_Associations
=> New_List
(
10068 Make_Attribute_Reference
(Loc
,
10070 Attribute_Name
=> Name_Tag
),
10074 Make_Attribute_Reference
(Loc
,
10075 Prefix
=> New_Occurrence_Of
(Etype
(Concval
), Loc
),
10076 Attribute_Name
=> Name_Tag
),
10080 Make_Integer_Literal
(Loc
,
10081 DT_Position
(Entity
(Ename
))))))));
10084 -- Specific actuals for protected to XXX requeue
10086 if Is_Protected_Type
(Old_Typ
) then
10087 Prepend_To
(Params
,
10088 Make_Attribute_Reference
(Loc
, -- _object'Address
10090 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10091 Attribute_Name
=> Name_Address
));
10093 Prepend_To
(Params
, -- True
10094 New_Occurrence_Of
(Standard_True
, Loc
));
10096 -- Specific actuals for task to XXX requeue
10099 pragma Assert
(Is_Task_Type
(Old_Typ
));
10101 Prepend_To
(Params
, -- null
10102 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
10104 Prepend_To
(Params
, -- False
10105 New_Occurrence_Of
(Standard_False
, Loc
));
10108 -- Add the object parameter
10110 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
10113 -- _Disp_Requeue (<Params>);
10115 -- Find entity for Disp_Requeue operation, which belongs to
10116 -- the type and may not be directly visible.
10121 pragma Warnings
(Off
, Op
);
10124 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
10125 while Present
(Elmt
) loop
10127 exit when Chars
(Op
) = Name_uDisp_Requeue
;
10132 Make_Procedure_Call_Statement
(Loc
,
10133 Name
=> New_Occurrence_Of
(Op
, Loc
),
10134 Parameter_Associations
=> Params
);
10136 end Build_Dispatching_Requeue
;
10138 --------------------------------------
10139 -- Build_Dispatching_Requeue_To_Any --
10140 --------------------------------------
10142 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
10143 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10144 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10145 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
10155 -- Dispatch table slot processing, generate:
10158 S
:= Build_S
(Loc
, Decls
);
10160 -- Call kind processing, generate:
10161 -- C : Ada.Tags.Prim_Op_Kind;
10163 C
:= Build_C
(Loc
, Decls
);
10166 -- S := Ada.Tags.Get_Offset_Index
10167 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10169 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10172 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10175 Make_Procedure_Call_Statement
(Loc
,
10177 New_Occurrence_Of
(
10178 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10179 Name_uDisp_Get_Prim_Op_Kind
),
10181 Parameter_Associations
=> New_List
(
10182 New_Copy_Tree
(Obj
),
10183 New_Occurrence_Of
(S
, Loc
),
10184 New_Occurrence_Of
(C
, Loc
))));
10188 -- if C = POK_Protected_Entry
10189 -- or else C = POK_Task_Entry
10192 Make_Implicit_If_Statement
(N
,
10198 New_Occurrence_Of
(C
, Loc
),
10200 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
10205 New_Occurrence_Of
(C
, Loc
),
10207 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
10209 -- Dispatching requeue equivalent
10211 Then_Statements
=> New_List
(
10212 Build_Dispatching_Requeue
,
10215 -- elsif C = POK_Protected_Procedure then
10217 Elsif_Parts
=> New_List
(
10218 Make_Elsif_Part
(Loc
,
10222 New_Occurrence_Of
(C
, Loc
),
10224 New_Occurrence_Of
(
10225 RTE
(RE_POK_Protected_Procedure
), Loc
)),
10227 -- Dispatching call equivalent
10229 Then_Statements
=> New_List
(
10230 Build_Dispatching_Call_Equivalent
))),
10233 -- raise Program_Error;
10236 Else_Statements
=> New_List
(
10237 Make_Raise_Program_Error
(Loc
,
10238 Reason
=> PE_Explicit_Raise
))));
10240 -- Wrap everything into a block
10243 Make_Block_Statement
(Loc
,
10244 Declarations
=> Decls
,
10245 Handled_Statement_Sequence
=>
10246 Make_Handled_Sequence_Of_Statements
(Loc
,
10247 Statements
=> Stmts
));
10248 end Build_Dispatching_Requeue_To_Any
;
10250 --------------------------
10251 -- Build_Normal_Requeue --
10252 --------------------------
10254 function Build_Normal_Requeue
return Node_Id
is
10255 Params
: constant List_Id
:= New_List
;
10260 -- Process the "with abort" parameter
10262 Prepend_To
(Params
,
10263 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10265 -- Add the index expression to the parameters. It is common among all
10268 Prepend_To
(Params
,
10269 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
10271 if Is_Protected_Type
(Old_Typ
) then
10273 Self_Param
: Node_Id
;
10277 Make_Attribute_Reference
(Loc
,
10279 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10281 Name_Unchecked_Access
);
10283 -- Protected to protected requeue
10285 if Is_Protected_Type
(Conc_Typ
) then
10287 New_Occurrence_Of
(
10288 RTE
(RE_Requeue_Protected_Entry
), Loc
);
10291 Make_Attribute_Reference
(Loc
,
10293 Concurrent_Ref
(Concval
),
10295 Name_Unchecked_Access
);
10297 -- Protected to task requeue
10299 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10301 New_Occurrence_Of
(
10302 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
10304 Param
:= Concurrent_Ref
(Concval
);
10307 Prepend_To
(Params
, Param
);
10308 Prepend_To
(Params
, Self_Param
);
10311 else pragma Assert
(Is_Task_Type
(Old_Typ
));
10313 -- Task to protected requeue
10315 if Is_Protected_Type
(Conc_Typ
) then
10317 New_Occurrence_Of
(
10318 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
10321 Make_Attribute_Reference
(Loc
,
10323 Concurrent_Ref
(Concval
),
10325 Name_Unchecked_Access
);
10327 -- Task to task requeue
10329 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10331 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
);
10333 Param
:= Concurrent_Ref
(Concval
);
10336 Prepend_To
(Params
, Param
);
10340 Make_Procedure_Call_Statement
(Loc
,
10342 Parameter_Associations
=> Params
);
10343 end Build_Normal_Requeue
;
10345 --------------------------
10346 -- Build_Skip_Statement --
10347 --------------------------
10349 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
10350 Skip_Stmt
: Node_Id
;
10353 -- Build a return statement to skip the rest of the entire body
10355 if Is_Protected_Type
(Old_Typ
) then
10356 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
10358 -- If the requeue is within a task, find the end label of the
10359 -- enclosing accept statement and create a goto statement to it.
10367 -- Climb the parent chain looking for the enclosing accept
10370 Acc
:= Parent
(Search
);
10371 while Present
(Acc
)
10372 and then Nkind
(Acc
) /= N_Accept_Statement
10374 Acc
:= Parent
(Acc
);
10377 -- The last statement is the second label used for completing
10378 -- the rendezvous the usual way. The label we are looking for
10379 -- is right before it.
10382 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
10384 pragma Assert
(Nkind
(Label
) = N_Label
);
10386 -- Generate a goto statement to skip the rest of the accept
10389 Make_Goto_Statement
(Loc
,
10391 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
10395 Set_Analyzed
(Skip_Stmt
);
10398 end Build_Skip_Statement
;
10400 -- Start of processing for Expand_N_Requeue_Statement
10403 -- Extract the components of the entry call
10405 Extract_Entry
(N
, Concval
, Ename
, Index
);
10406 Conc_Typ
:= Etype
(Concval
);
10408 -- If the prefix is an access to class-wide type, dereference to get
10409 -- object and entry type.
10411 if Is_Access_Type
(Conc_Typ
) then
10412 Conc_Typ
:= Designated_Type
(Conc_Typ
);
10414 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Concval
)));
10415 Analyze_And_Resolve
(Concval
, Conc_Typ
);
10418 -- Examine the scope stack in order to find nearest enclosing protected
10419 -- or task type. This will constitute our invocation source.
10421 Old_Typ
:= Current_Scope
;
10422 while Present
(Old_Typ
)
10423 and then not Is_Protected_Type
(Old_Typ
)
10424 and then not Is_Task_Type
(Old_Typ
)
10426 Old_Typ
:= Scope
(Old_Typ
);
10429 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10430 -- Concval.Ename where the type of Concval is class-wide concurrent
10433 if Ada_Version
>= Ada_2012
10434 and then Present
(Concval
)
10435 and then Is_Class_Wide_Type
(Conc_Typ
)
10436 and then Is_Concurrent_Interface
(Conc_Typ
)
10439 Has_Impl
: Boolean := False;
10440 Impl_Kind
: Name_Id
:= No_Name
;
10443 -- Check whether the Ename is flagged by pragma Implemented
10445 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
10447 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
10450 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10451 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10453 if Has_Impl
and then Impl_Kind
= Name_By_Entry
then
10454 Rewrite
(N
, Build_Dispatching_Requeue
);
10456 Insert_After
(N
, Build_Skip_Statement
(N
));
10458 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10459 -- a protected procedure. In this case the requeue is transformed
10460 -- into a dispatching call.
10463 and then Impl_Kind
= Name_By_Protected_Procedure
10465 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
10468 -- The procedure_or_entry_NAME's implementation kind is either
10469 -- By_Any, Optional, or pragma Implemented was not applied at all.
10470 -- In this case a runtime test determines whether Ename denotes an
10471 -- entry or a protected procedure and performs the appropriate
10475 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
10480 -- Processing for regular (nondispatching) requeues
10483 Rewrite
(N
, Build_Normal_Requeue
);
10485 Insert_After
(N
, Build_Skip_Statement
(N
));
10487 end Expand_N_Requeue_Statement
;
10489 -------------------------------
10490 -- Expand_N_Selective_Accept --
10491 -------------------------------
10493 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10494 Loc
: constant Source_Ptr
:= Sloc
(N
);
10495 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10497 -- Note: in the below declarations a lot of new lists are allocated
10498 -- unconditionally which may well not end up being used. That's not
10499 -- a good idea since it wastes space gratuitously ???
10501 Accept_Case
: List_Id
;
10502 Accept_List
: constant List_Id
:= New_List
;
10505 Alt_List
: constant List_Id
:= New_List
;
10506 Alt_Stats
: List_Id
;
10507 Ann
: Entity_Id
:= Empty
;
10509 Check_Guard
: Boolean := True;
10511 Decls
: constant List_Id
:= New_List
;
10512 Stats
: constant List_Id
:= New_List
;
10513 Body_List
: constant List_Id
:= New_List
;
10514 Trailing_List
: constant List_Id
:= New_List
;
10517 Else_Present
: Boolean := False;
10518 Terminate_Alt
: Node_Id
:= Empty
;
10519 Select_Mode
: Node_Id
;
10521 Delay_Case
: List_Id
;
10522 Delay_Count
: Integer := 0;
10523 Delay_Val
: Entity_Id
;
10524 Delay_Index
: Entity_Id
;
10525 Delay_Min
: Entity_Id
;
10526 Delay_Num
: Pos
:= 1;
10527 Delay_Alt_List
: List_Id
:= New_List
;
10528 Delay_List
: constant List_Id
:= New_List
;
10532 First_Delay
: Boolean := True;
10533 Guard_Open
: Entity_Id
;
10539 Num_Accept
: Nat
:= 0;
10541 Time_Type
: Entity_Id
;
10542 Select_Call
: Node_Id
;
10544 Qnam
: constant Entity_Id
:=
10545 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10547 Xnam
: constant Entity_Id
:=
10548 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10550 -----------------------
10551 -- Local subprograms --
10552 -----------------------
10554 function Accept_Or_Raise
return List_Id
;
10555 -- For the rare case where delay alternatives all have guards, and
10556 -- all of them are closed, it is still possible that there were open
10557 -- accept alternatives with no callers. We must reexamine the
10558 -- Accept_List, and execute a selective wait with no else if some
10559 -- accept is open. If none, we raise program_error.
10561 procedure Add_Accept
(Alt
: Node_Id
);
10562 -- Process a single accept statement in a select alternative. Build
10563 -- procedure for body of accept, and add entry to dispatch table with
10564 -- expression for guard, in preparation for call to run time select.
10566 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10567 -- Manufacture a label using Num as a serial number and declare it.
10568 -- The declaration is appended to Decls. The label marks the trailing
10569 -- statements of an accept or delay alternative.
10571 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10572 -- Build call to Selective_Wait runtime routine
10574 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10575 -- Add code to compare value of delay with previous values, and
10576 -- generate case entry for trailing statements.
10578 procedure Process_Accept_Alternative
10582 -- Add code to call corresponding procedure, and branch to
10583 -- trailing statements, if any.
10585 ---------------------
10586 -- Accept_Or_Raise --
10587 ---------------------
10589 function Accept_Or_Raise
return List_Id
is
10592 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10595 -- We generate the following:
10597 -- for J in q'range loop
10598 -- if q(J).S /=null_task_entry then
10599 -- selective_wait (simple_mode,...);
10605 -- if no rendez_vous then
10606 -- raise program_error;
10609 -- Note that the code needs to know that the selector name
10610 -- in an Accept_Alternative is named S.
10612 Cond
:= Make_Op_Ne
(Loc
,
10614 Make_Selected_Component
(Loc
,
10616 Make_Indexed_Component
(Loc
,
10617 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10618 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))),
10619 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10621 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Loc
));
10623 Stats
:= New_List
(
10624 Make_Implicit_Loop_Statement
(N
,
10625 Iteration_Scheme
=>
10626 Make_Iteration_Scheme
(Loc
,
10627 Loop_Parameter_Specification
=>
10628 Make_Loop_Parameter_Specification
(Loc
,
10629 Defining_Identifier
=> J
,
10630 Discrete_Subtype_Definition
=>
10631 Make_Attribute_Reference
(Loc
,
10632 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10633 Attribute_Name
=> Name_Range
,
10634 Expressions
=> New_List
(
10635 Make_Integer_Literal
(Loc
, 1))))),
10637 Statements
=> New_List
(
10638 Make_Implicit_If_Statement
(N
,
10640 Then_Statements
=> New_List
(
10642 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)),
10643 Make_Exit_Statement
(Loc
))))));
10646 Make_Raise_Program_Error
(Loc
,
10647 Condition
=> Make_Op_Eq
(Loc
,
10648 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
10650 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
10651 Reason
=> PE_All_Guards_Closed
));
10654 end Accept_Or_Raise
;
10660 procedure Add_Accept
(Alt
: Node_Id
) is
10661 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10662 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10663 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10664 Eent
: constant Entity_Id
:= Entity
(Ename
);
10665 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10669 Null_Body
: Node_Id
;
10670 PB_Ent
: Entity_Id
;
10671 Proc_Body
: Node_Id
;
10673 -- Start of processing for Add_Accept
10677 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10680 if Present
(Condition
(Alt
)) then
10682 Make_If_Expression
(Eloc
, New_List
(
10684 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10685 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10687 Expr
:= Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
));
10690 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10691 Null_Body
:= New_Occurrence_Of
(Standard_False
, Eloc
);
10693 -- Always add call to Abort_Undefer when generating code, since
10694 -- this is what the runtime expects (abort deferred in
10695 -- Selective_Wait). In CodePeer mode this only confuses the
10696 -- analysis with unknown calls, so don't do it.
10698 if not CodePeer_Mode
then
10699 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10701 (First
(Statements
(Handled_Statement_Sequence
10702 (Accept_Statement
(Alt
)))),
10708 Make_Defining_Identifier
(Eloc
,
10709 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10711 -- Link the acceptor to the original receiving entry
10713 Set_Ekind
(PB_Ent
, E_Procedure
);
10714 Set_Receiving_Entry
(PB_Ent
, Eent
);
10716 if Comes_From_Source
(Alt
) then
10717 Set_Debug_Info_Needed
(PB_Ent
);
10721 Make_Subprogram_Body
(Eloc
,
10723 Make_Procedure_Specification
(Eloc
,
10724 Defining_Unit_Name
=> PB_Ent
),
10725 Declarations
=> Declarations
(Acc_Stm
),
10726 Handled_Statement_Sequence
=>
10727 Build_Accept_Body
(Accept_Statement
(Alt
)));
10729 Reset_Scopes_To
(Proc_Body
, PB_Ent
);
10731 -- During the analysis of the body of the accept statement, any
10732 -- zero cost exception handler records were collected in the
10733 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10734 -- This is where we move them to where they belong, namely the
10735 -- newly created procedure.
10737 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10738 Append
(Proc_Body
, Body_List
);
10741 Null_Body
:= New_Occurrence_Of
(Standard_True
, Eloc
);
10743 -- if accept statement has declarations, insert above, given that
10744 -- we are not creating a body for the accept.
10746 if Present
(Declarations
(Acc_Stm
)) then
10747 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10751 Append_To
(Accept_List
,
10752 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10754 Num_Accept
:= Num_Accept
+ 1;
10757 ----------------------------
10758 -- Make_And_Declare_Label --
10759 ----------------------------
10761 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10765 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10767 Make_Label
(Loc
, Lab_Id
);
10770 Make_Implicit_Label_Declaration
(Loc
,
10771 Defining_Identifier
=>
10772 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10773 Label_Construct
=> Lab
));
10776 end Make_And_Declare_Label
;
10778 ----------------------
10779 -- Make_Select_Call --
10780 ----------------------
10782 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10783 Params
: constant List_Id
:= New_List
;
10787 Make_Attribute_Reference
(Loc
,
10788 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10789 Attribute_Name
=> Name_Unchecked_Access
));
10790 Append_To
(Params
, Select_Mode
);
10791 Append_To
(Params
, New_Occurrence_Of
(Ann
, Loc
));
10792 Append_To
(Params
, New_Occurrence_Of
(Xnam
, Loc
));
10795 Make_Procedure_Call_Statement
(Loc
,
10796 Name
=> New_Occurrence_Of
(RTE
(RE_Selective_Wait
), Loc
),
10797 Parameter_Associations
=> Params
);
10798 end Make_Select_Call
;
10800 --------------------------------
10801 -- Process_Accept_Alternative --
10802 --------------------------------
10804 procedure Process_Accept_Alternative
10809 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10810 Alt_Stats
: List_Id
;
10813 Adjust_Condition
(Condition
(Alt
));
10815 -- Accept with body
10817 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10820 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10823 (Defining_Unit_Name
(Specification
(Proc
)),
10826 -- Accept with no body (followed by trailing statements)
10829 Alt_Stats
:= Empty_List
;
10832 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
10834 -- After the call, if any, branch to trailing statements, if any.
10835 -- We create a label for each, as well as the corresponding label
10838 if not Is_Empty_List
(Statements
(Alt
)) then
10839 Lab
:= Make_And_Declare_Label
(Index
);
10840 Append
(Lab
, Trailing_List
);
10841 Append_List
(Statements
(Alt
), Trailing_List
);
10842 Append_To
(Trailing_List
,
10843 Make_Goto_Statement
(Loc
,
10844 Name
=> New_Copy
(Identifier
(End_Lab
))));
10850 Append_To
(Alt_Stats
,
10851 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
10853 Append_To
(Alt_List
,
10854 Make_Case_Statement_Alternative
(Loc
,
10855 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
10856 Statements
=> Alt_Stats
));
10857 end Process_Accept_Alternative
;
10859 -------------------------------
10860 -- Process_Delay_Alternative --
10861 -------------------------------
10863 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
10864 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
10866 Delay_Alt
: List_Id
;
10869 -- Deal with C/Fortran boolean as delay condition
10871 Adjust_Condition
(Condition
(Alt
));
10873 -- Determine the smallest specified delay
10875 -- for each delay alternative generate:
10877 -- if guard-expression then
10878 -- Delay_Val := delay-expression;
10879 -- Guard_Open := True;
10880 -- if Delay_Val < Delay_Min then
10881 -- Delay_Min := Delay_Val;
10882 -- Delay_Index := Index;
10886 -- The enclosing if-statement is omitted if there is no guard
10888 if Delay_Count
= 1 or else First_Delay
then
10889 First_Delay
:= False;
10891 Delay_Alt
:= New_List
(
10892 Make_Assignment_Statement
(Loc
,
10893 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10894 Expression
=> Expression
(Delay_Statement
(Alt
))));
10896 if Delay_Count
> 1 then
10897 Append_To
(Delay_Alt
,
10898 Make_Assignment_Statement
(Loc
,
10899 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10900 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
10904 Delay_Alt
:= New_List
(
10905 Make_Assignment_Statement
(Loc
,
10906 Name
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10907 Expression
=> Expression
(Delay_Statement
(Alt
))));
10909 if Time_Type
= Standard_Duration
then
10912 Left_Opnd
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10913 Right_Opnd
=> New_Occurrence_Of
(Delay_Min
, Loc
));
10916 -- The scope of the time type must define a comparison
10917 -- operator. The scope itself may not be visible, so we
10918 -- construct a node with entity information to insure that
10919 -- semantic analysis can find the proper operator.
10922 Make_Function_Call
(Loc
,
10923 Name
=> Make_Selected_Component
(Loc
,
10925 New_Occurrence_Of
(Scope
(Time_Type
), Loc
),
10927 Make_Operator_Symbol
(Loc
,
10928 Chars
=> Name_Op_Lt
,
10929 Strval
=> No_String
)),
10930 Parameter_Associations
=>
10932 New_Occurrence_Of
(Delay_Val
, Loc
),
10933 New_Occurrence_Of
(Delay_Min
, Loc
)));
10935 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
10938 Append_To
(Delay_Alt
,
10939 Make_Implicit_If_Statement
(N
,
10941 Then_Statements
=> New_List
(
10942 Make_Assignment_Statement
(Loc
,
10943 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10944 Expression
=> New_Occurrence_Of
(Delay_Val
, Loc
)),
10946 Make_Assignment_Statement
(Loc
,
10947 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10948 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
10951 if Check_Guard
then
10952 Append_To
(Delay_Alt
,
10953 Make_Assignment_Statement
(Loc
,
10954 Name
=> New_Occurrence_Of
(Guard_Open
, Loc
),
10955 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
10958 if Present
(Condition
(Alt
)) then
10959 Delay_Alt
:= New_List
(
10960 Make_Implicit_If_Statement
(N
,
10961 Condition
=> Condition
(Alt
),
10962 Then_Statements
=> Delay_Alt
));
10965 Append_List
(Delay_Alt
, Delay_List
);
10967 Ensure_Statement_Present
(Dloc
, Alt
);
10969 -- If the delay alternative has a statement part, add choice to the
10970 -- case statements for delays.
10972 if not Is_Empty_List
(Statements
(Alt
)) then
10974 if Delay_Count
= 1 then
10975 Append_List
(Statements
(Alt
), Delay_Alt_List
);
10978 Append_To
(Delay_Alt_List
,
10979 Make_Case_Statement_Alternative
(Loc
,
10980 Discrete_Choices
=> New_List
(
10981 Make_Integer_Literal
(Loc
, Index
)),
10982 Statements
=> Statements
(Alt
)));
10985 elsif Delay_Count
= 1 then
10987 -- If the single delay has no trailing statements, add a branch
10988 -- to the exit label to the selective wait.
10990 Delay_Alt_List
:= New_List
(
10991 Make_Goto_Statement
(Loc
,
10992 Name
=> New_Copy
(Identifier
(End_Lab
))));
10995 end Process_Delay_Alternative
;
10997 -- Start of processing for Expand_N_Selective_Accept
11000 Process_Statements_For_Controlled_Objects
(N
);
11002 -- First insert some declarations before the select. The first is:
11006 -- This variable holds the parameters passed to the accept body. This
11007 -- declaration has already been inserted by the time we get here by
11008 -- a call to Expand_Accept_Declarations made from the semantics when
11009 -- processing the first accept statement contained in the select. We
11010 -- can find this entity as Accept_Address (E), where E is any of the
11011 -- entries references by contained accept statements.
11013 -- The first step is to scan the list of Selective_Accept_Statements
11014 -- to find this entity, and also count the number of accepts, and
11015 -- determine if terminated, delay or else is present:
11019 Alt
:= First
(Alts
);
11020 while Present
(Alt
) loop
11021 Process_Statements_For_Controlled_Objects
(Alt
);
11023 if Nkind
(Alt
) = N_Accept_Alternative
then
11026 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11027 Delay_Count
:= Delay_Count
+ 1;
11029 -- If the delays are relative delays, the delay expressions have
11030 -- type Standard_Duration. Otherwise they must have some time type
11031 -- recognized by GNAT.
11033 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
11034 Time_Type
:= Standard_Duration
;
11036 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
11038 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
11039 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
11044 "& is not a time type (RM 9.6(6))",
11045 Expression
(Delay_Statement
(Alt
)), Time_Type
);
11046 Time_Type
:= Standard_Duration
;
11047 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
11051 if No
(Condition
(Alt
)) then
11053 -- This guard will always be open
11055 Check_Guard
:= False;
11058 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
11059 Adjust_Condition
(Condition
(Alt
));
11060 Terminate_Alt
:= Alt
;
11063 Num_Alts
:= Num_Alts
+ 1;
11067 Else_Present
:= Present
(Else_Statements
(N
));
11069 -- At the same time (see procedure Add_Accept) we build the accept list:
11071 -- Qnn : Accept_List (1 .. num-select) := (
11072 -- (null-body, entry-index),
11073 -- (null-body, entry-index),
11075 -- (null_body, entry-index));
11077 -- In the above declaration, null-body is True if the corresponding
11078 -- accept has no body, and false otherwise. The entry is either the
11079 -- entry index expression if there is no guard, or if a guard is
11080 -- present, then an if expression of the form:
11082 -- (if guard then entry-index else Null_Task_Entry)
11084 -- If a guard is statically known to be false, the entry can simply
11085 -- be omitted from the accept list.
11088 Make_Object_Declaration
(Loc
,
11089 Defining_Identifier
=> Qnam
,
11090 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11091 Aliased_Present
=> True,
11093 Make_Qualified_Expression
(Loc
,
11095 New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11097 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
11099 -- Then we declare the variable that holds the index for the accept
11100 -- that will be selected for service:
11102 -- Xnn : Select_Index;
11105 Make_Object_Declaration
(Loc
,
11106 Defining_Identifier
=> Xnam
,
11107 Object_Definition
=>
11108 New_Occurrence_Of
(RTE
(RE_Select_Index
), Loc
),
11110 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)));
11112 -- After this follow procedure declarations for each accept body
11114 -- procedure Pnn is
11119 -- where the ... are statements from the corresponding procedure body.
11120 -- No parameters are involved, since the parameters are passed via Ann
11121 -- and the parameter references have already been expanded to be direct
11122 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11123 -- any embedded tasking statements (which would normally be illegal in
11124 -- procedures), have been converted to calls to the tasking runtime so
11125 -- there is no problem in putting them into procedures.
11127 -- The original accept statement has been expanded into a block in
11128 -- the same fashion as for simple accepts (see Build_Accept_Body).
11130 -- Note: we don't really need to build these procedures for the case
11131 -- where no delay statement is present, but it is just as easy to
11132 -- build them unconditionally, and not significantly inefficient,
11133 -- since if they are short they will be inlined anyway.
11135 -- The procedure declarations have been assembled in Body_List
11137 -- If delays are present, we must compute the required delay.
11138 -- We first generate the declarations:
11140 -- Delay_Index : Boolean := 0;
11141 -- Delay_Min : Some_Time_Type.Time;
11142 -- Delay_Val : Some_Time_Type.Time;
11144 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11145 -- active delay that is actually chosen as the basis for the possible
11146 -- delay if an immediate rendez-vous is not possible.
11148 -- In the most common case there is a single delay statement, and this
11149 -- is handled specially.
11151 if Delay_Count
> 0 then
11153 -- Generate the required declarations
11156 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
11158 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
11160 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
11163 Make_Object_Declaration
(Loc
,
11164 Defining_Identifier
=> Delay_Val
,
11165 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
)));
11168 Make_Object_Declaration
(Loc
,
11169 Defining_Identifier
=> Delay_Index
,
11170 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11171 Expression
=> Make_Integer_Literal
(Loc
, 0)));
11174 Make_Object_Declaration
(Loc
,
11175 Defining_Identifier
=> Delay_Min
,
11176 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
),
11178 Unchecked_Convert_To
(Time_Type
,
11179 Make_Attribute_Reference
(Loc
,
11181 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
11182 Attribute_Name
=> Name_Last
))));
11184 -- Create Duration and Delay_Mode objects used for passing a delay
11187 D
:= Make_Temporary
(Loc
, 'D');
11188 M
:= Make_Temporary
(Loc
, 'M');
11194 -- Note that these values are defined in s-osprim.ads and must
11195 -- be kept in sync:
11197 -- Relative : constant := 0;
11198 -- Absolute_Calendar : constant := 1;
11199 -- Absolute_RT : constant := 2;
11201 if Time_Type
= Standard_Duration
then
11202 Discr
:= Make_Integer_Literal
(Loc
, 0);
11204 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11205 Discr
:= Make_Integer_Literal
(Loc
, 1);
11209 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11210 Discr
:= Make_Integer_Literal
(Loc
, 2);
11214 Make_Object_Declaration
(Loc
,
11215 Defining_Identifier
=> D
,
11216 Object_Definition
=>
11217 New_Occurrence_Of
(Standard_Duration
, Loc
)));
11220 Make_Object_Declaration
(Loc
,
11221 Defining_Identifier
=> M
,
11222 Object_Definition
=>
11223 New_Occurrence_Of
(Standard_Integer
, Loc
),
11224 Expression
=> Discr
));
11227 if Check_Guard
then
11229 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
11232 Make_Object_Declaration
(Loc
,
11233 Defining_Identifier
=> Guard_Open
,
11234 Object_Definition
=>
11235 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11237 New_Occurrence_Of
(Standard_False
, Loc
)));
11240 -- Delay_Count is zero, don't need M and D set (suppress warning)
11247 if Present
(Terminate_Alt
) then
11249 -- If the terminate alternative guard is False, use
11250 -- Simple_Mode; otherwise use Terminate_Mode.
11252 if Present
(Condition
(Terminate_Alt
)) then
11253 Select_Mode
:= Make_If_Expression
(Loc
,
11254 New_List
(Condition
(Terminate_Alt
),
11255 New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
),
11256 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)));
11258 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
);
11261 elsif Else_Present
or Delay_Count
> 0 then
11262 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Else_Mode
), Loc
);
11265 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
);
11268 Select_Call
:= Make_Select_Call
(Select_Mode
);
11269 Append
(Select_Call
, Stats
);
11271 -- Now generate code to act on the result. There is an entry
11272 -- in this case for each accept statement with a non-null body,
11273 -- followed by a branch to the statements that follow the Accept.
11274 -- In the absence of delay alternatives, we generate:
11277 -- when No_Rendezvous => -- omitted if simple mode
11292 -- Lab0: Else_Statements;
11295 -- Lab1: Trailing_Statements1;
11298 -- Lab2: Trailing_Statements2;
11303 -- Generate label for common exit
11305 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
11307 -- First entry is the default case, when no rendezvous is possible
11309 Choices
:= New_List
(New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
));
11311 if Else_Present
then
11313 -- If no rendezvous is possible, the else part is executed
11315 Lab
:= Make_And_Declare_Label
(0);
11316 Alt_Stats
:= New_List
(
11317 Make_Goto_Statement
(Loc
,
11318 Name
=> New_Copy
(Identifier
(Lab
))));
11320 Append
(Lab
, Trailing_List
);
11321 Append_List
(Else_Statements
(N
), Trailing_List
);
11322 Append_To
(Trailing_List
,
11323 Make_Goto_Statement
(Loc
,
11324 Name
=> New_Copy
(Identifier
(End_Lab
))));
11326 Alt_Stats
:= New_List
(
11327 Make_Goto_Statement
(Loc
,
11328 Name
=> New_Copy
(Identifier
(End_Lab
))));
11331 Append_To
(Alt_List
,
11332 Make_Case_Statement_Alternative
(Loc
,
11333 Discrete_Choices
=> Choices
,
11334 Statements
=> Alt_Stats
));
11336 -- We make use of the fact that Accept_Index is an integer type, and
11337 -- generate successive literals for entries for each accept. Only those
11338 -- for which there is a body or trailing statements get a case entry.
11340 Alt
:= First
(Select_Alternatives
(N
));
11341 Proc
:= First
(Body_List
);
11342 while Present
(Alt
) loop
11344 if Nkind
(Alt
) = N_Accept_Alternative
then
11345 Process_Accept_Alternative
(Alt
, Index
, Proc
);
11346 Index
:= Index
+ 1;
11349 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
11354 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11355 Process_Delay_Alternative
(Alt
, Delay_Num
);
11356 Delay_Num
:= Delay_Num
+ 1;
11362 -- An others choice is always added to the main case, as well
11363 -- as the delay case (to satisfy the compiler).
11365 Append_To
(Alt_List
,
11366 Make_Case_Statement_Alternative
(Loc
,
11367 Discrete_Choices
=>
11368 New_List
(Make_Others_Choice
(Loc
)),
11370 New_List
(Make_Goto_Statement
(Loc
,
11371 Name
=> New_Copy
(Identifier
(End_Lab
))))));
11373 Accept_Case
:= New_List
(
11374 Make_Case_Statement
(Loc
,
11375 Expression
=> New_Occurrence_Of
(Xnam
, Loc
),
11376 Alternatives
=> Alt_List
));
11378 Append_List
(Trailing_List
, Accept_Case
);
11379 Append_List
(Body_List
, Decls
);
11381 -- Construct case statement for trailing statements of delay
11382 -- alternatives, if there are several of them.
11384 if Delay_Count
> 1 then
11385 Append_To
(Delay_Alt_List
,
11386 Make_Case_Statement_Alternative
(Loc
,
11387 Discrete_Choices
=>
11388 New_List
(Make_Others_Choice
(Loc
)),
11390 New_List
(Make_Null_Statement
(Loc
))));
11392 Delay_Case
:= New_List
(
11393 Make_Case_Statement
(Loc
,
11394 Expression
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11395 Alternatives
=> Delay_Alt_List
));
11397 Delay_Case
:= Delay_Alt_List
;
11400 -- If there are no delay alternatives, we append the case statement
11401 -- to the statement list.
11403 if Delay_Count
= 0 then
11404 Append_List
(Accept_Case
, Stats
);
11406 -- Delay alternatives present
11409 -- If delay alternatives are present we generate:
11411 -- find minimum delay.
11412 -- DX := minimum delay;
11413 -- M := <delay mode>;
11414 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11417 -- if X = No_Rendezvous then
11418 -- case statement for delay statements.
11420 -- case statement for accept alternatives.
11431 -- The type of the delay expression is known to be legal
11433 if Time_Type
= Standard_Duration
then
11434 Conv
:= New_Occurrence_Of
(Delay_Min
, Loc
);
11436 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11437 Conv
:= Make_Function_Call
(Loc
,
11438 New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
11439 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11443 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11445 Conv
:= Make_Function_Call
(Loc
,
11446 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
11447 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11450 Stmt
:= Make_Assignment_Statement
(Loc
,
11451 Name
=> New_Occurrence_Of
(D
, Loc
),
11452 Expression
=> Conv
);
11454 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11456 Parms
:= Parameter_Associations
(Select_Call
);
11458 Parm
:= First
(Parms
);
11459 while Present
(Parm
) and then Parm
/= Select_Mode
loop
11463 pragma Assert
(Present
(Parm
));
11464 Rewrite
(Parm
, New_Occurrence_Of
(RTE
(RE_Delay_Mode
), Loc
));
11467 -- Prepare two new parameters of Duration and Delay_Mode type
11468 -- which represent the value and the mode of the minimum delay.
11471 Insert_After
(Parm
, New_Occurrence_Of
(M
, Loc
));
11472 Insert_After
(Parm
, New_Occurrence_Of
(D
, Loc
));
11474 -- Create a call to RTS
11476 Rewrite
(Select_Call
,
11477 Make_Procedure_Call_Statement
(Loc
,
11478 Name
=> New_Occurrence_Of
(RTE
(RE_Timed_Selective_Wait
), Loc
),
11479 Parameter_Associations
=> Parms
));
11481 -- This new call should follow the calculation of the minimum
11484 Insert_List_Before
(Select_Call
, Delay_List
);
11486 if Check_Guard
then
11488 Make_Implicit_If_Statement
(N
,
11489 Condition
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11490 Then_Statements
=> New_List
(
11491 New_Copy_Tree
(Stmt
),
11492 New_Copy_Tree
(Select_Call
)),
11493 Else_Statements
=> Accept_Or_Raise
);
11494 Rewrite
(Select_Call
, Stmt
);
11496 Insert_Before
(Select_Call
, Stmt
);
11500 Make_Implicit_If_Statement
(N
,
11501 Condition
=> Make_Op_Eq
(Loc
,
11502 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
11504 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
11506 Then_Statements
=> Delay_Case
,
11507 Else_Statements
=> Accept_Case
);
11509 Append
(Cases
, Stats
);
11513 Append
(End_Lab
, Stats
);
11515 -- Replace accept statement with appropriate block
11518 Make_Block_Statement
(Loc
,
11519 Declarations
=> Decls
,
11520 Handled_Statement_Sequence
=>
11521 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11524 -- Note: have to worry more about abort deferral in above code ???
11526 -- Final step is to unstack the Accept_Address entries for all accept
11527 -- statements appearing in accept alternatives in the select statement
11529 Alt
:= First
(Alts
);
11530 while Present
(Alt
) loop
11531 if Nkind
(Alt
) = N_Accept_Alternative
then
11532 Remove_Last_Elmt
(Accept_Address
11533 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11538 end Expand_N_Selective_Accept
;
11540 -------------------------------------------
11541 -- Expand_N_Single_Protected_Declaration --
11542 -------------------------------------------
11544 -- A single protected declaration should never be present after semantic
11545 -- analysis because it is transformed into a protected type declaration
11546 -- and an accompanying anonymous object. This routine ensures that the
11547 -- transformation takes place.
11549 procedure Expand_N_Single_Protected_Declaration
(N
: Node_Id
) is
11551 raise Program_Error
;
11552 end Expand_N_Single_Protected_Declaration
;
11554 --------------------------------------
11555 -- Expand_N_Single_Task_Declaration --
11556 --------------------------------------
11558 -- A single task declaration should never be present after semantic
11559 -- analysis because it is transformed into a task type declaration and
11560 -- an accompanying anonymous object. This routine ensures that the
11561 -- transformation takes place.
11563 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11565 raise Program_Error
;
11566 end Expand_N_Single_Task_Declaration
;
11568 ------------------------
11569 -- Expand_N_Task_Body --
11570 ------------------------
11572 -- Given a task body
11574 -- task body tname is
11580 -- This expansion routine converts it into a procedure and sets the
11581 -- elaboration flag for the procedure to true, to represent the fact
11582 -- that the task body is now elaborated:
11584 -- procedure tnameB (_Task : access tnameV) is
11585 -- discriminal : dtype renames _Task.discriminant;
11587 -- procedure _clean is
11589 -- Abort_Defer.all;
11591 -- Abort_Undefer.all;
11596 -- Abort_Undefer.all;
11598 -- System.Task_Stages.Complete_Activation;
11606 -- In addition, if the task body is an activator, then a call to activate
11607 -- tasks is added at the start of the statements, before the call to
11608 -- Complete_Activation, and if in addition the task is a master then it
11609 -- must be established as a master. These calls are inserted and analyzed
11610 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11613 -- There is one discriminal declaration line generated for each
11614 -- discriminant that is present to provide an easy reference point for
11615 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11617 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11618 -- task body procedures have a profile (Arg : System.Address). That is
11619 -- needed because GNARLI has to use the same access-to-subprogram type
11620 -- for all task types. We depend here on knowing that in GNAT, passing
11621 -- an address argument by value is identical to passing a record value
11622 -- by access (in either case a single pointer is passed), so even though
11623 -- this procedure has the wrong profile. In fact it's all OK, since the
11624 -- callings sequence is identical.
11626 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11627 Loc
: constant Source_Ptr
:= Sloc
(N
);
11628 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11632 Insert_Nod
: Node_Id
;
11633 -- Used to determine the proper location of wrapper body insertions
11636 -- if no task body procedure, means we had an error in configurable
11637 -- run-time mode, and there is no point in proceeding further.
11639 if No
(Task_Body_Procedure
(Ttyp
)) then
11643 -- Add renaming declarations for discriminals and a declaration for the
11644 -- entry family index (if applicable).
11646 Install_Private_Data_Declarations
11647 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11649 -- Add a call to Abort_Undefer at the very beginning of the task
11650 -- body since this body is called with abort still deferred.
11652 if Abort_Allowed
then
11653 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11655 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11659 -- The statement part has already been protected with an at_end and
11660 -- cleanup actions. The call to Complete_Activation must be placed
11661 -- at the head of the sequence of statements of that block. The
11662 -- declarations have been merged in this sequence of statements but
11663 -- the first real statement is accessible from the First_Real_Statement
11664 -- field (which was set for exactly this purpose).
11666 if Restricted_Profile
then
11667 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11669 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11673 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11677 Make_Subprogram_Body
(Loc
,
11678 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11679 Declarations
=> Declarations
(N
),
11680 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11681 Set_Is_Task_Body_Procedure
(New_N
);
11683 -- If the task contains generic instantiations, cleanup actions are
11684 -- delayed until after instantiation. Transfer the activation chain to
11685 -- the subprogram, to insure that the activation call is properly
11686 -- generated. It the task body contains inner tasks, indicate that the
11687 -- subprogram is a task master.
11689 if Delay_Cleanups
(Ttyp
) then
11690 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11691 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11694 Rewrite
(N
, New_N
);
11697 -- Set elaboration flag immediately after task body. If the body is a
11698 -- subunit, the flag is set in the declarative part containing the stub.
11700 if Nkind
(Parent
(N
)) /= N_Subunit
then
11702 Make_Assignment_Statement
(Loc
,
11704 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11705 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11708 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11709 -- the task body. At this point all wrapper specs have been created,
11710 -- frozen and included in the dispatch table for the task type.
11712 if Ada_Version
>= Ada_2005
then
11713 if Nkind
(Parent
(N
)) = N_Subunit
then
11714 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11719 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11721 end Expand_N_Task_Body
;
11723 ------------------------------------
11724 -- Expand_N_Task_Type_Declaration --
11725 ------------------------------------
11727 -- We have several things to do. First we must create a Boolean flag used
11728 -- to mark if the body is elaborated yet. This variable gets set to True
11729 -- when the body of the task is elaborated (we can't rely on the normal
11730 -- ABE mechanism for the task body, since we need to pass an access to
11731 -- this elaboration boolean to the runtime routines).
11733 -- taskE : aliased Boolean := False;
11735 -- Next a variable is declared to hold the task stack size (either the
11736 -- default : Unspecified_Size, or a value that is set by a pragma
11737 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11738 -- the variable is initialized with this value:
11740 -- taskZ : Size_Type := Unspecified_Size;
11742 -- taskZ : Size_Type := Size_Type (size_expression);
11744 -- Note: No variable is needed to hold the task relative deadline since
11745 -- its value would never be static because the parameter is of a private
11746 -- type (Ada.Real_Time.Time_Span).
11748 -- Next we create a corresponding record type declaration used to represent
11749 -- values of this task. The general form of this type declaration is
11751 -- type taskV (discriminants) is record
11752 -- _Task_Id : Task_Id;
11753 -- entry_family : array (bounds) of Void;
11754 -- _Priority : Integer := priority_expression;
11755 -- _Size : Size_Type := size_expression;
11756 -- _Secondary_Stack_Size : Size_Type := size_expression;
11757 -- _Task_Info : Task_Info_Type := task_info_expression;
11758 -- _CPU : Integer := cpu_range_expression;
11759 -- _Relative_Deadline : Time_Span := time_span_expression;
11760 -- _Domain : Dispatching_Domain := dd_expression;
11763 -- The discriminants are present only if the corresponding task type has
11764 -- discriminants, and they exactly mirror the task type discriminants.
11766 -- The Id field is always present. It contains the Task_Id value, as set by
11767 -- the call to Create_Task. Note that although the task is limited, the
11768 -- task value record type is not limited, so there is no problem in passing
11769 -- this field as an out parameter to Create_Task.
11771 -- One entry_family component is present for each entry family in the task
11772 -- definition. The bounds correspond to the bounds of the entry family
11773 -- (which may depend on discriminants). The element type is void, since we
11774 -- only need the bounds information for determining the entry index. Note
11775 -- that the use of an anonymous array would normally be illegal in this
11776 -- context, but this is a parser check, and the semantics is quite prepared
11777 -- to handle such a case.
11779 -- The _Size field is present only if a Storage_Size pragma appears in the
11780 -- task definition. The expression captures the argument that was present
11781 -- in the pragma, and is used to override the task stack size otherwise
11782 -- associated with the task type.
11784 -- The _Secondary_Stack_Size field is present only the task entity has a
11785 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11786 -- when the record init proc is built, to capture the expression of the
11787 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11788 -- be filled here since aspect evaluations are delayed till the freeze
11791 -- The _Priority field is present only if the task entity has a Priority or
11792 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11793 -- definition clause). It will be filled at the freeze point, when the
11794 -- record init proc is built, to capture the expression of the rep item
11795 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11796 -- here since aspect evaluations are delayed till the freeze point.
11798 -- The _Task_Info field is present only if a Task_Info pragma appears in
11799 -- the task definition. The expression captures the argument that was
11800 -- present in the pragma, and is used to provide the Task_Image parameter
11801 -- to the call to Create_Task.
11803 -- The _CPU field is present only if the task entity has a CPU rep item
11804 -- (pragma, aspect specification or attribute definition clause). It will
11805 -- be filled at the freeze point, when the record init proc is built, to
11806 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11807 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11808 -- are delayed till the freeze point.
11810 -- The _Relative_Deadline field is present only if a Relative_Deadline
11811 -- pragma appears in the task definition. The expression captures the
11812 -- argument that was present in the pragma, and is used to provide the
11813 -- Relative_Deadline parameter to the call to Create_Task.
11815 -- The _Domain field is present only if the task entity has a
11816 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11817 -- definition clause). It will be filled at the freeze point, when the
11818 -- record init proc is built, to capture the expression of the rep item
11819 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11820 -- here since aspect evaluations are delayed till the freeze point.
11822 -- When a task is declared, an instance of the task value record is
11823 -- created. The elaboration of this declaration creates the correct bounds
11824 -- for the entry families, and also evaluates the size, priority, and
11825 -- task_Info expressions if needed. The initialization routine for the task
11826 -- type itself then calls Create_Task with appropriate parameters to
11827 -- initialize the value of the Task_Id field.
11829 -- Note: the address of this record is passed as the "Discriminants"
11830 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11831 -- body procedure, it does not matter that it does not quite match the
11832 -- GNARLI model of what is being passed (the record contains more than just
11833 -- the discriminants, but the discriminants can be found from the record
11836 -- The Entity_Id for this created record type is placed in the
11837 -- Corresponding_Record_Type field of the associated task type entity.
11839 -- Next we create a procedure specification for the task body procedure:
11841 -- procedure taskB (_Task : access taskV);
11843 -- Note that this must come after the record type declaration, since
11844 -- the spec refers to this type. It turns out that the initialization
11845 -- procedure for the value type references the task body spec, but that's
11846 -- fine, since it won't be generated till the freeze point for the type,
11847 -- which is certainly after the task body spec declaration.
11849 -- Finally, we set the task index value field of the entry attribute in
11850 -- the case of a simple entry.
11852 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
11853 Loc
: constant Source_Ptr
:= Sloc
(N
);
11854 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
11855 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
11856 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
11857 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
11859 Body_Decl
: Node_Id
;
11861 Decl_Stack
: Node_Id
;
11863 Elab_Decl
: Node_Id
;
11864 Ent_Stack
: Entity_Id
;
11865 Proc_Spec
: Node_Id
;
11866 Rec_Decl
: Node_Id
;
11867 Rec_Ent
: Entity_Id
;
11868 Size_Decl
: Entity_Id
;
11869 Task_Size
: Node_Id
;
11871 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
11872 -- Searches the task definition T for the first occurrence of the pragma
11873 -- Relative Deadline. The caller has ensured that the pragma is present
11874 -- in the task definition. Note that this routine cannot be implemented
11875 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11876 -- not chained because their expansion into a procedure call statement
11877 -- would cause a break in the chain.
11879 ----------------------------------
11880 -- Get_Relative_Deadline_Pragma --
11881 ----------------------------------
11883 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
11887 N
:= First
(Visible_Declarations
(T
));
11888 while Present
(N
) loop
11889 if Nkind
(N
) = N_Pragma
11890 and then Pragma_Name
(N
) = Name_Relative_Deadline
11898 N
:= First
(Private_Declarations
(T
));
11899 while Present
(N
) loop
11900 if Nkind
(N
) = N_Pragma
11901 and then Pragma_Name
(N
) = Name_Relative_Deadline
11909 raise Program_Error
;
11910 end Get_Relative_Deadline_Pragma
;
11912 -- Start of processing for Expand_N_Task_Type_Declaration
11915 -- If already expanded, nothing to do
11917 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
11921 -- Here we will do the expansion
11923 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
11925 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
11926 Cdecls
:= Component_Items
(Component_List
11927 (Type_Definition
(Rec_Decl
)));
11929 Qualify_Entity_Names
(N
);
11931 -- First create the elaboration variable
11934 Make_Object_Declaration
(Loc
,
11935 Defining_Identifier
=>
11936 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11937 Chars
=> New_External_Name
(Tasknm
, 'E')),
11938 Aliased_Present
=> True,
11939 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
11940 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
11942 Insert_After
(N
, Elab_Decl
);
11944 -- Next create the declaration of the size variable (tasknmZ)
11946 Set_Storage_Size_Variable
(Tasktyp
,
11947 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11948 Chars
=> New_External_Name
(Tasknm
, 'Z')));
11950 if Present
(Taskdef
)
11951 and then Has_Storage_Size_Pragma
(Taskdef
)
11953 Is_OK_Static_Expression
11955 (First
(Pragma_Argument_Associations
11956 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
11959 Make_Object_Declaration
(Loc
,
11960 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11961 Object_Definition
=>
11962 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
11964 Convert_To
(RTE
(RE_Size_Type
),
11966 (Expression
(First
(Pragma_Argument_Associations
11968 (TaskId
, Name_Storage_Size
)))))));
11972 Make_Object_Declaration
(Loc
,
11973 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11974 Object_Definition
=>
11975 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
11977 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
11980 Insert_After
(Elab_Decl
, Size_Decl
);
11982 -- Next build the rest of the corresponding record declaration. This is
11983 -- done last, since the corresponding record initialization procedure
11984 -- will reference the previously created entities.
11986 -- Fill in the component declarations -- first the _Task_Id field
11989 Make_Component_Declaration
(Loc
,
11990 Defining_Identifier
=>
11991 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
11992 Component_Definition
=>
11993 Make_Component_Definition
(Loc
,
11994 Aliased_Present
=> False,
11995 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RO_ST_Task_Id
),
11998 -- Declare static ATCB (that is, created by the expander) if we are
11999 -- using the Restricted run time.
12001 if Restricted_Profile
then
12003 Make_Component_Declaration
(Loc
,
12004 Defining_Identifier
=>
12005 Make_Defining_Identifier
(Loc
, Name_uATCB
),
12007 Component_Definition
=>
12008 Make_Component_Definition
(Loc
,
12009 Aliased_Present
=> True,
12010 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12012 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
12015 Make_Index_Or_Discriminant_Constraint
(Loc
,
12017 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
12021 -- Declare static stack (that is, created by the expander) if we are
12022 -- using the Restricted run time on a bare board configuration.
12024 if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
12026 -- First we need to extract the appropriate stack size
12028 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
12030 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12032 Expr_N
: constant Node_Id
:=
12033 Expression
(First
(
12034 Pragma_Argument_Associations
(
12035 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
12036 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
12037 P
: constant Node_Id
:= Parent
(Expr_N
);
12040 -- The stack is defined inside the corresponding record.
12041 -- Therefore if the size of the stack is set by means of
12042 -- a discriminant, we must reference the discriminant of the
12043 -- corresponding record type.
12045 if Nkind
(Expr_N
) in N_Has_Entity
12046 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
12050 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
12052 Set_Parent
(Task_Size
, P
);
12053 Set_Etype
(Task_Size
, Etyp
);
12054 Set_Analyzed
(Task_Size
);
12057 Task_Size
:= New_Copy_Tree
(Expr_N
);
12063 New_Occurrence_Of
(RTE
(RE_Default_Stack_Size
), Loc
);
12066 Decl_Stack
:= Make_Component_Declaration
(Loc
,
12067 Defining_Identifier
=> Ent_Stack
,
12069 Component_Definition
=>
12070 Make_Component_Definition
(Loc
,
12071 Aliased_Present
=> True,
12072 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12074 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
12077 Make_Index_Or_Discriminant_Constraint
(Loc
,
12078 Constraints
=> New_List
(Make_Range
(Loc
,
12079 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
12080 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
12083 Append_To
(Cdecls
, Decl_Stack
);
12085 -- The appropriate alignment for the stack is ensured by the run-time
12086 -- code in charge of task creation.
12090 -- Declare a static secondary stack if the conditions for a statically
12091 -- generated stack are met.
12093 if Create_Secondary_Stack_For_Task
(TaskId
) then
12095 Size_Expr
: constant Node_Id
:=
12096 Expression
(First
(
12097 Pragma_Argument_Associations
(
12098 Get_Rep_Pragma
(TaskId
,
12099 Name_Secondary_Stack_Size
))));
12101 Stack_Size
: Node_Id
;
12104 -- The secondary stack is defined inside the corresponding
12105 -- record. Therefore if the size of the stack is set by means
12106 -- of a discriminant, we must reference the discriminant of the
12107 -- corresponding record type.
12109 if Nkind
(Size_Expr
) in N_Has_Entity
12110 and then Present
(Discriminal_Link
(Entity
(Size_Expr
)))
12114 (CR_Discriminant
(Discriminal_Link
(Entity
(Size_Expr
))),
12116 Set_Parent
(Stack_Size
, Parent
(Size_Expr
));
12117 Set_Etype
(Stack_Size
, Etype
(Size_Expr
));
12118 Set_Analyzed
(Stack_Size
);
12121 Stack_Size
:= New_Copy_Tree
(Size_Expr
);
12124 -- Create the secondary stack for the task
12127 Make_Component_Declaration
(Loc
,
12128 Defining_Identifier
=>
12129 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack
),
12130 Component_Definition
=>
12131 Make_Component_Definition
(Loc
,
12132 Aliased_Present
=> True,
12133 Subtype_Indication
=>
12134 Make_Subtype_Indication
(Loc
,
12136 New_Occurrence_Of
(RTE
(RE_SS_Stack
), Loc
),
12138 Make_Index_Or_Discriminant_Constraint
(Loc
,
12139 Constraints
=> New_List
(
12140 Convert_To
(RTE
(RE_Size_Type
),
12143 Append_To
(Cdecls
, Decl_SS
);
12147 -- Add components for entry families
12149 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
12151 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12152 -- item is present.
12154 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
12156 Make_Component_Declaration
(Loc
,
12157 Defining_Identifier
=>
12158 Make_Defining_Identifier
(Loc
, Name_uPriority
),
12159 Component_Definition
=>
12160 Make_Component_Definition
(Loc
,
12161 Aliased_Present
=> False,
12162 Subtype_Indication
=>
12163 New_Occurrence_Of
(Standard_Integer
, Loc
))));
12166 -- Add the _Size component if a Storage_Size pragma is present
12168 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12170 Make_Component_Declaration
(Loc
,
12171 Defining_Identifier
=>
12172 Make_Defining_Identifier
(Loc
, Name_uSize
),
12174 Component_Definition
=>
12175 Make_Component_Definition
(Loc
,
12176 Aliased_Present
=> False,
12177 Subtype_Indication
=>
12178 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
)),
12181 Convert_To
(RTE
(RE_Size_Type
),
12183 Expression
(First
(
12184 Pragma_Argument_Associations
(
12185 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
12188 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
12189 -- pragma is present.
12192 (TaskId
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
12195 Make_Component_Declaration
(Loc
,
12196 Defining_Identifier
=>
12197 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack_Size
),
12199 Component_Definition
=>
12200 Make_Component_Definition
(Loc
,
12201 Aliased_Present
=> False,
12202 Subtype_Indication
=>
12203 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
))));
12206 -- Add the _Task_Info component if a Task_Info pragma is present
12208 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
12210 Make_Component_Declaration
(Loc
,
12211 Defining_Identifier
=>
12212 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
12214 Component_Definition
=>
12215 Make_Component_Definition
(Loc
,
12216 Aliased_Present
=> False,
12217 Subtype_Indication
=>
12218 New_Occurrence_Of
(RTE
(RE_Task_Info_Type
), Loc
)),
12220 Expression
=> New_Copy
(
12221 Expression
(First
(
12222 Pragma_Argument_Associations
(
12224 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
12227 -- Add the _CPU component if a CPU rep item is present
12229 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
12231 Make_Component_Declaration
(Loc
,
12232 Defining_Identifier
=>
12233 Make_Defining_Identifier
(Loc
, Name_uCPU
),
12235 Component_Definition
=>
12236 Make_Component_Definition
(Loc
,
12237 Aliased_Present
=> False,
12238 Subtype_Indication
=>
12239 New_Occurrence_Of
(RTE
(RE_CPU_Range
), Loc
))));
12242 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12243 -- present. If we are using a restricted run time this component will
12244 -- not be added (deadlines are not allowed by the Ravenscar profile),
12245 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
12248 if (not Restricted_Profile
or else Task_Dispatching_Policy
= 'E')
12249 and then Present
(Taskdef
)
12250 and then Has_Relative_Deadline_Pragma
(Taskdef
)
12253 Make_Component_Declaration
(Loc
,
12254 Defining_Identifier
=>
12255 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
12257 Component_Definition
=>
12258 Make_Component_Definition
(Loc
,
12259 Aliased_Present
=> False,
12260 Subtype_Indication
=>
12261 New_Occurrence_Of
(RTE
(RE_Time_Span
), Loc
)),
12264 Convert_To
(RTE
(RE_Time_Span
),
12266 Expression
(First
(
12267 Pragma_Argument_Associations
(
12268 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
12271 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12272 -- item is present. If we are using a restricted run time this component
12273 -- will not be added (dispatching domains are not allowed by the
12274 -- Ravenscar profile).
12276 if not Restricted_Profile
12279 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
12282 Make_Component_Declaration
(Loc
,
12283 Defining_Identifier
=>
12284 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
12286 Component_Definition
=>
12287 Make_Component_Definition
(Loc
,
12288 Aliased_Present
=> False,
12289 Subtype_Indication
=>
12291 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
12294 Insert_After
(Size_Decl
, Rec_Decl
);
12296 -- Analyze the record declaration immediately after construction,
12297 -- because the initialization procedure is needed for single task
12298 -- declarations before the next entity is analyzed.
12300 Analyze
(Rec_Decl
);
12302 -- Create the declaration of the task body procedure
12304 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
12306 Make_Subprogram_Declaration
(Loc
,
12307 Specification
=> Proc_Spec
);
12308 Set_Is_Task_Body_Procedure
(Body_Decl
);
12310 Insert_After
(Rec_Decl
, Body_Decl
);
12312 -- The subprogram does not comes from source, so we have to indicate the
12313 -- need for debugging information explicitly.
12315 if Comes_From_Source
(Original_Node
(N
)) then
12316 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
12319 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12320 -- the corresponding record has been frozen.
12322 if Ada_Version
>= Ada_2005
then
12323 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
12326 -- Ada 2005 (AI-345): We must defer freezing to allow further
12327 -- declaration of primitive subprograms covering task interfaces
12329 if Ada_Version
<= Ada_95
then
12331 -- Now we can freeze the corresponding record. This needs manually
12332 -- freezing, since it is really part of the task type, and the task
12333 -- type is frozen at this stage. We of course need the initialization
12334 -- procedure for this corresponding record type and we won't get it
12335 -- in time if we don't freeze now.
12338 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
12340 if Is_Non_Empty_List
(L
) then
12341 Insert_List_After
(Body_Decl
, L
);
12346 -- Complete the expansion of access types to the current task type, if
12347 -- any were declared.
12349 Expand_Previous_Access_Type
(Tasktyp
);
12351 -- Create wrappers for entries that have contract cases, preconditions
12352 -- and postconditions.
12358 Ent
:= First_Entity
(Tasktyp
);
12359 while Present
(Ent
) loop
12360 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
) then
12361 Build_Contract_Wrapper
(Ent
, N
);
12367 end Expand_N_Task_Type_Declaration
;
12369 -------------------------------
12370 -- Expand_N_Timed_Entry_Call --
12371 -------------------------------
12373 -- A timed entry call in normal case is not implemented using ATC mechanism
12374 -- anymore for efficiency reason.
12384 -- is expanded as follows:
12386 -- 1) When T.E is a task entry_call;
12390 -- X : Task_Entry_Index := <entry index>;
12391 -- DX : Duration := To_Duration (D);
12392 -- M : Delay_Mode := <discriminant>;
12393 -- P : parms := (parm, parm, parm);
12396 -- Timed_Protected_Entry_Call
12397 -- (<acceptor-task>, X, P'Address, DX, M, B);
12405 -- 2) When T.E is a protected entry_call;
12409 -- X : Protected_Entry_Index := <entry index>;
12410 -- DX : Duration := To_Duration (D);
12411 -- M : Delay_Mode := <discriminant>;
12412 -- P : parms := (parm, parm, parm);
12415 -- Timed_Protected_Entry_Call
12416 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12424 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12425 -- is no delay and the triggering statements are executed. We first
12426 -- determine the kind of the triggering call and then execute a
12427 -- synchronized operation or a direct call.
12430 -- B : Boolean := False;
12431 -- C : Ada.Tags.Prim_Op_Kind;
12432 -- DX : Duration := To_Duration (D)
12433 -- K : Ada.Tags.Tagged_Kind :=
12434 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12435 -- M : Integer :=...;
12436 -- P : Parameters := (Param1 .. ParamN);
12440 -- if K = Ada.Tags.TK_Limited_Tagged
12441 -- or else K = Ada.Tags.TK_Tagged
12443 -- <dispatching-call>;
12448 -- Ada.Tags.Get_Offset_Index
12449 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12451 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12453 -- if C = POK_Protected_Entry
12454 -- or else C = POK_Task_Entry
12456 -- Param1 := P.Param1;
12458 -- ParamN := P.ParamN;
12462 -- if C = POK_Procedure
12463 -- or else C = POK_Protected_Procedure
12464 -- or else C = POK_Task_Procedure
12466 -- <dispatching-call>;
12472 -- <triggering-statements>
12474 -- <timed-statements>
12478 -- The triggering statement and the sequence of timed statements have not
12479 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12480 -- global references if within an instantiation.
12482 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
12483 Loc
: constant Source_Ptr
:= Sloc
(N
);
12486 Blk_Typ
: Entity_Id
;
12488 Call_Ent
: Entity_Id
;
12489 Conc_Typ_Stmts
: List_Id
;
12490 Concval
: Node_Id
:= Empty
; -- init to avoid warning
12491 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
12494 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
12496 D_Type
: Entity_Id
;
12499 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
12500 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
12505 Is_Disp_Select
: Boolean;
12506 Lim_Typ_Stmts
: List_Id
;
12515 B
: Entity_Id
; -- Call status flag
12516 C
: Entity_Id
; -- Call kind
12517 D
: Entity_Id
; -- Delay
12518 K
: Entity_Id
; -- Tagged kind
12519 M
: Entity_Id
; -- Delay mode
12520 P
: Entity_Id
; -- Parameter block
12521 S
: Entity_Id
; -- Primitive operation slot
12523 -- Start of processing for Expand_N_Timed_Entry_Call
12526 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12527 -- was already reported on spec, so do not attempt to expand the call.
12529 if Restriction_Active
(No_Select_Statements
) then
12533 Process_Statements_For_Controlled_Objects
(E_Alt
);
12534 Process_Statements_For_Controlled_Objects
(D_Alt
);
12536 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
12538 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12539 -- may wrap them in blocks.
12541 E_Stats
:= Statements
(E_Alt
);
12542 D_Stats
:= Statements
(D_Alt
);
12544 -- The arguments in the call may require dynamic allocation, and the
12545 -- call statement may have been transformed into a block. The block
12546 -- may contain additional declarations for internal entities, and the
12547 -- original call is found by sequential search.
12549 if Nkind
(E_Call
) = N_Block_Statement
then
12550 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
12551 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
12552 N_Entry_Call_Statement
)
12559 Ada_Version
>= Ada_2005
12560 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
12562 if Is_Disp_Select
then
12563 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
12569 -- B : Boolean := False;
12571 B
:= Build_B
(Loc
, Decls
);
12574 -- C : Ada.Tags.Prim_Op_Kind;
12576 C
:= Build_C
(Loc
, Decls
);
12578 -- Because the analysis of all statements was disabled, manually
12579 -- analyze the delay statement.
12582 D_Stat
:= Original_Node
(D_Stat
);
12585 -- Build an entry call using Simple_Entry_Call
12587 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
12588 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
12590 Decls
:= Declarations
(E_Call
);
12591 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
12600 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12603 Make_Object_Declaration
(Loc
,
12604 Defining_Identifier
=> B
,
12605 Object_Definition
=>
12606 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
12609 -- Duration and mode processing
12611 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12613 -- Use the type of the delay expression (Calendar or Real_Time) to
12614 -- generate the appropriate conversion.
12616 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12617 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12618 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12620 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12621 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12623 Make_Function_Call
(Loc
,
12624 Name
=> New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
12625 Parameter_Associations
=>
12626 New_List
(New_Copy
(Expression
(D_Stat
))));
12628 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12629 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12631 Make_Function_Call
(Loc
,
12632 Name
=> New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
12633 Parameter_Associations
=>
12634 New_List
(New_Copy
(Expression
(D_Stat
))));
12637 D
:= Make_Temporary
(Loc
, 'D');
12643 Make_Object_Declaration
(Loc
,
12644 Defining_Identifier
=> D
,
12645 Object_Definition
=> New_Occurrence_Of
(Standard_Duration
, Loc
)));
12647 M
:= Make_Temporary
(Loc
, 'M');
12650 -- M : Integer := (0 | 1 | 2);
12653 Make_Object_Declaration
(Loc
,
12654 Defining_Identifier
=> M
,
12655 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
12656 Expression
=> D_Disc
));
12658 -- Do the assignment at this stage only because the evaluation of the
12659 -- expression must not occur earlier (see ACVC C97302A).
12662 Make_Assignment_Statement
(Loc
,
12663 Name
=> New_Occurrence_Of
(D
, Loc
),
12664 Expression
=> D_Conv
));
12666 -- Parameter block processing
12668 -- Manually create the parameter block for dispatching calls. In the
12669 -- case of entries, the block has already been created during the call
12670 -- to Build_Simple_Entry_Call.
12672 if Is_Disp_Select
then
12674 -- Tagged kind processing, generate:
12675 -- K : Ada.Tags.Tagged_Kind :=
12676 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12678 K
:= Build_K
(Loc
, Decls
, Obj
);
12680 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12682 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12684 -- Dispatch table slot processing, generate:
12687 S
:= Build_S
(Loc
, Decls
);
12690 -- S := Ada.Tags.Get_Offset_Index
12691 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12694 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12697 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12699 -- where Obj is the controlling formal parameter, S is the dispatch
12700 -- table slot number of the dispatching operation, P is the wrapped
12701 -- parameter block, D is the duration, M is the duration mode, C is
12702 -- the call kind and B is the call status.
12704 Params
:= New_List
;
12706 Append_To
(Params
, New_Copy_Tree
(Obj
));
12707 Append_To
(Params
, New_Occurrence_Of
(S
, Loc
));
12709 Make_Attribute_Reference
(Loc
,
12710 Prefix
=> New_Occurrence_Of
(P
, Loc
),
12711 Attribute_Name
=> Name_Address
));
12712 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12713 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12714 Append_To
(Params
, New_Occurrence_Of
(C
, Loc
));
12715 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12717 Append_To
(Conc_Typ_Stmts
,
12718 Make_Procedure_Call_Statement
(Loc
,
12722 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12723 Parameter_Associations
=> Params
));
12726 -- if C = POK_Protected_Entry
12727 -- or else C = POK_Task_Entry
12729 -- Param1 := P.Param1;
12731 -- ParamN := P.ParamN;
12734 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12736 -- Generate the if statement only when the packed parameters need
12737 -- explicit assignments to their corresponding actuals.
12739 if Present
(Unpack
) then
12740 Append_To
(Conc_Typ_Stmts
,
12741 Make_Implicit_If_Statement
(N
,
12747 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12750 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12754 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12756 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
12758 Then_Statements
=> Unpack
));
12764 -- if C = POK_Procedure
12765 -- or else C = POK_Protected_Procedure
12766 -- or else C = POK_Task_Procedure
12768 -- <dispatching-call>
12772 N_Stats
:= New_List
(
12773 Make_Implicit_If_Statement
(N
,
12778 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12780 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
12786 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12788 New_Occurrence_Of
(RTE
(
12789 RE_POK_Protected_Procedure
), Loc
)),
12792 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12795 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12797 Then_Statements
=> New_List
(E_Call
)));
12799 Append_To
(Conc_Typ_Stmts
,
12800 Make_Implicit_If_Statement
(N
,
12801 Condition
=> New_Occurrence_Of
(B
, Loc
),
12802 Then_Statements
=> N_Stats
));
12805 -- <dispatching-call>;
12809 New_List
(New_Copy_Tree
(E_Call
),
12810 Make_Assignment_Statement
(Loc
,
12811 Name
=> New_Occurrence_Of
(B
, Loc
),
12812 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12815 -- if K = Ada.Tags.TK_Limited_Tagged
12816 -- or else K = Ada.Tags.TK_Tagged
12824 Make_Implicit_If_Statement
(N
,
12825 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
12826 Then_Statements
=> Lim_Typ_Stmts
,
12827 Else_Statements
=> Conc_Typ_Stmts
));
12832 -- <triggering-statements>
12834 -- <timed-statements>
12838 Make_Implicit_If_Statement
(N
,
12839 Condition
=> New_Occurrence_Of
(B
, Loc
),
12840 Then_Statements
=> E_Stats
,
12841 Else_Statements
=> D_Stats
));
12844 -- Simple case of a nondispatching trigger. Skip assignments to
12845 -- temporaries created for in-out parameters.
12847 -- This makes unwarranted assumptions about the shape of the expanded
12848 -- tree for the call, and should be cleaned up ???
12850 Stmt
:= First
(Stmts
);
12851 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
12855 -- Do the assignment at this stage only because the evaluation
12856 -- of the expression must not occur earlier (see ACVC C97302A).
12858 Insert_Before
(Stmt
,
12859 Make_Assignment_Statement
(Loc
,
12860 Name
=> New_Occurrence_Of
(D
, Loc
),
12861 Expression
=> D_Conv
));
12864 Params
:= Parameter_Associations
(Call
);
12866 -- For a protected type, we build a Timed_Protected_Entry_Call
12868 if Is_Protected_Type
(Etype
(Concval
)) then
12870 -- Create a new call statement
12872 Param
:= First
(Params
);
12873 while Present
(Param
)
12874 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
12879 Dummy
:= Remove_Next
(Next
(Param
));
12881 -- Remove garbage is following the Cancel_Param if present
12883 Dummy
:= Next
(Param
);
12885 -- Remove the mode of the Protected_Entry_Call call, then remove
12886 -- the Communication_Block of the Protected_Entry_Call call, and
12887 -- finally add Duration and a Delay_Mode parameter
12889 pragma Assert
(Present
(Param
));
12890 Rewrite
(Param
, New_Occurrence_Of
(D
, Loc
));
12892 Rewrite
(Dummy
, New_Occurrence_Of
(M
, Loc
));
12894 -- Add a Boolean flag for successful entry call
12896 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12898 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
12899 when System_Tasking_Protected_Objects_Entries
=>
12901 Make_Procedure_Call_Statement
(Loc
,
12904 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
12905 Parameter_Associations
=> Params
));
12908 raise Program_Error
;
12911 -- For the task case, build a Timed_Task_Entry_Call
12914 -- Create a new call statement
12916 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12917 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12918 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12921 Make_Procedure_Call_Statement
(Loc
,
12923 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
12924 Parameter_Associations
=> Params
));
12928 Make_Implicit_If_Statement
(N
,
12929 Condition
=> New_Occurrence_Of
(B
, Loc
),
12930 Then_Statements
=> E_Stats
,
12931 Else_Statements
=> D_Stats
));
12935 Make_Block_Statement
(Loc
,
12936 Declarations
=> Decls
,
12937 Handled_Statement_Sequence
=>
12938 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
12942 -- Some items in Decls used to be in the N_Block in E_Call that
12943 -- is constructed in Expand_Entry_Call, and are now in the new
12944 -- Block into which N has been rewritten. Adjust their scopes
12945 -- to reflect that.
12947 if Nkind
(E_Call
) = N_Block_Statement
then
12948 Obj
:= First_Entity
(Entity
(Identifier
(E_Call
)));
12949 while Present
(Obj
) loop
12950 Set_Scope
(Obj
, Entity
(Identifier
(N
)));
12955 Reset_Scopes_To
(N
, Entity
(Identifier
(N
)));
12956 end Expand_N_Timed_Entry_Call
;
12958 ----------------------------------------
12959 -- Expand_Protected_Body_Declarations --
12960 ----------------------------------------
12962 procedure Expand_Protected_Body_Declarations
12964 Spec_Id
: Entity_Id
)
12967 if No_Run_Time_Mode
then
12968 Error_Msg_CRT
("protected body", N
);
12971 elsif Expander_Active
then
12973 -- Associate discriminals with the first subprogram or entry body to
12976 if Present
(First_Protected_Operation
(Declarations
(N
))) then
12977 Set_Discriminals
(Parent
(Spec_Id
));
12980 end Expand_Protected_Body_Declarations
;
12982 -------------------------
12983 -- External_Subprogram --
12984 -------------------------
12986 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
12987 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
12990 -- The internal and external subprograms follow each other on the entity
12991 -- chain. Note that previously private operations had no separate
12992 -- external subprogram. We now create one in all cases, because a
12993 -- private operation may actually appear in an external call, through
12994 -- a 'Access reference used for a callback.
12996 -- If the operation is a function that returns an anonymous access type,
12997 -- the corresponding itype appears before the operation, and must be
13000 -- This mechanism is fragile, there should be a real link between the
13001 -- two versions of the operation, but there is no place to put it ???
13003 if Is_Access_Type
(Next_Entity
(Subp
)) then
13004 return Next_Entity
(Next_Entity
(Subp
));
13006 return Next_Entity
(Subp
);
13008 end External_Subprogram
;
13010 ------------------------------
13011 -- Extract_Dispatching_Call --
13012 ------------------------------
13014 procedure Extract_Dispatching_Call
13016 Call_Ent
: out Entity_Id
;
13017 Object
: out Entity_Id
;
13018 Actuals
: out List_Id
;
13019 Formals
: out List_Id
)
13021 Call_Nam
: Node_Id
;
13024 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
13026 if Present
(Original_Node
(N
)) then
13027 Call_Nam
:= Name
(Original_Node
(N
));
13029 Call_Nam
:= Name
(N
);
13032 -- Retrieve the name of the dispatching procedure. It contains the
13033 -- dispatch table slot number.
13036 case Nkind
(Call_Nam
) is
13037 when N_Identifier
=>
13040 when N_Selected_Component
=>
13041 Call_Nam
:= Selector_Name
(Call_Nam
);
13044 raise Program_Error
;
13048 Actuals
:= Parameter_Associations
(N
);
13049 Call_Ent
:= Entity
(Call_Nam
);
13050 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
13051 Object
:= First
(Actuals
);
13053 if Present
(Original_Node
(Object
)) then
13054 Object
:= Original_Node
(Object
);
13057 -- If the type of the dispatching object is an access type then return
13058 -- an explicit dereference of a copy of the object, and note that this
13059 -- is the controlling actual of the call.
13061 if Is_Access_Type
(Etype
(Object
)) then
13063 Make_Explicit_Dereference
(Sloc
(N
), New_Copy_Tree
(Object
));
13065 Set_Is_Controlling_Actual
(Object
);
13067 end Extract_Dispatching_Call
;
13069 -------------------
13070 -- Extract_Entry --
13071 -------------------
13073 procedure Extract_Entry
13075 Concval
: out Node_Id
;
13076 Ename
: out Node_Id
;
13077 Index
: out Node_Id
)
13079 Nam
: constant Node_Id
:= Name
(N
);
13082 -- For a simple entry, the name is a selected component, with the
13083 -- prefix being the task value, and the selector being the entry.
13085 if Nkind
(Nam
) = N_Selected_Component
then
13086 Concval
:= Prefix
(Nam
);
13087 Ename
:= Selector_Name
(Nam
);
13090 -- For a member of an entry family, the name is an indexed component
13091 -- where the prefix is a selected component, whose prefix in turn is
13092 -- the task value, and whose selector is the entry family. The single
13093 -- expression in the expressions list of the indexed component is the
13094 -- subscript for the family.
13096 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
13097 Concval
:= Prefix
(Prefix
(Nam
));
13098 Ename
:= Selector_Name
(Prefix
(Nam
));
13099 Index
:= First
(Expressions
(Nam
));
13102 -- Through indirection, the type may actually be a limited view of a
13103 -- concurrent type. When compiling a call, the non-limited view of the
13104 -- type is visible.
13106 if From_Limited_With
(Etype
(Concval
)) then
13107 Set_Etype
(Concval
, Non_Limited_View
(Etype
(Concval
)));
13111 -------------------
13112 -- Family_Offset --
13113 -------------------
13115 function Family_Offset
13120 Cap
: Boolean) return Node_Id
13126 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
13127 -- If one of the bounds is a reference to a discriminant, replace with
13128 -- corresponding discriminal of type. Within the body of a task retrieve
13129 -- the renamed discriminant by simple visibility, using its generated
13130 -- name. Within a protected object, find the original discriminant and
13131 -- replace it with the discriminal of the current protected operation.
13133 ------------------------------
13134 -- Convert_Discriminant_Ref --
13135 ------------------------------
13137 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
13138 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
13143 if Is_Entity_Name
(Bound
)
13144 and then Ekind
(Entity
(Bound
)) = E_Discriminant
13146 if Is_Task_Type
(Ttyp
) and then Has_Completion
(Ttyp
) then
13147 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13148 Find_Direct_Name
(B
);
13150 elsif Is_Protected_Type
(Ttyp
) then
13151 D
:= First_Discriminant
(Ttyp
);
13152 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
13153 Next_Discriminant
(D
);
13156 B
:= New_Occurrence_Of
(Discriminal
(D
), Loc
);
13159 B
:= New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
13162 elsif Nkind
(Bound
) = N_Attribute_Reference
then
13166 B
:= New_Copy_Tree
(Bound
);
13170 Make_Attribute_Reference
(Loc
,
13171 Attribute_Name
=> Name_Pos
,
13172 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
13173 Expressions
=> New_List
(B
));
13174 end Convert_Discriminant_Ref
;
13176 -- Start of processing for Family_Offset
13179 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
13180 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
13183 if Is_Task_Type
(Ttyp
) then
13184 Ityp
:= RTE
(RE_Task_Entry_Index
);
13186 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13190 Make_Attribute_Reference
(Loc
,
13191 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13192 Attribute_Name
=> Name_Min
,
13193 Expressions
=> New_List
(
13195 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
13198 Make_Attribute_Reference
(Loc
,
13199 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13200 Attribute_Name
=> Name_Max
,
13201 Expressions
=> New_List
(
13203 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
13206 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
13213 function Family_Size
13218 Cap
: Boolean) return Node_Id
13223 if Is_Task_Type
(Ttyp
) then
13224 Ityp
:= RTE
(RE_Task_Entry_Index
);
13226 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13230 Make_Attribute_Reference
(Loc
,
13231 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13232 Attribute_Name
=> Name_Max
,
13233 Expressions
=> New_List
(
13235 Left_Opnd
=> Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
13236 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
13237 Make_Integer_Literal
(Loc
, 0)));
13240 ----------------------------
13241 -- Find_Enclosing_Context --
13242 ----------------------------
13244 procedure Find_Enclosing_Context
13246 Context
: out Node_Id
;
13247 Context_Id
: out Entity_Id
;
13248 Context_Decls
: out List_Id
)
13251 -- Traverse the parent chain looking for an enclosing body, block,
13252 -- package or return statement.
13254 Context
:= Parent
(N
);
13255 while Present
(Context
) loop
13256 if Nkind_In
(Context
, N_Entry_Body
,
13257 N_Extended_Return_Statement
,
13259 N_Package_Declaration
,
13265 -- Do not consider block created to protect a list of statements with
13266 -- an Abort_Defer / Abort_Undefer_Direct pair.
13268 elsif Nkind
(Context
) = N_Block_Statement
13269 and then not Is_Abort_Block
(Context
)
13274 Context
:= Parent
(Context
);
13277 pragma Assert
(Present
(Context
));
13279 -- Extract the constituents of the context
13281 if Nkind
(Context
) = N_Extended_Return_Statement
then
13282 Context_Decls
:= Return_Object_Declarations
(Context
);
13283 Context_Id
:= Return_Statement_Entity
(Context
);
13285 -- Package declarations and bodies use a common library-level activation
13286 -- chain or task master, therefore return the package declaration as the
13287 -- proper carrier for the appropriate flag.
13289 elsif Nkind
(Context
) = N_Package_Body
then
13290 Context_Decls
:= Declarations
(Context
);
13291 Context_Id
:= Corresponding_Spec
(Context
);
13292 Context
:= Parent
(Context_Id
);
13294 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
13295 Context
:= Parent
(Parent
(Context
));
13297 Context
:= Parent
(Context
);
13300 elsif Nkind
(Context
) = N_Package_Declaration
then
13301 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
13302 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13304 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13305 Context_Id
:= Defining_Identifier
(Context_Id
);
13309 if Nkind
(Context
) = N_Block_Statement
then
13310 Context_Id
:= Entity
(Identifier
(Context
));
13312 elsif Nkind
(Context
) = N_Entry_Body
then
13313 Context_Id
:= Defining_Identifier
(Context
);
13315 elsif Nkind
(Context
) = N_Subprogram_Body
then
13316 if Present
(Corresponding_Spec
(Context
)) then
13317 Context_Id
:= Corresponding_Spec
(Context
);
13319 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13321 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13322 Context_Id
:= Defining_Identifier
(Context_Id
);
13326 elsif Nkind
(Context
) = N_Task_Body
then
13327 Context_Id
:= Corresponding_Spec
(Context
);
13330 raise Program_Error
;
13333 Context_Decls
:= Declarations
(Context
);
13336 pragma Assert
(Present
(Context_Id
));
13337 pragma Assert
(Present
(Context_Decls
));
13338 end Find_Enclosing_Context
;
13340 -----------------------
13341 -- Find_Master_Scope --
13342 -----------------------
13344 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
13348 -- In Ada 2005, the master is the innermost enclosing scope that is not
13349 -- transient. If the enclosing block is the rewriting of a call or the
13350 -- scope is an extended return statement this is valid master. The
13351 -- master in an extended return is only used within the return, and is
13352 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13353 -- now before that overwriting occurs.
13357 if Ada_Version
>= Ada_2005
then
13358 while Is_Internal
(S
) loop
13359 if Nkind
(Parent
(S
)) = N_Block_Statement
13361 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
13365 elsif Ekind
(S
) = E_Return_Statement
then
13375 end Find_Master_Scope
;
13377 -------------------------------
13378 -- First_Protected_Operation --
13379 -------------------------------
13381 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
13382 First_Op
: Node_Id
;
13385 First_Op
:= First
(D
);
13386 while Present
(First_Op
)
13387 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
13393 end First_Protected_Operation
;
13395 ---------------------------------------
13396 -- Install_Private_Data_Declarations --
13397 ---------------------------------------
13399 procedure Install_Private_Data_Declarations
13401 Spec_Id
: Entity_Id
;
13402 Conc_Typ
: Entity_Id
;
13403 Body_Nod
: Node_Id
;
13405 Barrier
: Boolean := False;
13406 Family
: Boolean := False)
13408 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
13411 Insert_Node
: Node_Id
:= Empty
;
13412 Obj_Ent
: Entity_Id
;
13414 procedure Add
(Decl
: Node_Id
);
13415 -- Add a single declaration after Insert_Node. If this is the first
13416 -- addition, Decl is added to the front of Decls and it becomes the
13419 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
13420 -- The bounds of an entry index may depend on discriminants, create a
13421 -- reference to the corresponding prival. Otherwise return a duplicate
13422 -- of the original bound.
13428 procedure Add
(Decl
: Node_Id
) is
13430 if No
(Insert_Node
) then
13431 Prepend_To
(Decls
, Decl
);
13433 Insert_After
(Insert_Node
, Decl
);
13436 Insert_Node
:= Decl
;
13439 -------------------
13440 -- Replace_Bound --
13441 -------------------
13443 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
13445 if Nkind
(Bound
) = N_Identifier
13446 and then Is_Discriminal
(Entity
(Bound
))
13448 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13450 return Duplicate_Subexpr
(Bound
);
13454 -- Start of processing for Install_Private_Data_Declarations
13457 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13458 -- formal parameter _O, _object or _task depending on the context.
13460 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
13462 -- Special processing of _O for barrier functions, protected entries
13469 (Ekind
(Spec_Id
) = E_Entry
13470 or else Ekind
(Spec_Id
) = E_Entry_Family
))
13473 Conc_Rec
: constant Entity_Id
:=
13474 Corresponding_Record_Type
(Conc_Typ
);
13475 Typ_Id
: constant Entity_Id
:=
13476 Make_Defining_Identifier
(Loc
,
13477 New_External_Name
(Chars
(Conc_Rec
), 'P'));
13480 -- type prot_typVP is access prot_typV;
13483 Make_Full_Type_Declaration
(Loc
,
13484 Defining_Identifier
=> Typ_Id
,
13486 Make_Access_To_Object_Definition
(Loc
,
13487 Subtype_Indication
=>
13488 New_Occurrence_Of
(Conc_Rec
, Loc
)));
13492 -- _object : prot_typVP := prot_typV (_O);
13495 Make_Object_Declaration
(Loc
,
13496 Defining_Identifier
=>
13497 Make_Defining_Identifier
(Loc
, Name_uObject
),
13498 Object_Definition
=> New_Occurrence_Of
(Typ_Id
, Loc
),
13500 Unchecked_Convert_To
(Typ_Id
,
13501 New_Occurrence_Of
(Obj_Ent
, Loc
)));
13504 -- Set the reference to the concurrent object
13506 Obj_Ent
:= Defining_Identifier
(Decl
);
13510 -- Step 2: Create the Protection object and build its declaration for
13511 -- any protected entry (family) of subprogram. Note for the lock-free
13512 -- implementation, the Protection object is not needed anymore.
13514 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
13516 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
13520 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
13522 -- Determine the proper protection type
13524 if Has_Attach_Handler
(Conc_Typ
)
13525 and then not Restricted_Profile
13527 Prot_Typ
:= RE_Static_Interrupt_Protection
;
13529 elsif Has_Interrupt_Handler
(Conc_Typ
)
13530 and then not Restriction_Active
(No_Dynamic_Attachment
)
13532 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
13535 case Corresponding_Runtime_Package
(Conc_Typ
) is
13536 when System_Tasking_Protected_Objects_Entries
=>
13537 Prot_Typ
:= RE_Protection_Entries
;
13539 when System_Tasking_Protected_Objects_Single_Entry
=>
13540 Prot_Typ
:= RE_Protection_Entry
;
13542 when System_Tasking_Protected_Objects
=>
13543 Prot_Typ
:= RE_Protection
;
13546 raise Program_Error
;
13551 -- conc_typR : protection_typ renames _object._object;
13554 Make_Object_Renaming_Declaration
(Loc
,
13555 Defining_Identifier
=> Prot_Ent
,
13557 New_Occurrence_Of
(RTE
(Prot_Typ
), Loc
),
13559 Make_Selected_Component
(Loc
,
13560 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13561 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
13566 -- Step 3: Add discriminant renamings (if any)
13568 if Has_Discriminants
(Conc_Typ
) then
13573 D
:= First_Discriminant
(Conc_Typ
);
13574 while Present
(D
) loop
13576 -- Adjust the source location
13578 Set_Sloc
(Discriminal
(D
), Loc
);
13581 -- discr_name : discr_typ renames _object.discr_name;
13583 -- discr_name : discr_typ renames _task.discr_name;
13586 Make_Object_Renaming_Declaration
(Loc
,
13587 Defining_Identifier
=> Discriminal
(D
),
13588 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
13590 Make_Selected_Component
(Loc
,
13591 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13592 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
13595 -- Set debug info needed on this renaming declaration even
13596 -- though it does not come from source, so that the debugger
13597 -- will get the right information for these generated names.
13599 Set_Debug_Info_Needed
(Discriminal
(D
));
13601 Next_Discriminant
(D
);
13606 -- Step 4: Add private component renamings (if any)
13608 if Is_Protected
then
13609 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
13611 if Present
(Private_Declarations
(Def
)) then
13614 Comp_Id
: Entity_Id
;
13615 Decl_Id
: Entity_Id
;
13618 Comp
:= First
(Private_Declarations
(Def
));
13619 while Present
(Comp
) loop
13620 if Nkind
(Comp
) = N_Component_Declaration
then
13621 Comp_Id
:= Defining_Identifier
(Comp
);
13623 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
13625 -- Minimal decoration
13627 if Ekind
(Spec_Id
) = E_Function
then
13628 Set_Ekind
(Decl_Id
, E_Constant
);
13630 Set_Ekind
(Decl_Id
, E_Variable
);
13633 Set_Prival
(Comp_Id
, Decl_Id
);
13634 Set_Prival_Link
(Decl_Id
, Comp_Id
);
13635 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13638 -- comp_name : comp_typ renames _object.comp_name;
13641 Make_Object_Renaming_Declaration
(Loc
,
13642 Defining_Identifier
=> Decl_Id
,
13644 New_Occurrence_Of
(Etype
(Comp_Id
), Loc
),
13646 Make_Selected_Component
(Loc
,
13648 New_Occurrence_Of
(Obj_Ent
, Loc
),
13650 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
13660 -- Step 5: Add the declaration of the entry index and the associated
13661 -- type for barrier functions and entry families.
13663 if (Barrier
and Family
) or else Ekind
(Spec_Id
) = E_Entry_Family
then
13665 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13666 Index
: constant Entity_Id
:=
13667 Defining_Identifier
13668 (Entry_Index_Specification
13669 (Entry_Body_Formal_Part
(Body_Nod
)));
13670 Index_Con
: constant Entity_Id
:=
13671 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13673 Index_Typ
: Entity_Id
;
13677 -- Minimal decoration
13679 Set_Ekind
(Index_Con
, E_Constant
);
13680 Set_Entry_Index_Constant
(Index
, Index_Con
);
13681 Set_Discriminal_Link
(Index_Con
, Index
);
13683 -- Retrieve the bounds of the entry family
13685 High
:= Type_High_Bound
(Etype
(Index
));
13686 Low
:= Type_Low_Bound
(Etype
(Index
));
13688 -- In the simple case the entry family is given by a subtype mark
13689 -- and the index constant has the same type.
13691 if Is_Entity_Name
(Original_Node
(
13692 Discrete_Subtype_Definition
(Parent
(Index
))))
13694 Index_Typ
:= Etype
(Index
);
13696 -- Otherwise a new subtype declaration is required
13699 High
:= Replace_Bound
(High
);
13700 Low
:= Replace_Bound
(Low
);
13702 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13705 -- subtype Jnn is <Etype of Index> range Low .. High;
13708 Make_Subtype_Declaration
(Loc
,
13709 Defining_Identifier
=> Index_Typ
,
13710 Subtype_Indication
=>
13711 Make_Subtype_Indication
(Loc
,
13713 New_Occurrence_Of
(Base_Type
(Etype
(Index
)), Loc
),
13715 Make_Range_Constraint
(Loc
,
13716 Range_Expression
=>
13717 Make_Range
(Loc
, Low
, High
))));
13721 Set_Etype
(Index_Con
, Index_Typ
);
13723 -- Create the object which designates the index:
13724 -- J : constant Jnn :=
13725 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13727 -- where Jnn is the subtype created above or the original type of
13728 -- the index, _E is a formal of the protected body subprogram and
13729 -- <index expr> is the index of the first family member.
13732 Make_Object_Declaration
(Loc
,
13733 Defining_Identifier
=> Index_Con
,
13734 Constant_Present
=> True,
13735 Object_Definition
=>
13736 New_Occurrence_Of
(Index_Typ
, Loc
),
13739 Make_Attribute_Reference
(Loc
,
13741 New_Occurrence_Of
(Index_Typ
, Loc
),
13742 Attribute_Name
=> Name_Val
,
13744 Expressions
=> New_List
(
13748 Make_Op_Subtract
(Loc
,
13749 Left_Opnd
=> New_Occurrence_Of
(E
, Loc
),
13751 Entry_Index_Expression
(Loc
,
13752 Defining_Identifier
(Body_Nod
),
13756 Make_Attribute_Reference
(Loc
,
13758 New_Occurrence_Of
(Index_Typ
, Loc
),
13759 Attribute_Name
=> Name_Pos
,
13760 Expressions
=> New_List
(
13761 Make_Attribute_Reference
(Loc
,
13763 New_Occurrence_Of
(Index_Typ
, Loc
),
13764 Attribute_Name
=> Name_First
)))))));
13768 end Install_Private_Data_Declarations
;
13770 ---------------------------------
13771 -- Is_Potentially_Large_Family --
13772 ---------------------------------
13774 function Is_Potentially_Large_Family
13775 (Base_Index
: Entity_Id
;
13776 Conctyp
: Entity_Id
;
13778 Hi
: Node_Id
) return Boolean
13781 return Scope
(Base_Index
) = Standard_Standard
13782 and then Base_Index
= Base_Type
(Standard_Integer
)
13783 and then Has_Discriminants
(Conctyp
)
13785 Present
(Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
13787 (Denotes_Discriminant
(Lo
, True)
13789 Denotes_Discriminant
(Hi
, True));
13790 end Is_Potentially_Large_Family
;
13792 -------------------------------------
13793 -- Is_Private_Primitive_Subprogram --
13794 -------------------------------------
13796 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13799 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13800 and then Is_Private_Primitive
(Id
);
13801 end Is_Private_Primitive_Subprogram
;
13807 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13808 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13809 Formal
: Entity_Id
;
13812 Formal
:= First_Formal
(Bod_Subp
);
13813 while Present
(Formal
) loop
13815 -- Look for formal parameter _E
13817 if Chars
(Formal
) = Name_uE
then
13821 Next_Formal
(Formal
);
13824 -- A protected body subprogram should always have the parameter in
13827 raise Program_Error
;
13830 --------------------------------
13831 -- Make_Initialize_Protection --
13832 --------------------------------
13834 function Make_Initialize_Protection
13835 (Protect_Rec
: Entity_Id
) return List_Id
13837 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
13840 Ptyp
: constant Node_Id
:=
13841 Corresponding_Concurrent_Type
(Protect_Rec
);
13843 L
: constant List_Id
:= New_List
;
13844 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
13845 Prio_Type
: Entity_Id
;
13846 Prio_Var
: Entity_Id
:= Empty
;
13847 Restricted
: constant Boolean := Restricted_Profile
;
13850 -- We may need two calls to properly initialize the object, one to
13851 -- Initialize_Protection, and possibly one to Install_Handlers if we
13852 -- have a pragma Attach_Handler.
13854 -- Get protected declaration. In the case of a task type declaration,
13855 -- this is simply the parent of the protected type entity. In the single
13856 -- protected object declaration, this parent will be the implicit type,
13857 -- and we can find the corresponding single protected object declaration
13858 -- by searching forward in the declaration list in the tree.
13860 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13861 -- of this type should have been removed during semantic analysis.
13863 Pdec
:= Parent
(Ptyp
);
13864 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
13865 N_Single_Protected_Declaration
)
13870 -- Build the parameter list for the call. Note that _Init is the name
13871 -- of the formal for the object to be initialized, which is the task
13872 -- value record itself.
13876 -- For lock-free implementation, skip initializations of the Protection
13879 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13881 -- Object parameter. This is a pointer to the object of type
13882 -- Protection used by the GNARL to control the protected object.
13885 Make_Attribute_Reference
(Loc
,
13887 Make_Selected_Component
(Loc
,
13888 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13889 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
13890 Attribute_Name
=> Name_Unchecked_Access
));
13892 -- Priority parameter. Set to Unspecified_Priority unless there is a
13893 -- Priority rep item, in which case we take the value from the pragma
13894 -- or attribute definition clause, or there is an Interrupt_Priority
13895 -- rep item and no Priority rep item, and we set the ceiling to
13896 -- Interrupt_Priority'Last, an implementation-defined value, see
13899 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
13901 Prio_Clause
: constant Node_Id
:=
13903 (Ptyp
, Name_Priority
, Check_Parents
=> False);
13910 if Nkind
(Prio_Clause
) = N_Pragma
then
13913 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
13915 -- Get_Rep_Item returns either priority pragma
13917 if Pragma_Name
(Prio_Clause
) = Name_Priority
then
13918 Prio_Type
:= RTE
(RE_Any_Priority
);
13920 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13923 -- Attribute definition clause Priority
13926 if Chars
(Prio_Clause
) = Name_Priority
then
13927 Prio_Type
:= RTE
(RE_Any_Priority
);
13929 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13932 Prio
:= Expression
(Prio_Clause
);
13935 -- Always create a locale variable to capture the priority.
13936 -- The priority is also passed to Install_Restriced_Handlers.
13937 -- Note that it is really necessary to create this variable
13938 -- explicitly. It might be thought that removing side effects
13939 -- would the appropriate approach, but that could generate
13940 -- declarations improperly placed in the enclosing scope.
13942 Prio_Var
:= Make_Temporary
(Loc
, 'R', Prio
);
13944 Make_Object_Declaration
(Loc
,
13945 Defining_Identifier
=> Prio_Var
,
13946 Object_Definition
=> New_Occurrence_Of
(Prio_Type
, Loc
),
13947 Expression
=> Relocate_Node
(Prio
)));
13949 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
13952 -- When no priority is specified but an xx_Handler pragma is, we
13953 -- default to System.Interrupts.Default_Interrupt_Priority, see
13956 elsif Has_Attach_Handler
(Ptyp
)
13957 or else Has_Interrupt_Handler
(Ptyp
)
13960 New_Occurrence_Of
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
13962 -- Normal case, no priority or xx_Handler specified, default priority
13966 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
13969 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
13971 if Restricted_Profile
and Task_Dispatching_Policy
= 'E' then
13972 Deadline_Floor
: declare
13973 Item
: constant Node_Id
:=
13975 (Ptyp
, Name_Deadline_Floor
, Check_Parents
=> False);
13977 Deadline
: Node_Id
;
13980 if Present
(Item
) then
13982 -- Pragma Deadline_Floor
13984 if Nkind
(Item
) = N_Pragma
then
13987 (First
(Pragma_Argument_Associations
(Item
)));
13989 -- Attribute definition clause Deadline_Floor
13993 (Nkind
(Item
) = N_Attribute_Definition_Clause
);
13995 Deadline
:= Expression
(Item
);
13998 Append_To
(Args
, Deadline
);
14000 -- Unusual case: default deadline
14004 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14006 end Deadline_Floor
;
14009 -- Test for Compiler_Info parameter. This parameter allows entry body
14010 -- procedures and barrier functions to be called from the runtime. It
14011 -- is a pointer to the record generated by the compiler to represent
14012 -- the protected object.
14014 -- A protected type without entries that covers an interface and
14015 -- overrides the abstract routines with protected procedures is
14016 -- considered equivalent to a protected type with entries in the
14017 -- context of dispatching select statements.
14019 -- Protected types with interrupt handlers (when not using a
14020 -- restricted profile) are also considered equivalent to protected
14021 -- types with entries.
14023 -- The types which are used (Static_Interrupt_Protection and
14024 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14027 Pkg_Id
: constant RTU_Id
:= Corresponding_Runtime_Package
(Ptyp
);
14029 Called_Subp
: RE_Id
;
14033 when System_Tasking_Protected_Objects_Entries
=>
14034 Called_Subp
:= RE_Initialize_Protection_Entries
;
14036 -- Argument Compiler_Info
14039 Make_Attribute_Reference
(Loc
,
14040 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14041 Attribute_Name
=> Name_Address
));
14043 when System_Tasking_Protected_Objects_Single_Entry
=>
14044 Called_Subp
:= RE_Initialize_Protection_Entry
;
14046 -- Argument Compiler_Info
14049 Make_Attribute_Reference
(Loc
,
14050 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14051 Attribute_Name
=> Name_Address
));
14053 when System_Tasking_Protected_Objects
=>
14054 Called_Subp
:= RE_Initialize_Protection
;
14057 raise Program_Error
;
14060 -- Entry_Queue_Maxes parameter. This is an access to an array of
14061 -- naturals representing the entry queue maximums for each entry
14062 -- in the protected type. Zero represents no max. The access is
14063 -- null if there is no limit for all entries (usual case).
14066 and then Pkg_Id
= System_Tasking_Protected_Objects_Entries
14068 if Present
(Entry_Max_Queue_Lengths_Array
(Ptyp
)) then
14070 Make_Attribute_Reference
(Loc
,
14073 (Entry_Max_Queue_Lengths_Array
(Ptyp
), Loc
),
14074 Attribute_Name
=> Name_Unrestricted_Access
));
14076 Append_To
(Args
, Make_Null
(Loc
));
14079 -- Edge cases exist where entry initialization functions are
14080 -- called, but no entries exist, so null is appended.
14082 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14083 Append_To
(Args
, Make_Null
(Loc
));
14086 -- Entry_Bodies parameter. This is a pointer to an array of
14087 -- pointers to the entry body procedures and barrier functions of
14088 -- the object. If the protected type has no entries this object
14089 -- will not exist, in this case, pass a null (it can happen when
14090 -- there are protected interrupt handlers or interfaces).
14093 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
14095 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14096 -- multiple entries).
14099 Make_Attribute_Reference
(Loc
,
14100 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14101 Attribute_Name
=> Name_Unrestricted_Access
));
14103 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14105 -- Find index mapping function (clumsy but ok for now)
14107 while Ekind
(P_Arr
) /= E_Function
loop
14108 Next_Entity
(P_Arr
);
14112 Make_Attribute_Reference
(Loc
,
14113 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14114 Attribute_Name
=> Name_Unrestricted_Access
));
14117 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
14119 -- This is the case where we have a protected object with
14120 -- interfaces and no entries, and the single entry restriction
14121 -- is in effect. We pass a null pointer for the entry
14122 -- parameter because there is no actual entry.
14124 Append_To
(Args
, Make_Null
(Loc
));
14126 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14128 -- This is the case where we have a protected object with no
14130 -- - either interrupt handlers with non restricted profile,
14132 -- Note that the types which are used for interrupt handlers
14133 -- (Static/Dynamic_Interrupt_Protection) are derived from
14134 -- Protection_Entries. We pass two null pointers because there
14135 -- is no actual entry, and the initialization procedure needs
14136 -- both Entry_Bodies and Find_Body_Index.
14138 Append_To
(Args
, Make_Null
(Loc
));
14139 Append_To
(Args
, Make_Null
(Loc
));
14143 Make_Procedure_Call_Statement
(Loc
,
14145 New_Occurrence_Of
(RTE
(Called_Subp
), Loc
),
14146 Parameter_Associations
=> Args
));
14150 if Has_Attach_Handler
(Ptyp
) then
14152 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14153 -- make the following call:
14155 -- Install_Handlers (_object,
14156 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14158 -- or, in the case of Ravenscar:
14160 -- Install_Restricted_Handlers
14161 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14164 Args
: constant List_Id
:= New_List
;
14165 Table
: constant List_Id
:= New_List
;
14166 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
14169 -- Build the Priority parameter (only for ravenscar)
14173 -- Priority comes from a pragma
14175 if Present
(Prio_Var
) then
14176 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14178 -- Priority is the default one
14183 (RTE
(RE_Default_Interrupt_Priority
), Loc
));
14187 -- Build the Attach_Handler table argument
14189 while Present
(Ritem
) loop
14190 if Nkind
(Ritem
) = N_Pragma
14191 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
14194 Handler
: constant Node_Id
:=
14195 First
(Pragma_Argument_Associations
(Ritem
));
14197 Interrupt
: constant Node_Id
:= Next
(Handler
);
14198 Expr
: constant Node_Id
:= Expression
(Interrupt
);
14202 Make_Aggregate
(Loc
, Expressions
=> New_List
(
14203 Unchecked_Convert_To
14204 (RTE
(RE_System_Interrupt_Id
), Expr
),
14205 Make_Attribute_Reference
(Loc
,
14207 Make_Selected_Component
(Loc
,
14209 Make_Identifier
(Loc
, Name_uInit
),
14211 Duplicate_Subexpr_No_Checks
14212 (Expression
(Handler
))),
14213 Attribute_Name
=> Name_Access
))));
14217 Next_Rep_Item
(Ritem
);
14220 -- Append the table argument we just built
14222 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
14224 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14225 -- call to the statements.
14228 -- Call a simplified version of Install_Handlers to be used
14229 -- when the Ravenscar restrictions are in effect
14230 -- (Install_Restricted_Handlers).
14233 Make_Procedure_Call_Statement
(Loc
,
14236 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
14237 Parameter_Associations
=> Args
));
14240 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14242 -- First, prepends the _object argument
14245 Make_Attribute_Reference
(Loc
,
14247 Make_Selected_Component
(Loc
,
14248 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14250 Make_Identifier
(Loc
, Name_uObject
)),
14251 Attribute_Name
=> Name_Unchecked_Access
));
14254 -- Then, insert call to Install_Handlers
14257 Make_Procedure_Call_Statement
(Loc
,
14259 New_Occurrence_Of
(RTE
(RE_Install_Handlers
), Loc
),
14260 Parameter_Associations
=> Args
));
14266 end Make_Initialize_Protection
;
14268 ---------------------------
14269 -- Make_Task_Create_Call --
14270 ---------------------------
14272 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
14273 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
14283 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
14284 Tnam
:= Chars
(Ttyp
);
14286 -- Get task declaration. In the case of a task type declaration, this is
14287 -- simply the parent of the task type entity. In the single task
14288 -- declaration, this parent will be the implicit type, and we can find
14289 -- the corresponding single task declaration by searching forward in the
14290 -- declaration list in the tree.
14292 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14293 -- this type should have been removed during semantic analysis.
14295 Tdec
:= Parent
(Ttyp
);
14296 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
14297 N_Single_Task_Declaration
)
14302 -- Now we can find the task definition from this declaration
14304 Tdef
:= Task_Definition
(Tdec
);
14306 -- Build the parameter list for the call. Note that _Init is the name
14307 -- of the formal for the object to be initialized, which is the task
14308 -- value record itself.
14312 -- Priority parameter. Set to Unspecified_Priority unless there is a
14313 -- Priority rep item, in which case we take the value from the rep item.
14314 -- Not used on Ravenscar_EDF profile.
14316 if not (Restricted_Profile
and then Task_Dispatching_Policy
= 'E') then
14317 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
14319 Make_Selected_Component
(Loc
,
14320 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14321 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
14324 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14328 -- Optional Stack parameter
14330 if Restricted_Profile
then
14332 -- If the stack has been preallocated by the expander then
14333 -- pass its address. Otherwise, pass a null address.
14335 if Preallocated_Stacks_On_Target
then
14337 Make_Attribute_Reference
(Loc
,
14339 Make_Selected_Component
(Loc
,
14340 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14341 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
14342 Attribute_Name
=> Name_Address
));
14346 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
14350 -- Size parameter. If no Storage_Size pragma is present, then
14351 -- the size is taken from the taskZ variable for the type, which
14352 -- is either Unspecified_Size, or has been reset by the use of
14353 -- a Storage_Size attribute definition clause. If a pragma is
14354 -- present, then the size is taken from the _Size field of the
14355 -- task value record, which was set from the pragma value.
14357 if Present
(Tdef
) and then Has_Storage_Size_Pragma
(Tdef
) then
14359 Make_Selected_Component
(Loc
,
14360 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14361 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
14365 New_Occurrence_Of
(Storage_Size_Variable
(Ttyp
), Loc
));
14368 -- Secondary_Stack parameter used for restricted profiles
14370 if Restricted_Profile
then
14372 -- If the secondary stack has been allocated by the expander then
14373 -- pass its access pointer. Otherwise, pass null.
14375 if Create_Secondary_Stack_For_Task
(Ttyp
) then
14377 Make_Attribute_Reference
(Loc
,
14379 Make_Selected_Component
(Loc
,
14380 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14382 Make_Identifier
(Loc
, Name_uSecondary_Stack
)),
14383 Attribute_Name
=> Name_Unrestricted_Access
));
14386 Append_To
(Args
, Make_Null
(Loc
));
14390 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
14391 -- is a Secondary_Stack_Size pragma, in which case take the value from
14392 -- the pragma. If the restriction No_Secondary_Stack is active then a
14393 -- size of 0 is passed regardless to prevent the allocation of the
14396 if Restriction_Active
(No_Secondary_Stack
) then
14397 Append_To
(Args
, Make_Integer_Literal
(Loc
, 0));
14399 elsif Has_Rep_Pragma
14400 (Ttyp
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
14403 Make_Selected_Component
(Loc
,
14404 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14406 Make_Identifier
(Loc
, Name_uSecondary_Stack_Size
)));
14410 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
14413 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14414 -- Task_Info pragma, in which case we take the value from the pragma.
14416 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
14418 Make_Selected_Component
(Loc
,
14419 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14420 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
14424 New_Occurrence_Of
(RTE
(RE_Unspecified_Task_Info
), Loc
));
14427 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14428 -- in which case we take the value from the rep item. The parameter is
14429 -- passed as an Integer because in the case of unspecified CPU the
14430 -- value is not in the range of CPU_Range.
14432 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
14434 Convert_To
(Standard_Integer
,
14435 Make_Selected_Component
(Loc
,
14436 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14437 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
14440 New_Occurrence_Of
(RTE
(RE_Unspecified_CPU
), Loc
));
14443 if not Restricted_Profile
or else Task_Dispatching_Policy
= 'E' then
14445 -- Deadline parameter. If no Relative_Deadline pragma is present,
14446 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14447 -- the deadline is taken from the _Relative_Deadline field of the
14448 -- task value record, which was set from the pragma value. Note that
14449 -- this parameter must not be generated for the restricted profiles
14450 -- since Ravenscar does not allow deadlines.
14452 -- Case where pragma Relative_Deadline applies: use given value
14454 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
14456 Make_Selected_Component
(Loc
,
14457 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14459 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
14461 -- No pragma Relative_Deadline apply to the task
14465 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14469 if not Restricted_Profile
then
14471 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14472 -- present, then the dispatching domain is null. If a rep item is
14473 -- present, then the dispatching domain is taken from the
14474 -- _Dispatching_Domain field of the task value record, which was set
14475 -- from the rep item value.
14477 -- Case where Dispatching_Domain rep item applies: use given value
14480 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
14483 Make_Selected_Component
(Loc
,
14485 Make_Identifier
(Loc
, Name_uInit
),
14487 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
14489 -- No pragma or aspect Dispatching_Domain applies to the task
14492 Append_To
(Args
, Make_Null
(Loc
));
14495 -- Number of entries. This is an expression of the form:
14497 -- n + _Init.a'Length + _Init.a'B'Length + ...
14499 -- where a,b... are the entry family names for the task definition
14502 Build_Entry_Count_Expression
14507 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
14509 Append_To
(Args
, Ecount
);
14511 -- Master parameter. This is a reference to the _Master parameter of
14512 -- the initialization procedure, except in the case of the pragma
14513 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14514 -- System.Tasking.Library_Task_Level.
14516 if Restriction_Active
(No_Task_Hierarchy
) = False then
14517 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
14520 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
14524 -- State parameter. This is a pointer to the task body procedure. The
14525 -- required value is obtained by taking 'Unrestricted_Access of the task
14526 -- body procedure and converting it (with an unchecked conversion) to
14527 -- the type required by the task kernel. For further details, see the
14528 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14529 -- than 'Address in order to avoid creating trampolines.
14532 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
14533 Subp_Ptr_Typ
: constant Node_Id
:=
14534 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
14535 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
14538 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
14539 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
14541 -- Be sure to freeze a reference to the access-to-subprogram type,
14542 -- otherwise gigi will complain that it's in the wrong scope, because
14543 -- it's actually inside the init procedure for the record type that
14544 -- corresponds to the task type.
14546 Set_Itype
(Ref
, Subp_Ptr_Typ
);
14547 Append_Freeze_Action
(Task_Rec
, Ref
);
14550 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
14551 Make_Qualified_Expression
(Loc
,
14552 Subtype_Mark
=> New_Occurrence_Of
(Subp_Ptr_Typ
, Loc
),
14554 Make_Attribute_Reference
(Loc
,
14555 Prefix
=> New_Occurrence_Of
(Body_Proc
, Loc
),
14556 Attribute_Name
=> Name_Unrestricted_Access
))));
14559 -- Discriminants parameter. This is just the address of the task
14560 -- value record itself (which contains the discriminant values
14563 Make_Attribute_Reference
(Loc
,
14564 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14565 Attribute_Name
=> Name_Address
));
14567 -- Elaborated parameter. This is an access to the elaboration Boolean
14570 Make_Attribute_Reference
(Loc
,
14571 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
14572 Attribute_Name
=> Name_Unchecked_Access
));
14574 -- Add Chain parameter (not done for sequential elaboration policy, see
14575 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14577 if Partition_Elaboration_Policy
/= 'S' then
14578 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
14581 -- Task name parameter. Take this from the _Task_Id parameter to the
14582 -- init call unless there is a Task_Name pragma, in which case we take
14583 -- the value from the pragma.
14585 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
14586 -- Copy expression in full, because it may be dynamic and have
14593 (Pragma_Argument_Associations
14595 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
14598 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
14601 -- Created_Task parameter. This is the _Task_Id field of the task
14605 Make_Selected_Component
(Loc
,
14606 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14607 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
14613 if Restricted_Profile
then
14614 if Partition_Elaboration_Policy
= 'S' then
14615 Create_RE
:= RE_Create_Restricted_Task_Sequential
;
14617 Create_RE
:= RE_Create_Restricted_Task
;
14620 Create_RE
:= RE_Create_Task
;
14623 Name
:= New_Occurrence_Of
(RTE
(Create_RE
), Loc
);
14627 Make_Procedure_Call_Statement
(Loc
,
14629 Parameter_Associations
=> Args
);
14630 end Make_Task_Create_Call
;
14632 ------------------------------
14633 -- Next_Protected_Operation --
14634 ------------------------------
14636 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
14640 -- Check whether there is a subsequent body for a protected operation
14641 -- in the current protected body. In Ada2012 that includes expression
14642 -- functions that are completions.
14644 Next_Op
:= Next
(N
);
14645 while Present
(Next_Op
)
14646 and then not Nkind_In
(Next_Op
,
14647 N_Subprogram_Body
, N_Entry_Body
, N_Expression_Function
)
14653 end Next_Protected_Operation
;
14655 ---------------------
14656 -- Null_Statements --
14657 ---------------------
14659 function Null_Statements
(Stats
: List_Id
) return Boolean is
14663 Stmt
:= First
(Stats
);
14664 while Nkind
(Stmt
) /= N_Empty
14665 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
14667 (Nkind
(Stmt
) = N_Pragma
14669 Nam_In
(Pragma_Name_Unmapped
(Stmt
),
14677 return Nkind
(Stmt
) = N_Empty
;
14678 end Null_Statements
;
14680 --------------------------
14681 -- Parameter_Block_Pack --
14682 --------------------------
14684 function Parameter_Block_Pack
14686 Blk_Typ
: Entity_Id
;
14690 Stmts
: List_Id
) return Node_Id
14692 Actual
: Entity_Id
;
14693 Expr
: Node_Id
:= Empty
;
14694 Formal
: Entity_Id
;
14695 Has_Param
: Boolean := False;
14698 Temp_Asn
: Node_Id
;
14699 Temp_Nam
: Node_Id
;
14702 Actual
:= First
(Actuals
);
14703 Formal
:= Defining_Identifier
(First
(Formals
));
14704 Params
:= New_List
;
14705 while Present
(Actual
) loop
14706 if Is_By_Copy_Type
(Etype
(Actual
)) then
14708 -- Jnn : aliased <formal-type>
14710 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14713 Make_Object_Declaration
(Loc
,
14714 Aliased_Present
=> True,
14715 Defining_Identifier
=> Temp_Nam
,
14716 Object_Definition
=>
14717 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
14719 -- The object is initialized with an explicit assignment
14720 -- later. Indicate that it does not need an initialization
14721 -- to prevent spurious warnings if the type excludes null.
14723 Set_No_Initialization
(Last
(Decls
));
14725 if Ekind
(Formal
) /= E_Out_Parameter
then
14731 New_Occurrence_Of
(Temp_Nam
, Loc
);
14733 Set_Assignment_OK
(Temp_Asn
);
14736 Make_Assignment_Statement
(Loc
,
14738 Expression
=> New_Copy_Tree
(Actual
)));
14741 -- If the actual is not controlling, generate:
14743 -- Jnn'unchecked_access
14745 -- and add it to aggegate for access to formals. Note that the
14746 -- actual may be by-copy but still be a controlling actual if it
14747 -- is an access to class-wide interface.
14749 if not Is_Controlling_Actual
(Actual
) then
14751 Make_Attribute_Reference
(Loc
,
14752 Attribute_Name
=> Name_Unchecked_Access
,
14753 Prefix
=> New_Occurrence_Of
(Temp_Nam
, Loc
)));
14758 -- The controlling parameter is omitted
14761 if not Is_Controlling_Actual
(Actual
) then
14763 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14769 Next_Actual
(Actual
);
14770 Next_Formal_With_Extras
(Formal
);
14774 Expr
:= Make_Aggregate
(Loc
, Params
);
14779 -- J1'unchecked_access;
14780 -- <actual2>'reference;
14783 P
:= Make_Temporary
(Loc
, 'P');
14786 Make_Object_Declaration
(Loc
,
14787 Defining_Identifier
=> P
,
14788 Object_Definition
=> New_Occurrence_Of
(Blk_Typ
, Loc
),
14789 Expression
=> Expr
));
14792 end Parameter_Block_Pack
;
14794 ----------------------------
14795 -- Parameter_Block_Unpack --
14796 ----------------------------
14798 function Parameter_Block_Unpack
14802 Formals
: List_Id
) return List_Id
14804 Actual
: Entity_Id
;
14806 Formal
: Entity_Id
;
14807 Has_Asnmt
: Boolean := False;
14808 Result
: constant List_Id
:= New_List
;
14811 Actual
:= First
(Actuals
);
14812 Formal
:= Defining_Identifier
(First
(Formals
));
14813 while Present
(Actual
) loop
14814 if Is_By_Copy_Type
(Etype
(Actual
))
14815 and then Ekind
(Formal
) /= E_In_Parameter
14818 -- <actual> := P.<formal>;
14821 Make_Assignment_Statement
(Loc
,
14825 Make_Explicit_Dereference
(Loc
,
14826 Make_Selected_Component
(Loc
,
14828 New_Occurrence_Of
(P
, Loc
),
14830 Make_Identifier
(Loc
, Chars
(Formal
)))));
14832 Set_Assignment_OK
(Name
(Asnmt
));
14833 Append_To
(Result
, Asnmt
);
14838 Next_Actual
(Actual
);
14839 Next_Formal_With_Extras
(Formal
);
14845 return New_List
(Make_Null_Statement
(Loc
));
14847 end Parameter_Block_Unpack
;
14849 ---------------------
14850 -- Reset_Scopes_To --
14851 ---------------------
14853 procedure Reset_Scopes_To
(Bod
: Node_Id
; E
: Entity_Id
) is
14854 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
;
14855 -- Temporaries may have been declared during expansion of the procedure
14856 -- created for an entry body or an accept alternative. Indicate that
14857 -- their scope is the new body, to unsure proper generation of uplevel
14858 -- references where needed during unnesting.
14860 procedure Reset_Scopes
is new Traverse_Proc
(Reset_Scope
);
14866 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
is
14870 -- If this is a block statement with an Identifier, it forms a scope,
14871 -- so we want to reset its scope but not look inside.
14874 and then Nkind
(N
) = N_Block_Statement
14875 and then Present
(Identifier
(N
))
14877 Set_Scope
(Entity
(Identifier
(N
)), E
);
14880 -- Ditto for a package declaration or a full type declaration, etc.
14882 elsif Nkind
(N
) = N_Package_Declaration
14883 or else Nkind
(N
) in N_Declaration
14884 or else Nkind
(N
) in N_Renaming_Declaration
14886 Set_Scope
(Defining_Entity
(N
), E
);
14891 -- Scan declarations in new body. Declarations in the statement
14892 -- part will be handled during later traversal.
14894 Decl
:= First
(Declarations
(N
));
14895 while Present
(Decl
) loop
14896 Reset_Scopes
(Decl
);
14900 elsif N
/= Bod
and then Nkind
(N
) in N_Proper_Body
then
14907 -- Start of processing for Reset_Scopes_To
14910 Reset_Scopes
(Bod
);
14911 end Reset_Scopes_To
;
14913 ----------------------
14914 -- Set_Discriminals --
14915 ----------------------
14917 procedure Set_Discriminals
(Dec
: Node_Id
) is
14920 D_Minal
: Entity_Id
;
14923 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
14924 Pdef
:= Defining_Identifier
(Dec
);
14926 if Has_Discriminants
(Pdef
) then
14927 D
:= First_Discriminant
(Pdef
);
14928 while Present
(D
) loop
14930 Make_Defining_Identifier
(Sloc
(D
),
14931 Chars
=> New_External_Name
(Chars
(D
), 'D'));
14933 Set_Ekind
(D_Minal
, E_Constant
);
14934 Set_Etype
(D_Minal
, Etype
(D
));
14935 Set_Scope
(D_Minal
, Pdef
);
14936 Set_Discriminal
(D
, D_Minal
);
14937 Set_Discriminal_Link
(D_Minal
, D
);
14939 Next_Discriminant
(D
);
14942 end Set_Discriminals
;
14944 -----------------------
14945 -- Trivial_Accept_OK --
14946 -----------------------
14948 function Trivial_Accept_OK
return Boolean is
14950 case Opt
.Task_Dispatching_Policy
is
14952 -- If we have the default task dispatching policy in effect, we can
14953 -- definitely do the optimization (one way of looking at this is to
14954 -- think of the formal definition of the default policy being allowed
14955 -- to run any task it likes after a rendezvous, so even if notionally
14956 -- a full rescheduling occurs, we can say that our dispatching policy
14957 -- (i.e. the default dispatching policy) reorders the queue to be the
14958 -- same as just before the call.
14963 -- FIFO_Within_Priorities certainly does not permit this
14964 -- optimization since the Rendezvous is a scheduling action that may
14965 -- require some other task to be run.
14970 -- For now, disallow the optimization for all other policies. This
14971 -- may be over-conservative, but it is certainly not incorrect.
14976 end Trivial_Accept_OK
;