1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Ch3
; use Exp_Ch3
;
32 with Exp_Ch6
; use Exp_Ch6
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Dbug
; use Exp_Dbug
;
35 with Exp_Disp
; use Exp_Disp
;
36 with Exp_Sel
; use Exp_Sel
;
37 with Exp_Smem
; use Exp_Smem
;
38 with Exp_Tss
; use Exp_Tss
;
39 with Exp_Util
; use Exp_Util
;
40 with Freeze
; use Freeze
;
42 with Itypes
; use Itypes
;
43 with Namet
; use Namet
;
44 with Nlists
; use Nlists
;
45 with Nmake
; use Nmake
;
47 with Restrict
; use Restrict
;
48 with Rident
; use Rident
;
49 with Rtsfind
; use Rtsfind
;
51 with Sem_Aux
; use Sem_Aux
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Ch9
; use Sem_Ch9
;
55 with Sem_Ch11
; use Sem_Ch11
;
56 with Sem_Elab
; use Sem_Elab
;
57 with Sem_Eval
; use Sem_Eval
;
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 Stringt
; use Stringt
;
64 with Targparm
; use Targparm
;
65 with Tbuild
; use Tbuild
;
66 with Uintp
; use Uintp
;
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 is 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 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
345 -- Decls is a list which may contain the declarations created by Install_
346 -- Private_Data_Declarations. All generated entities are marked as needing
347 -- debug info and debug nodes are manually generation where necessary. This
348 -- step of the expansion must to be done after private data has been moved
349 -- to its final resting scope to ensure proper visibility of debug objects.
351 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
);
352 -- If control flow optimizations are suppressed, and Alt is an accept,
353 -- delay, or entry call alternative with no trailing statements, insert
354 -- a null trailing statement with the given Loc (which is the sloc of
355 -- the accept, delay, or entry call statement). There might not be any
356 -- generated code for the accept, delay, or entry call itself (the effect
357 -- of these statements is part of the general processsing done for the
358 -- enclosing selective accept, timed entry call, or asynchronous select),
359 -- and the null statement is there to carry the sloc of that statement to
360 -- the back-end for trace-based coverage analysis purposes.
362 procedure Extract_Dispatching_Call
364 Call_Ent
: out Entity_Id
;
365 Object
: out Entity_Id
;
366 Actuals
: out List_Id
;
367 Formals
: out List_Id
);
368 -- Given a dispatching call, extract the entity of the name of the call,
369 -- its actual dispatching object, its actual parameters and the formal
370 -- parameters of the overridden interface-level version. If the type of
371 -- the dispatching object is an access type then an explicit dereference
372 -- is returned in Object.
374 procedure Extract_Entry
376 Concval
: out Node_Id
;
378 Index
: out Node_Id
);
379 -- Given an entry call, returns the associated concurrent object, the entry
380 -- name, and the entry family index.
382 function Family_Offset
387 Cap
: Boolean) return Node_Id
;
388 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
389 -- accept statement, or the upper bound in the discrete subtype of an entry
390 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
391 -- type of the entry. If Cap is true, the result is capped according to
392 -- Entry_Family_Bound.
399 Cap
: Boolean) return Node_Id
;
400 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
401 -- family, and handle properly the superflat case. This is equivalent to
402 -- the use of 'Length on the index type, but must use Family_Offset to
403 -- handle properly the case of bounds that depend on discriminants. If
404 -- Cap is true, the result is capped according to Entry_Family_Bound.
406 procedure Find_Enclosing_Context
408 Context
: out Node_Id
;
409 Context_Id
: out Entity_Id
;
410 Context_Decls
: out List_Id
);
411 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
412 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
413 -- nearest enclosing body, block, package, or return statement and return
414 -- its constituents. Context is the enclosing construct, Context_Id is
415 -- the scope of Context_Id and Context_Decls is the declarative list of
418 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
419 -- Given a subprogram identifier, return the entity which is associated
420 -- with the protection entry index in the Protected_Body_Subprogram or
421 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
424 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean;
425 -- Tell whether a given subprogram cannot raise an exception
427 function Is_Potentially_Large_Family
428 (Base_Index
: Entity_Id
;
431 Hi
: Node_Id
) return Boolean;
433 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
434 -- Determine whether Id is a function or a procedure and is marked as a
435 -- private primitive.
437 function Null_Statements
(Stats
: List_Id
) return Boolean;
438 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
439 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
440 -- to still count as null. Returns True for a null sequence. The argument
441 -- is the list of statements from the DO-END sequence.
443 function Parameter_Block_Pack
449 Stmts
: List_Id
) return Entity_Id
;
450 -- Set the components of the generated parameter block with the values
451 -- of the actual parameters. Generate aliased temporaries to capture the
452 -- values for types that are passed by copy. Otherwise generate a reference
453 -- to the actual's value. Return the address of the aggregate block.
455 -- Jnn1 : alias <formal-type1>;
456 -- Jnn1 := <actual1>;
459 -- Jnn1'unchecked_access;
460 -- <actual2>'reference;
463 function Parameter_Block_Unpack
467 Formals
: List_Id
) return List_Id
;
468 -- Retrieve the values of the components from the parameter block and
469 -- assign then to the original actual parameters. Generate:
470 -- <actual1> := P.<formal1>;
472 -- <actualN> := P.<formalN>;
474 function Trivial_Accept_OK
return Boolean;
475 -- If there is no DO-END block for an accept, or if the DO-END block has
476 -- only null statements, then it is possible to do the Rendezvous with much
477 -- less overhead using the Accept_Trivial routine in the run-time library.
478 -- However, this is not always a valid optimization. Whether it is valid or
479 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
480 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
481 -- a rescheduling is required, so this optimization is not allowed. This
482 -- function returns True if the optimization is permitted.
484 -----------------------------
485 -- Actual_Index_Expression --
486 -----------------------------
488 function Actual_Index_Expression
492 Tsk
: Entity_Id
) return Node_Id
494 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
502 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
503 -- Compute difference between bounds of entry family
505 --------------------------
506 -- Actual_Family_Offset --
507 --------------------------
509 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
511 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
512 -- Replace a reference to a discriminant with a selected component
513 -- denoting the discriminant of the target task.
515 -----------------------------
516 -- Actual_Discriminant_Ref --
517 -----------------------------
519 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
520 Typ
: constant Entity_Id
:= Etype
(Bound
);
524 if not Is_Entity_Name
(Bound
)
525 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
527 if Nkind
(Bound
) = N_Attribute_Reference
then
530 B
:= New_Copy_Tree
(Bound
);
535 Make_Selected_Component
(Sloc
,
536 Prefix
=> New_Copy_Tree
(Tsk
),
537 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
539 Analyze_And_Resolve
(B
, Typ
);
543 Make_Attribute_Reference
(Sloc
,
544 Attribute_Name
=> Name_Pos
,
545 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
546 Expressions
=> New_List
(B
));
547 end Actual_Discriminant_Ref
;
549 -- Start of processing for Actual_Family_Offset
553 Make_Op_Subtract
(Sloc
,
554 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
555 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
556 end Actual_Family_Offset
;
558 -- Start of processing for Actual_Index_Expression
561 -- The queues of entries and entry families appear in textual order in
562 -- the associated record. The entry index is computed as the sum of the
563 -- number of queues for all entries that precede the designated one, to
564 -- which is added the index expression, if this expression denotes a
565 -- member of a family.
567 -- The following is a place holder for the count of simple entries
569 Num
:= Make_Integer_Literal
(Sloc
, 1);
571 -- We construct an expression which is a series of addition operations.
572 -- See comments in Entry_Index_Expression, which is identical in
575 if Present
(Index
) then
576 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
582 Actual_Family_Offset
(
583 Make_Attribute_Reference
(Sloc
,
584 Attribute_Name
=> Name_Pos
,
585 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
586 Expressions
=> New_List
(Relocate_Node
(Index
))),
587 Type_Low_Bound
(S
)));
592 -- Now add lengths of preceding entries and entry families
594 Prev
:= First_Entity
(Ttyp
);
595 while Chars
(Prev
) /= Chars
(Ent
)
596 or else (Ekind
(Prev
) /= Ekind
(Ent
))
597 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
599 if Ekind
(Prev
) = E_Entry
then
600 Set_Intval
(Num
, Intval
(Num
) + 1);
602 elsif Ekind
(Prev
) = E_Entry_Family
then
604 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
606 -- The need for the following full view retrieval stems from this
607 -- complex case of nested generics and tasking:
610 -- type Formal_Index is range <>;
613 -- type Index is private;
620 -- type Index is new Formal_Index range 1 .. 10;
623 -- package body Outer is
625 -- entry Fam (Index); -- (2)
628 -- package body Inner is -- (3)
636 -- We are currently building the index expression for the entry
637 -- call "T.E" (1). Part of the expansion must mention the range
638 -- of the discrete type "Index" (2) of entry family "Fam".
640 -- However only the private view of type "Index" is available to
641 -- the inner generic (3) because there was no prior mention of
642 -- the type inside "Inner". This visibility requirement is
643 -- implicit and cannot be detected during the construction of
644 -- the generic trees and needs special handling.
647 and then Is_Private_Type
(S
)
648 and then Present
(Full_View
(S
))
653 Lo
:= Type_Low_Bound
(S
);
654 Hi
:= Type_High_Bound
(S
);
661 Left_Opnd
=> Actual_Family_Offset
(Hi
, Lo
),
662 Right_Opnd
=> Make_Integer_Literal
(Sloc
, 1)));
664 -- Other components are anonymous types to be ignored
674 end Actual_Index_Expression
;
676 --------------------------
677 -- Add_Formal_Renamings --
678 --------------------------
680 procedure Add_Formal_Renamings
686 Ptr
: constant Entity_Id
:=
688 (Next
(First
(Parameter_Specifications
(Spec
))));
689 -- The name of the formal that holds the address of the parameter block
696 Renamed_Formal
: Node_Id
;
699 Formal
:= First_Formal
(Ent
);
700 while Present
(Formal
) loop
701 Comp
:= Entry_Component
(Formal
);
703 Make_Defining_Identifier
(Sloc
(Formal
),
704 Chars
=> Chars
(Formal
));
705 Set_Etype
(New_F
, Etype
(Formal
));
706 Set_Scope
(New_F
, Ent
);
708 -- Now we set debug info needed on New_F even though it does not come
709 -- from source, so that the debugger will get the right information
710 -- for these generated names.
712 Set_Debug_Info_Needed
(New_F
);
714 if Ekind
(Formal
) = E_In_Parameter
then
715 Set_Ekind
(New_F
, E_Constant
);
717 Set_Ekind
(New_F
, E_Variable
);
718 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
721 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
724 Make_Selected_Component
(Loc
,
726 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
727 Make_Identifier
(Loc
, Chars
(Ptr
))),
728 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
731 Build_Renamed_Formal_Declaration
732 (New_F
, Formal
, Comp
, Renamed_Formal
);
734 Append
(Decl
, Decls
);
735 Set_Renamed_Object
(Formal
, New_F
);
736 Next_Formal
(Formal
);
738 end Add_Formal_Renamings
;
740 ------------------------
741 -- Add_Object_Pointer --
742 ------------------------
744 procedure Add_Object_Pointer
746 Conc_Typ
: Entity_Id
;
749 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
754 -- Create the renaming declaration for the Protection object of a
755 -- protected type. _Object is used by Complete_Entry_Body.
756 -- ??? An attempt to make this a renaming was unsuccessful.
758 -- Build the entity for the access type
761 Make_Defining_Identifier
(Loc
,
762 New_External_Name
(Chars
(Rec_Typ
), 'P'));
765 -- _object : poVP := poVP!O;
768 Make_Object_Declaration
(Loc
,
769 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uObject
),
770 Object_Definition
=> New_Occurrence_Of
(Obj_Ptr
, Loc
),
772 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
773 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
774 Prepend_To
(Decls
, Decl
);
777 -- type poVP is access poV;
780 Make_Full_Type_Declaration
(Loc
,
781 Defining_Identifier
=>
784 Make_Access_To_Object_Definition
(Loc
,
785 Subtype_Indication
=>
786 New_Occurrence_Of
(Rec_Typ
, Loc
)));
787 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
788 Prepend_To
(Decls
, Decl
);
789 end Add_Object_Pointer
;
791 -----------------------
792 -- Build_Accept_Body --
793 -----------------------
795 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
796 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
797 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
804 -- At the end of the statement sequence, Complete_Rendezvous is called.
805 -- A label skipping the Complete_Rendezvous, and all other accept
806 -- processing, has already been added for the expansion of requeue
807 -- statements. The Sloc is copied from the last statement since it
808 -- is really part of this last statement.
812 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
813 Insert_Before
(Last
(Statements
(Stats
)), Call
);
816 -- If exception handlers are present, then append Complete_Rendezvous
817 -- calls to the handlers, and construct the required outer block. As
818 -- above, the Sloc is copied from the last statement in the sequence.
820 if Present
(Exception_Handlers
(Stats
)) then
821 Hand
:= First
(Exception_Handlers
(Stats
));
822 while Present
(Hand
) loop
825 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
826 Append
(Call
, Statements
(Hand
));
832 Make_Handled_Sequence_Of_Statements
(Loc
,
833 Statements
=> New_List
(
834 Make_Block_Statement
(Loc
,
835 Handled_Statement_Sequence
=> Stats
)));
841 -- At this stage we know that the new statement sequence does
842 -- not have an exception handler part, so we supply one to call
843 -- Exceptional_Complete_Rendezvous. This handler is
845 -- when all others =>
846 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
848 -- We handle Abort_Signal to make sure that we properly catch the abort
849 -- case and wake up the caller.
851 Ohandle
:= Make_Others_Choice
(Loc
);
852 Set_All_Others
(Ohandle
);
854 Set_Exception_Handlers
(New_S
,
856 Make_Implicit_Exception_Handler
(Loc
,
857 Exception_Choices
=> New_List
(Ohandle
),
859 Statements
=> New_List
(
860 Make_Procedure_Call_Statement
(Sloc
(Stats
),
861 Name
=> New_Occurrence_Of
(
862 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
863 Parameter_Associations
=> New_List
(
864 Make_Function_Call
(Sloc
(Stats
),
867 (RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
869 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
870 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
871 Expand_Exception_Handlers
(New_S
);
873 -- Exceptional_Complete_Rendezvous must be called with abort still
874 -- deferred, which is the case for a "when all others" handler.
877 end Build_Accept_Body
;
879 -----------------------------------
880 -- Build_Activation_Chain_Entity --
881 -----------------------------------
883 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
884 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean;
885 -- Determine whether an extended return statement has activation chain
887 --------------------------
888 -- Has_Activation_Chain --
889 --------------------------
891 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean is
895 Decl
:= First
(Return_Object_Declarations
(Stmt
));
896 while Present
(Decl
) loop
897 if Nkind
(Decl
) = N_Object_Declaration
898 and then Chars
(Defining_Identifier
(Decl
)) = Name_uChain
907 end Has_Activation_Chain
;
912 Context_Id
: Entity_Id
;
915 -- Start of processing for Build_Activation_Chain_Entity
918 -- Activation chain is never used for sequential elaboration policy, see
919 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
921 if Partition_Elaboration_Policy
= 'S' then
925 Find_Enclosing_Context
(N
, Context
, Context_Id
, Decls
);
927 -- If activation chain entity has not been declared already, create one
929 if Nkind
(Context
) = N_Extended_Return_Statement
930 or else No
(Activation_Chain_Entity
(Context
))
932 -- Since extended return statements do not store the entity of the
933 -- chain, examine the return object declarations to avoid creating
936 if Nkind
(Context
) = N_Extended_Return_Statement
937 and then Has_Activation_Chain
(Context
)
943 Loc
: constant Source_Ptr
:= Sloc
(Context
);
948 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
950 -- Note: An extended return statement is not really a task
951 -- activator, but it does have an activation chain on which to
952 -- store the tasks temporarily. On successful return, the tasks
953 -- on this chain are moved to the chain passed in by the caller.
954 -- We do not build an Activation_Chain_Entity for an extended
955 -- return statement, because we do not want to build a call to
956 -- Activate_Tasks. Task activation is the responsibility of the
959 if Nkind
(Context
) /= N_Extended_Return_Statement
then
960 Set_Activation_Chain_Entity
(Context
, Chain
);
964 Make_Object_Declaration
(Loc
,
965 Defining_Identifier
=> Chain
,
966 Aliased_Present
=> True,
968 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
));
970 Prepend_To
(Decls
, Decl
);
972 -- Ensure that _chain appears in the proper scope of the context
974 if Context_Id
/= Current_Scope
then
975 Push_Scope
(Context_Id
);
983 end Build_Activation_Chain_Entity
;
985 ----------------------------
986 -- Build_Barrier_Function --
987 ----------------------------
989 function Build_Barrier_Function
992 Pid
: Node_Id
) return Node_Id
994 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
995 Cond
: constant Node_Id
:= Condition
(Ent_Formals
);
996 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
997 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
998 Op_Decls
: constant List_Id
:= New_List
;
1000 Func_Body
: Node_Id
;
1003 -- Add a declaration for the Protection object, renaming declarations
1004 -- for the discriminals and privals and finally a declaration for the
1005 -- entry family index (if applicable).
1007 Install_Private_Data_Declarations
(Sloc
(N
),
1013 Family
=> Ekind
(Ent
) = E_Entry_Family
);
1015 -- If compiling with -fpreserve-control-flow, make sure we insert an
1016 -- IF statement so that the back-end knows to generate a conditional
1017 -- branch instruction, even if the condition is just the name of a
1018 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1019 -- such redundant IF statements under -fpreserve-control-flow
1020 -- (whether coming from this routine, or directly from source).
1022 if Opt
.Suppress_Control_Flow_Optimizations
then
1024 Make_Implicit_If_Statement
(Cond
,
1026 Then_Statements
=> New_List
(
1027 Make_Simple_Return_Statement
(Loc
,
1028 New_Occurrence_Of
(Standard_True
, Loc
))),
1030 Else_Statements
=> New_List
(
1031 Make_Simple_Return_Statement
(Loc
,
1032 New_Occurrence_Of
(Standard_False
, Loc
))));
1035 Stmt
:= Make_Simple_Return_Statement
(Loc
, Cond
);
1038 -- Note: the condition in the barrier function needs to be properly
1039 -- processed for the C/Fortran boolean possibility, but this happens
1040 -- automatically since the return statement does this normalization.
1043 Make_Subprogram_Body
(Loc
,
1045 Build_Barrier_Function_Specification
(Loc
,
1046 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
1047 Declarations
=> Op_Decls
,
1048 Handled_Statement_Sequence
=>
1049 Make_Handled_Sequence_Of_Statements
(Loc
,
1050 Statements
=> New_List
(Stmt
)));
1051 Set_Is_Entry_Barrier_Function
(Func_Body
);
1054 end Build_Barrier_Function
;
1056 ------------------------------------------
1057 -- Build_Barrier_Function_Specification --
1058 ------------------------------------------
1060 function Build_Barrier_Function_Specification
1062 Def_Id
: Entity_Id
) return Node_Id
1065 Set_Debug_Info_Needed
(Def_Id
);
1068 Make_Function_Specification
(Loc
,
1069 Defining_Unit_Name
=> Def_Id
,
1070 Parameter_Specifications
=> New_List
(
1071 Make_Parameter_Specification
(Loc
,
1072 Defining_Identifier
=>
1073 Make_Defining_Identifier
(Loc
, Name_uO
),
1075 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
1077 Make_Parameter_Specification
(Loc
,
1078 Defining_Identifier
=>
1079 Make_Defining_Identifier
(Loc
, Name_uE
),
1081 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
1083 Result_Definition
=>
1084 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1085 end Build_Barrier_Function_Specification
;
1087 --------------------------
1088 -- Build_Call_With_Task --
1089 --------------------------
1091 function Build_Call_With_Task
1093 E
: Entity_Id
) return Node_Id
1095 Loc
: constant Source_Ptr
:= Sloc
(N
);
1098 Make_Function_Call
(Loc
,
1099 Name
=> New_Occurrence_Of
(E
, Loc
),
1100 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
1101 end Build_Call_With_Task
;
1103 -----------------------------
1104 -- Build_Class_Wide_Master --
1105 -----------------------------
1107 procedure Build_Class_Wide_Master
(Typ
: Entity_Id
) is
1108 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1109 Master_Decl
: Node_Id
;
1110 Master_Id
: Entity_Id
;
1111 Master_Scope
: Entity_Id
;
1113 Related_Node
: Node_Id
;
1117 -- Nothing to do if there is no task hierarchy
1119 if Restriction_Active
(No_Task_Hierarchy
) then
1123 -- Find the declaration that created the access type, which is either a
1124 -- type declaration, or an object declaration with an access definition,
1125 -- in which case the type is anonymous.
1127 if Is_Itype
(Typ
) then
1128 Related_Node
:= Associated_Node_For_Itype
(Typ
);
1130 Related_Node
:= Parent
(Typ
);
1133 Master_Scope
:= Find_Master_Scope
(Typ
);
1135 -- Nothing to do if the master scope already contains a _master entity.
1136 -- The only exception to this is the following scenario:
1139 -- Transient_Scope_1
1142 -- Transient_Scope_2
1145 -- In this case the source scope is marked as having the master entity
1146 -- even though the actual declaration appears inside an inner scope. If
1147 -- the second transient scope requires a _master, it cannot use the one
1148 -- already declared because the entity is not visible.
1150 Name_Id
:= Make_Identifier
(Loc
, Name_uMaster
);
1151 Master_Decl
:= Empty
;
1153 if not Has_Master_Entity
(Master_Scope
)
1154 or else No
(Current_Entity_In_Scope
(Name_Id
))
1157 Set_Has_Master_Entity
(Master_Scope
);
1160 -- _master : constant Integer := Current_Master.all;
1163 Make_Object_Declaration
(Loc
,
1164 Defining_Identifier
=>
1165 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1166 Constant_Present
=> True,
1167 Object_Definition
=>
1168 New_Occurrence_Of
(Standard_Integer
, Loc
),
1170 Make_Explicit_Dereference
(Loc
,
1171 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
1173 Insert_Action
(Find_Hook_Context
(Related_Node
), Master_Decl
);
1174 Analyze
(Master_Decl
);
1176 -- Mark the containing scope as a task master. Masters associated
1177 -- with return statements are already marked at this stage (see
1178 -- Analyze_Subprogram_Body).
1180 if Ekind
(Current_Scope
) /= E_Return_Statement
then
1182 Par
: Node_Id
:= Related_Node
;
1185 while Nkind
(Par
) /= N_Compilation_Unit
loop
1186 Par
:= Parent
(Par
);
1188 -- If we fall off the top, we are at the outer level,
1189 -- and the environment task is our effective master,
1190 -- so nothing to mark.
1192 if Nkind_In
(Par
, N_Block_Statement
,
1196 Set_Is_Task_Master
(Par
);
1206 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(Typ
), 'M'));
1209 -- typeMnn renames _master;
1212 Make_Object_Renaming_Declaration
(Loc
,
1213 Defining_Identifier
=> Master_Id
,
1214 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
1217 -- If the master is declared locally, add the renaming declaration
1218 -- immediately after it, to prevent access-before-elaboration in the
1221 if Present
(Master_Decl
) then
1222 Insert_After
(Master_Decl
, Ren_Decl
);
1226 Insert_Action
(Related_Node
, Ren_Decl
);
1229 Set_Master_Id
(Typ
, Master_Id
);
1230 end Build_Class_Wide_Master
;
1232 ----------------------------
1233 -- Build_Contract_Wrapper --
1234 ----------------------------
1236 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1237 Conc_Typ
: constant Entity_Id
:= Scope
(E
);
1238 Loc
: constant Source_Ptr
:= Sloc
(E
);
1240 procedure Add_Discriminant_Renamings
1241 (Obj_Id
: Entity_Id
;
1243 -- Add renaming declarations for all discriminants of concurrent type
1244 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1245 -- represents the concurrent object.
1247 procedure Add_Matching_Formals
1249 Actuals
: in out List_Id
);
1250 -- Add formal parameters that match those of entry E to list Formals.
1251 -- The routine also adds matching actuals for the new formals to list
1254 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
);
1255 -- Relocate pragma Prag to list To. The routine creates a new list if
1256 -- To does not exist.
1258 --------------------------------
1259 -- Add_Discriminant_Renamings --
1260 --------------------------------
1262 procedure Add_Discriminant_Renamings
1263 (Obj_Id
: Entity_Id
;
1269 -- Inspect the discriminants of the concurrent type and generate a
1270 -- renaming for each one.
1272 if Has_Discriminants
(Conc_Typ
) then
1273 Discr
:= First_Discriminant
(Conc_Typ
);
1274 while Present
(Discr
) loop
1276 Make_Object_Renaming_Declaration
(Loc
,
1277 Defining_Identifier
=>
1278 Make_Defining_Identifier
(Loc
, Chars
(Discr
)),
1280 New_Occurrence_Of
(Etype
(Discr
), Loc
),
1282 Make_Selected_Component
(Loc
,
1283 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1285 Make_Identifier
(Loc
, Chars
(Discr
)))));
1287 Next_Discriminant
(Discr
);
1290 end Add_Discriminant_Renamings
;
1292 --------------------------
1293 -- Add_Matching_Formals --
1294 --------------------------
1296 procedure Add_Matching_Formals
1298 Actuals
: in out List_Id
)
1301 New_Formal
: Entity_Id
;
1304 -- Inspect the formal parameters of the entry and generate a new
1305 -- matching formal with the same name for the wrapper. A reference
1306 -- to the new formal becomes an actual in the entry call.
1308 Formal
:= First_Formal
(E
);
1309 while Present
(Formal
) loop
1310 New_Formal
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1312 Make_Parameter_Specification
(Loc
,
1313 Defining_Identifier
=> New_Formal
,
1314 In_Present
=> In_Present
(Parent
(Formal
)),
1315 Out_Present
=> Out_Present
(Parent
(Formal
)),
1317 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
1319 if No
(Actuals
) then
1320 Actuals
:= New_List
;
1323 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
1324 Next_Formal
(Formal
);
1326 end Add_Matching_Formals
;
1328 ---------------------
1329 -- Transfer_Pragma --
1330 ---------------------
1332 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
) is
1340 New_Prag
:= Relocate_Node
(Prag
);
1342 Set_Analyzed
(New_Prag
, False);
1343 Append
(New_Prag
, To
);
1344 end Transfer_Pragma
;
1348 Items
: constant Node_Id
:= Contract
(E
);
1349 Actuals
: List_Id
:= No_List
;
1352 Decls
: List_Id
:= No_List
;
1354 Has_Pragma
: Boolean := False;
1355 Index_Id
: Entity_Id
;
1358 Wrapper_Id
: Entity_Id
;
1360 -- Start of processing for Build_Contract_Wrapper
1363 -- This routine generates a specialized wrapper for a protected or task
1364 -- entry [family] which implements precondition/postcondition semantics.
1365 -- Preconditions and case guards of contract cases are checked before
1366 -- the protected action or rendezvous takes place. Postconditions and
1367 -- consequences of contract cases are checked after the protected action
1368 -- or rendezvous takes place. The structure of the generated wrapper is
1371 -- procedure Wrapper
1372 -- (Obj_Id : Conc_Typ; -- concurrent object
1373 -- [Index : Index_Typ;] -- index of entry family
1374 -- [Formal_1 : ...; -- parameters of original entry
1377 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1378 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1380 -- <precondition checks>
1381 -- <case guard checks>
1383 -- procedure _Postconditions is
1385 -- <postcondition checks>
1386 -- <consequence checks>
1387 -- end _Postconditions;
1390 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1394 -- Create the wrapper only when the entry has at least one executable
1395 -- contract item such as contract cases, precondition or postcondition.
1397 if Present
(Items
) then
1399 -- Inspect the list of pre/postconditions and transfer all available
1400 -- pragmas to the declarative list of the wrapper.
1402 Prag
:= Pre_Post_Conditions
(Items
);
1403 while Present
(Prag
) loop
1404 if Nam_In
(Pragma_Name
(Prag
), Name_Postcondition
,
1406 and then Is_Checked
(Prag
)
1409 Transfer_Pragma
(Prag
, To
=> Decls
);
1412 Prag
:= Next_Pragma
(Prag
);
1415 -- Inspect the list of test/contract cases and transfer only contract
1416 -- cases pragmas to the declarative part of the wrapper.
1418 Prag
:= Contract_Test_Cases
(Items
);
1419 while Present
(Prag
) loop
1420 if Pragma_Name
(Prag
) = Name_Contract_Cases
1421 and then Is_Checked
(Prag
)
1424 Transfer_Pragma
(Prag
, To
=> Decls
);
1427 Prag
:= Next_Pragma
(Prag
);
1431 -- The entry lacks executable contract items and a wrapper is not needed
1433 if not Has_Pragma
then
1437 -- Create the profile of the wrapper. The first formal parameter is the
1438 -- concurrent object.
1441 Make_Defining_Identifier
(Loc
,
1442 Chars
=> New_External_Name
(Chars
(Conc_Typ
), 'A'));
1444 Formals
:= New_List
(
1445 Make_Parameter_Specification
(Loc
,
1446 Defining_Identifier
=> Obj_Id
,
1447 Out_Present
=> True,
1449 Parameter_Type
=> New_Occurrence_Of
(Conc_Typ
, Loc
)));
1451 -- Construct the call to the original entry. The call will be gradually
1452 -- augmented with an optional entry index and extra parameters.
1455 Make_Selected_Component
(Loc
,
1456 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1457 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1459 -- When creating a wrapper for an entry family, the second formal is the
1462 if Ekind
(E
) = E_Entry_Family
then
1463 Index_Id
:= Make_Defining_Identifier
(Loc
, Name_I
);
1466 Make_Parameter_Specification
(Loc
,
1467 Defining_Identifier
=> Index_Id
,
1469 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1471 -- The call to the original entry becomes an indexed component to
1472 -- accommodate the entry index.
1475 Make_Indexed_Component
(Loc
,
1477 Expressions
=> New_List
(New_Occurrence_Of
(Index_Id
, Loc
)));
1480 -- Add formal parameters to match those of the entry and build actuals
1481 -- for the entry call.
1483 Add_Matching_Formals
(Formals
, Actuals
);
1486 Make_Procedure_Call_Statement
(Loc
,
1488 Parameter_Associations
=> Actuals
);
1490 -- Add renaming declarations for the discriminants of the enclosing type
1491 -- as the various contract items may reference them.
1493 Add_Discriminant_Renamings
(Obj_Id
, Decls
);
1496 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(E
), 'E'));
1497 Set_Contract_Wrapper
(E
, Wrapper_Id
);
1499 -- The wrapper body is analyzed when the enclosing type is frozen
1501 Append_Freeze_Action
(Defining_Entity
(Decl
),
1502 Make_Subprogram_Body
(Loc
,
1504 Make_Procedure_Specification
(Loc
,
1505 Defining_Unit_Name
=> Wrapper_Id
,
1506 Parameter_Specifications
=> Formals
),
1507 Declarations
=> Decls
,
1508 Handled_Statement_Sequence
=>
1509 Make_Handled_Sequence_Of_Statements
(Loc
,
1510 Statements
=> New_List
(Call
))));
1511 end Build_Contract_Wrapper
;
1513 --------------------------------
1514 -- Build_Corresponding_Record --
1515 --------------------------------
1517 function Build_Corresponding_Record
1520 Loc
: Source_Ptr
) return Node_Id
1522 Rec_Ent
: constant Entity_Id
:=
1523 Make_Defining_Identifier
1524 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1527 New_Disc
: Entity_Id
;
1531 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1532 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1533 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1534 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1535 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1536 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1539 -- Use discriminals to create list of discriminants for record, and
1540 -- create new discriminals for use in default expressions, etc. It is
1541 -- worth noting that a task discriminant gives rise to 5 entities;
1543 -- a) The original discriminant.
1544 -- b) The discriminal for use in the task.
1545 -- c) The discriminant of the corresponding record.
1546 -- d) The discriminal for the init proc of the corresponding record.
1547 -- e) The local variable that renames the discriminant in the procedure
1548 -- for the task body.
1550 -- In fact the discriminals b) are used in the renaming declarations
1551 -- for e). See details in einfo (Handling of Discriminants).
1553 if Present
(Discriminant_Specifications
(N
)) then
1555 Disc
:= First_Discriminant
(Ctyp
);
1557 while Present
(Disc
) loop
1558 New_Disc
:= CR_Discriminant
(Disc
);
1561 Make_Discriminant_Specification
(Loc
,
1562 Defining_Identifier
=> New_Disc
,
1563 Discriminant_Type
=>
1564 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1566 New_Copy
(Discriminant_Default_Value
(Disc
))));
1568 Next_Discriminant
(Disc
);
1575 -- Now we can construct the record type declaration. Note that this
1576 -- record is "limited tagged". It is "limited" to reflect the underlying
1577 -- limitedness of the task or protected object that it represents, and
1578 -- ensuring for example that it is properly passed by reference. It is
1579 -- "tagged" to give support to dispatching calls through interfaces. We
1580 -- propagate here the list of interfaces covered by the concurrent type
1581 -- (Ada 2005: AI-345).
1584 Make_Full_Type_Declaration
(Loc
,
1585 Defining_Identifier
=> Rec_Ent
,
1586 Discriminant_Specifications
=> Dlist
,
1588 Make_Record_Definition
(Loc
,
1590 Make_Component_List
(Loc
, Component_Items
=> Cdecls
),
1592 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1593 Interface_List
=> Interface_List
(N
),
1594 Limited_Present
=> True));
1595 end Build_Corresponding_Record
;
1597 ---------------------------------
1598 -- Build_Dispatching_Tag_Check --
1599 ---------------------------------
1601 function Build_Dispatching_Tag_Check
1603 N
: Node_Id
) return Node_Id
1605 Loc
: constant Source_Ptr
:= Sloc
(N
);
1612 New_Occurrence_Of
(K
, Loc
),
1614 New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
1618 New_Occurrence_Of
(K
, Loc
),
1620 New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
)));
1621 end Build_Dispatching_Tag_Check
;
1623 ----------------------------------
1624 -- Build_Entry_Count_Expression --
1625 ----------------------------------
1627 function Build_Entry_Count_Expression
1628 (Concurrent_Type
: Node_Id
;
1629 Component_List
: List_Id
;
1630 Loc
: Source_Ptr
) return Node_Id
1642 -- Count number of non-family entries
1645 Ent
:= First_Entity
(Concurrent_Type
);
1646 while Present
(Ent
) loop
1647 if Ekind
(Ent
) = E_Entry
then
1654 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1656 -- Loop through entry families building the addition nodes
1658 Ent
:= First_Entity
(Concurrent_Type
);
1659 Comp
:= First
(Component_List
);
1660 while Present
(Ent
) loop
1661 if Ekind
(Ent
) = E_Entry_Family
then
1662 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1666 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1667 Hi
:= Type_High_Bound
(Typ
);
1668 Lo
:= Type_Low_Bound
(Typ
);
1669 Large
:= Is_Potentially_Large_Family
1670 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1673 Left_Opnd
=> Ecount
,
1675 Family_Size
(Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1682 end Build_Entry_Count_Expression
;
1684 -----------------------
1685 -- Build_Entry_Names --
1686 -----------------------
1688 procedure Build_Entry_Names
1690 Obj_Typ
: Entity_Id
;
1693 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
1694 Data
: Entity_Id
:= Empty
;
1695 Index
: Entity_Id
:= Empty
;
1696 Typ
: Entity_Id
:= Obj_Typ
;
1698 procedure Build_Entry_Name
(Comp_Id
: Entity_Id
);
1699 -- Given an entry [family], create a static string which denotes the
1700 -- name of Comp_Id and assign it to the underlying data structure which
1701 -- contains the entry names of a concurrent object.
1703 function Object_Reference
return Node_Id
;
1704 -- Return a reference to field _object or _task_id depending on the
1705 -- concurrent object being processed.
1707 ----------------------
1708 -- Build_Entry_Name --
1709 ----------------------
1711 procedure Build_Entry_Name
(Comp_Id
: Entity_Id
) is
1712 function Build_Range
(Def
: Node_Id
) return Node_Id
;
1713 -- Given a discrete subtype definition of an entry family, generate a
1714 -- range node which covers the range of Def's type.
1716 procedure Create_Index_And_Data
;
1717 -- Generate the declarations of variables Index and Data. Subsequent
1718 -- calls do nothing.
1720 function Increment_Index
return Node_Id
;
1721 -- Increment the index used in the assignment of string names to the
1724 function Name_Declaration
(Def_Id
: Entity_Id
) return Node_Id
;
1725 -- Given the name of a temporary variable, create the following
1726 -- declaration for it:
1728 -- Def_Id : aliased constant String := <String_Name_From_Buffer>;
1730 function Set_Entry_Name
(Def_Id
: Entity_Id
) return Node_Id
;
1731 -- Given the name of a temporary variable, place it in the array of
1732 -- string names. Generate:
1734 -- Data (Index) := Def_Id'Unchecked_Access;
1740 function Build_Range
(Def
: Node_Id
) return Node_Id
is
1741 High
: Node_Id
:= Type_High_Bound
(Etype
(Def
));
1742 Low
: Node_Id
:= Type_Low_Bound
(Etype
(Def
));
1745 -- If a bound references a discriminant, generate an identifier
1746 -- with the same name. Resolution will map it to the formals of
1749 if Is_Entity_Name
(Low
)
1750 and then Ekind
(Entity
(Low
)) = E_Discriminant
1753 Make_Selected_Component
(Loc
,
1754 Prefix
=> New_Copy_Tree
(Obj_Ref
),
1755 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Low
)));
1757 Low
:= New_Copy_Tree
(Low
);
1760 if Is_Entity_Name
(High
)
1761 and then Ekind
(Entity
(High
)) = E_Discriminant
1764 Make_Selected_Component
(Loc
,
1765 Prefix
=> New_Copy_Tree
(Obj_Ref
),
1766 Selector_Name
=> Make_Identifier
(Loc
, Chars
(High
)));
1768 High
:= New_Copy_Tree
(High
);
1774 High_Bound
=> High
);
1777 ---------------------------
1778 -- Create_Index_And_Data --
1779 ---------------------------
1781 procedure Create_Index_And_Data
is
1783 if No
(Index
) and then No
(Data
) then
1790 if Is_Protected_Type
(Typ
) then
1791 Count
:= RO_PE_Number_Of_Entries
;
1792 Data_Typ
:= RE_Protected_Entry_Names_Array
;
1794 Count
:= RO_ST_Number_Of_Entries
;
1795 Data_Typ
:= RE_Task_Entry_Names_Array
;
1798 -- Step 1: Generate the declaration of the index variable:
1800 -- Index : Entry_Index := 1;
1802 Index
:= Make_Temporary
(Loc
, 'I');
1805 Make_Object_Declaration
(Loc
,
1806 Defining_Identifier
=> Index
,
1807 Object_Definition
=>
1808 New_Occurrence_Of
(RTE
(RE_Entry_Index
), Loc
),
1809 Expression
=> Make_Integer_Literal
(Loc
, 1)));
1811 -- Step 2: Generate the declaration of an array to house all
1814 -- Size : constant Entry_Index := <Count> (Obj_Ref);
1815 -- Data : aliased <Data_Typ> := (1 .. Size => null);
1817 Size
:= Make_Temporary
(Loc
, 'S');
1820 Make_Object_Declaration
(Loc
,
1821 Defining_Identifier
=> Size
,
1822 Constant_Present
=> True,
1823 Object_Definition
=>
1824 New_Occurrence_Of
(RTE
(RE_Entry_Index
), Loc
),
1826 Make_Function_Call
(Loc
,
1828 New_Occurrence_Of
(RTE
(Count
), Loc
),
1829 Parameter_Associations
=>
1830 New_List
(Object_Reference
))));
1832 Data
:= Make_Temporary
(Loc
, 'A');
1835 Make_Object_Declaration
(Loc
,
1836 Defining_Identifier
=> Data
,
1837 Aliased_Present
=> True,
1838 Object_Definition
=>
1839 New_Occurrence_Of
(RTE
(Data_Typ
), Loc
),
1841 Make_Aggregate
(Loc
,
1842 Component_Associations
=> New_List
(
1843 Make_Component_Association
(Loc
,
1844 Choices
=> New_List
(
1847 Make_Integer_Literal
(Loc
, 1),
1849 New_Occurrence_Of
(Size
, Loc
))),
1850 Expression
=> Make_Null
(Loc
))))));
1853 end Create_Index_And_Data
;
1855 ---------------------
1856 -- Increment_Index --
1857 ---------------------
1859 function Increment_Index
return Node_Id
is
1862 Make_Assignment_Statement
(Loc
,
1863 Name
=> New_Occurrence_Of
(Index
, Loc
),
1866 Left_Opnd
=> New_Occurrence_Of
(Index
, Loc
),
1867 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
1868 end Increment_Index
;
1870 ----------------------
1871 -- Name_Declaration --
1872 ----------------------
1874 function Name_Declaration
(Def_Id
: Entity_Id
) return Node_Id
is
1877 Make_Object_Declaration
(Loc
,
1878 Defining_Identifier
=> Def_Id
,
1879 Aliased_Present
=> True,
1880 Constant_Present
=> True,
1881 Object_Definition
=>
1882 New_Occurrence_Of
(Standard_String
, Loc
),
1884 Make_String_Literal
(Loc
, String_From_Name_Buffer
));
1885 end Name_Declaration
;
1887 --------------------
1888 -- Set_Entry_Name --
1889 --------------------
1891 function Set_Entry_Name
(Def_Id
: Entity_Id
) return Node_Id
is
1894 Make_Assignment_Statement
(Loc
,
1896 Make_Indexed_Component
(Loc
,
1897 Prefix
=> New_Occurrence_Of
(Data
, Loc
),
1898 Expressions
=> New_List
(New_Occurrence_Of
(Index
, Loc
))),
1901 Make_Attribute_Reference
(Loc
,
1902 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
),
1903 Attribute_Name
=> Name_Unchecked_Access
));
1908 Temp_Id
: Entity_Id
;
1911 -- Start of processing for Build_Entry_Name
1914 if Ekind
(Comp_Id
) = E_Entry_Family
then
1915 Subt_Def
:= Discrete_Subtype_Definition
(Parent
(Comp_Id
));
1917 Create_Index_And_Data
;
1919 -- Step 1: Create the string name of the entry family.
1921 -- Temp : aliased constant String := "name ()";
1923 Temp_Id
:= Make_Temporary
(Loc
, 'S');
1924 Get_Name_String
(Chars
(Comp_Id
));
1925 Add_Char_To_Name_Buffer
(' ');
1926 Add_Char_To_Name_Buffer
('(');
1927 Add_Char_To_Name_Buffer
(')');
1929 Append_To
(Stmts
, Name_Declaration
(Temp_Id
));
1932 -- for Member in Family_Low .. Family_High loop
1933 -- Set_Entry_Name (...);
1934 -- Index := Index + 1;
1938 Make_Loop_Statement
(Loc
,
1940 Make_Iteration_Scheme
(Loc
,
1941 Loop_Parameter_Specification
=>
1942 Make_Loop_Parameter_Specification
(Loc
,
1943 Defining_Identifier
=>
1944 Make_Temporary
(Loc
, 'L'),
1945 Discrete_Subtype_Definition
=>
1946 Build_Range
(Subt_Def
))),
1948 Statements
=> New_List
(
1949 Set_Entry_Name
(Temp_Id
),
1951 End_Label
=> Empty
));
1956 Create_Index_And_Data
;
1958 -- Step 1: Create the string name of the entry. Generate:
1959 -- Temp : aliased constant String := "name";
1961 Temp_Id
:= Make_Temporary
(Loc
, 'S');
1962 Get_Name_String
(Chars
(Comp_Id
));
1964 Append_To
(Stmts
, Name_Declaration
(Temp_Id
));
1966 -- Step 2: Associate the string name with the underlying data
1969 Append_To
(Stmts
, Set_Entry_Name
(Temp_Id
));
1970 Append_To
(Stmts
, Increment_Index
);
1972 end Build_Entry_Name
;
1974 ----------------------
1975 -- Object_Reference --
1976 ----------------------
1978 function Object_Reference
return Node_Id
is
1979 Conc_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Typ
);
1984 if Is_Protected_Type
(Typ
) then
1985 Field
:= Name_uObject
;
1987 Field
:= Name_uTask_Id
;
1991 Make_Selected_Component
(Loc
,
1993 Unchecked_Convert_To
(Conc_Typ
, New_Copy_Tree
(Obj_Ref
)),
1994 Selector_Name
=> Make_Identifier
(Loc
, Field
));
1996 if Is_Protected_Type
(Typ
) then
1998 Make_Attribute_Reference
(Loc
,
2000 Attribute_Name
=> Name_Unchecked_Access
);
2004 end Object_Reference
;
2011 -- Start of processing for Build_Entry_Names
2014 -- Retrieve the original concurrent type
2016 if Is_Concurrent_Record_Type
(Typ
) then
2017 Typ
:= Corresponding_Concurrent_Type
(Typ
);
2020 pragma Assert
(Is_Concurrent_Type
(Typ
));
2022 -- Nothing to do if the type has no entries
2024 if not Has_Entries
(Typ
) then
2028 -- Avoid generating entry names for a protected type with only one entry
2030 if Is_Protected_Type
(Typ
)
2031 and then Find_Protection_Type
(Base_Type
(Typ
)) /=
2032 RTE
(RE_Protection_Entries
)
2037 -- Step 1: Populate the array with statically generated strings denoting
2038 -- entries and entry family names.
2040 Comp
:= First_Entity
(Typ
);
2041 while Present
(Comp
) loop
2042 if Comes_From_Source
(Comp
)
2043 and then Ekind_In
(Comp
, E_Entry
, E_Entry_Family
)
2045 Build_Entry_Name
(Comp
);
2051 -- Step 2: Associate the array with the related concurrent object:
2053 -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access);
2055 if Present
(Data
) then
2056 if Is_Protected_Type
(Typ
) then
2057 Proc
:= RO_PE_Set_Entry_Names
;
2059 Proc
:= RO_ST_Set_Entry_Names
;
2063 Make_Procedure_Call_Statement
(Loc
,
2064 Name
=> New_Occurrence_Of
(RTE
(Proc
), Loc
),
2065 Parameter_Associations
=> New_List
(
2067 Make_Attribute_Reference
(Loc
,
2068 Prefix
=> New_Occurrence_Of
(Data
, Loc
),
2069 Attribute_Name
=> Name_Unchecked_Access
))));
2071 end Build_Entry_Names
;
2073 ---------------------------
2074 -- Build_Parameter_Block --
2075 ---------------------------
2077 function Build_Parameter_Block
2081 Decls
: List_Id
) return Entity_Id
2087 Has_Comp
: Boolean := False;
2091 Actual
:= First
(Actuals
);
2093 Formal
:= Defining_Identifier
(First
(Formals
));
2095 while Present
(Actual
) loop
2096 if not Is_Controlling_Actual
(Actual
) then
2099 -- type Ann is access all <actual-type>
2101 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
2102 Set_Is_Param_Block_Component_Type
(Comp_Nam
);
2105 Make_Full_Type_Declaration
(Loc
,
2106 Defining_Identifier
=> Comp_Nam
,
2108 Make_Access_To_Object_Definition
(Loc
,
2109 All_Present
=> True,
2110 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
2111 Subtype_Indication
=>
2112 New_Occurrence_Of
(Etype
(Actual
), Loc
))));
2118 Make_Component_Declaration
(Loc
,
2119 Defining_Identifier
=>
2120 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
2121 Component_Definition
=>
2122 Make_Component_Definition
(Loc
,
2125 Subtype_Indication
=>
2126 New_Occurrence_Of
(Comp_Nam
, Loc
))));
2131 Next_Actual
(Actual
);
2132 Next_Formal_With_Extras
(Formal
);
2135 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
2140 -- type Pnn is record
2145 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
2146 -- the original parameter names and Ann1 .. AnnN are the access to
2150 Make_Full_Type_Declaration
(Loc
,
2151 Defining_Identifier
=>
2154 Make_Record_Definition
(Loc
,
2156 Make_Component_List
(Loc
, Comps
))));
2159 -- type Pnn is null record;
2162 Make_Full_Type_Declaration
(Loc
,
2163 Defining_Identifier
=>
2166 Make_Record_Definition
(Loc
,
2167 Null_Present
=> True,
2168 Component_List
=> Empty
)));
2172 end Build_Parameter_Block
;
2174 --------------------------------------
2175 -- Build_Renamed_Formal_Declaration --
2176 --------------------------------------
2178 function Build_Renamed_Formal_Declaration
2182 Renamed_Formal
: Node_Id
) return Node_Id
2184 Loc
: constant Source_Ptr
:= Sloc
(New_F
);
2188 -- If the formal is a tagged incomplete type, it is already passed
2189 -- by reference, so it is sufficient to rename the pointer component
2190 -- that corresponds to the actual. Otherwise we need to dereference
2191 -- the pointer component to obtain the actual.
2193 if Is_Incomplete_Type
(Etype
(Formal
))
2194 and then Is_Tagged_Type
(Etype
(Formal
))
2197 Make_Object_Renaming_Declaration
(Loc
,
2198 Defining_Identifier
=> New_F
,
2199 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Comp
), Loc
),
2200 Name
=> Renamed_Formal
);
2204 Make_Object_Renaming_Declaration
(Loc
,
2205 Defining_Identifier
=> New_F
,
2206 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Formal
), Loc
),
2208 Make_Explicit_Dereference
(Loc
, Renamed_Formal
));
2212 end Build_Renamed_Formal_Declaration
;
2214 --------------------------
2215 -- Build_Wrapper_Bodies --
2216 --------------------------
2218 procedure Build_Wrapper_Bodies
2223 Rec_Typ
: Entity_Id
;
2225 function Build_Wrapper_Body
2227 Subp_Id
: Entity_Id
;
2228 Obj_Typ
: Entity_Id
;
2229 Formals
: List_Id
) return Node_Id
;
2230 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
2231 -- associated with a protected or task type. Subp_Id is the subprogram
2232 -- name which will be wrapped. Obj_Typ is the type of the new formal
2233 -- parameter which handles dispatching and object notation. Formals are
2234 -- the original formals of Subp_Id which will be explicitly replicated.
2236 ------------------------
2237 -- Build_Wrapper_Body --
2238 ------------------------
2240 function Build_Wrapper_Body
2242 Subp_Id
: Entity_Id
;
2243 Obj_Typ
: Entity_Id
;
2244 Formals
: List_Id
) return Node_Id
2246 Body_Spec
: Node_Id
;
2249 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
2251 -- The subprogram is not overriding or is not a primitive declared
2252 -- between two views.
2254 if No
(Body_Spec
) then
2259 Actuals
: List_Id
:= No_List
;
2261 First_Form
: Node_Id
;
2266 -- Map formals to actuals. Use the list built for the wrapper
2267 -- spec, skipping the object notation parameter.
2269 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
2271 Formal
:= First_Form
;
2274 if Present
(Formal
) then
2275 Actuals
:= New_List
;
2276 while Present
(Formal
) loop
2278 Make_Identifier
(Loc
,
2279 Chars
=> Chars
(Defining_Identifier
(Formal
))));
2284 -- Special processing for primitives declared between a private
2285 -- type and its completion: the wrapper needs a properly typed
2286 -- parameter if the wrapped operation has a controlling first
2287 -- parameter. Note that this might not be the case for a function
2288 -- with a controlling result.
2290 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
2291 if No
(Actuals
) then
2292 Actuals
:= New_List
;
2295 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
2296 Prepend_To
(Actuals
,
2297 Unchecked_Convert_To
2298 (Corresponding_Concurrent_Type
(Obj_Typ
),
2299 Make_Identifier
(Loc
, Name_uO
)));
2302 Prepend_To
(Actuals
,
2303 Make_Identifier
(Loc
,
2304 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
2307 Nam
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2309 -- An access-to-variable object parameter requires an explicit
2310 -- dereference in the unchecked conversion. This case occurs
2311 -- when a protected entry wrapper must override an interface
2312 -- level procedure with interface access as first parameter.
2314 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
2316 if Nkind
(Parameter_Type
(First_Form
)) =
2320 Make_Explicit_Dereference
(Loc
,
2321 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
2323 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
2327 Make_Selected_Component
(Loc
,
2329 Unchecked_Convert_To
2330 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
2331 Selector_Name
=> New_Occurrence_Of
(Subp_Id
, Loc
));
2334 -- Create the subprogram body. For a function, the call to the
2335 -- actual subprogram has to be converted to the corresponding
2336 -- record if it is a controlling result.
2338 if Ekind
(Subp_Id
) = E_Function
then
2344 Make_Function_Call
(Loc
,
2346 Parameter_Associations
=> Actuals
);
2348 if Has_Controlling_Result
(Subp_Id
) then
2350 Unchecked_Convert_To
2351 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
2355 Make_Subprogram_Body
(Loc
,
2356 Specification
=> Body_Spec
,
2357 Declarations
=> Empty_List
,
2358 Handled_Statement_Sequence
=>
2359 Make_Handled_Sequence_Of_Statements
(Loc
,
2360 Statements
=> New_List
(
2361 Make_Simple_Return_Statement
(Loc
, Res
))));
2366 Make_Subprogram_Body
(Loc
,
2367 Specification
=> Body_Spec
,
2368 Declarations
=> Empty_List
,
2369 Handled_Statement_Sequence
=>
2370 Make_Handled_Sequence_Of_Statements
(Loc
,
2371 Statements
=> New_List
(
2372 Make_Procedure_Call_Statement
(Loc
,
2374 Parameter_Associations
=> Actuals
))));
2377 end Build_Wrapper_Body
;
2379 -- Start of processing for Build_Wrapper_Bodies
2382 if Is_Concurrent_Type
(Typ
) then
2383 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2388 -- Generate wrapper bodies for a concurrent type which implements an
2391 if Present
(Interfaces
(Rec_Typ
)) then
2393 Insert_Nod
: Node_Id
;
2395 Prim_Elmt
: Elmt_Id
;
2396 Prim_Decl
: Node_Id
;
2398 Wrap_Body
: Node_Id
;
2399 Wrap_Id
: Entity_Id
;
2404 -- Examine all primitive operations of the corresponding record
2405 -- type, looking for wrapper specs. Generate bodies in order to
2408 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
2409 while Present
(Prim_Elmt
) loop
2410 Prim
:= Node
(Prim_Elmt
);
2412 if (Ekind
(Prim
) = E_Function
2413 or else Ekind
(Prim
) = E_Procedure
)
2414 and then Is_Primitive_Wrapper
(Prim
)
2416 Subp
:= Wrapped_Entity
(Prim
);
2417 Prim_Decl
:= Parent
(Parent
(Prim
));
2420 Build_Wrapper_Body
(Loc
,
2423 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
2424 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
2426 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
2427 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
2429 Insert_After
(Insert_Nod
, Wrap_Body
);
2430 Insert_Nod
:= Wrap_Body
;
2432 Analyze
(Wrap_Body
);
2435 Next_Elmt
(Prim_Elmt
);
2439 end Build_Wrapper_Bodies
;
2441 ------------------------
2442 -- Build_Wrapper_Spec --
2443 ------------------------
2445 function Build_Wrapper_Spec
2446 (Subp_Id
: Entity_Id
;
2447 Obj_Typ
: Entity_Id
;
2448 Formals
: List_Id
) return Node_Id
2450 function Overriding_Possible
2451 (Iface_Op
: Entity_Id
;
2452 Wrapper
: Entity_Id
) return Boolean;
2453 -- Determine whether a primitive operation can be overridden by Wrapper.
2454 -- Iface_Op is the candidate primitive operation of an interface type,
2455 -- Wrapper is the generated entry wrapper.
2457 function Replicate_Formals
2459 Formals
: List_Id
) return List_Id
;
2460 -- An explicit parameter replication is required due to the Is_Entry_
2461 -- Formal flag being set for all the formals of an entry. The explicit
2462 -- replication removes the flag that would otherwise cause a different
2463 -- path of analysis.
2465 -------------------------
2466 -- Overriding_Possible --
2467 -------------------------
2469 function Overriding_Possible
2470 (Iface_Op
: Entity_Id
;
2471 Wrapper
: Entity_Id
) return Boolean
2473 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2474 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2476 function Type_Conformant_Parameters
2477 (Iface_Op_Params
: List_Id
;
2478 Wrapper_Params
: List_Id
) return Boolean;
2479 -- Determine whether the parameters of the generated entry wrapper
2480 -- and those of a primitive operation are type conformant. During
2481 -- this check, the first parameter of the primitive operation is
2482 -- skipped if it is a controlling argument: protected functions
2483 -- may have a controlling result.
2485 --------------------------------
2486 -- Type_Conformant_Parameters --
2487 --------------------------------
2489 function Type_Conformant_Parameters
2490 (Iface_Op_Params
: List_Id
;
2491 Wrapper_Params
: List_Id
) return Boolean
2493 Iface_Op_Param
: Node_Id
;
2494 Iface_Op_Typ
: Entity_Id
;
2495 Wrapper_Param
: Node_Id
;
2496 Wrapper_Typ
: Entity_Id
;
2499 -- Skip the first (controlling) parameter of primitive operation
2501 Iface_Op_Param
:= First
(Iface_Op_Params
);
2503 if Present
(First_Formal
(Iface_Op
))
2504 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2506 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2509 Wrapper_Param
:= First
(Wrapper_Params
);
2510 while Present
(Iface_Op_Param
)
2511 and then Present
(Wrapper_Param
)
2513 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2514 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2516 -- The two parameters must be mode conformant
2518 if not Conforming_Types
2519 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2524 Next
(Iface_Op_Param
);
2525 Next
(Wrapper_Param
);
2528 -- One of the lists is longer than the other
2530 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2535 end Type_Conformant_Parameters
;
2537 -- Start of processing for Overriding_Possible
2540 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2544 -- If an inherited subprogram is implemented by a protected procedure
2545 -- or an entry, then the first parameter of the inherited subprogram
2546 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2548 if Ekind
(Iface_Op
) = E_Procedure
2549 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2552 Obj_Param
: constant Node_Id
:=
2553 First
(Parameter_Specifications
(Iface_Op_Spec
));
2555 if not Out_Present
(Obj_Param
)
2556 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2565 Type_Conformant_Parameters
2566 (Parameter_Specifications
(Iface_Op_Spec
),
2567 Parameter_Specifications
(Wrapper_Spec
));
2568 end Overriding_Possible
;
2570 -----------------------
2571 -- Replicate_Formals --
2572 -----------------------
2574 function Replicate_Formals
2576 Formals
: List_Id
) return List_Id
2578 New_Formals
: constant List_Id
:= New_List
;
2580 Param_Type
: Node_Id
;
2583 Formal
:= First
(Formals
);
2585 -- Skip the object parameter when dealing with primitives declared
2586 -- between two views.
2588 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2589 and then not Has_Controlling_Result
(Subp_Id
)
2591 Formal
:= Next
(Formal
);
2594 while Present
(Formal
) loop
2596 -- Create an explicit copy of the entry parameter
2598 -- When creating the wrapper subprogram for a primitive operation
2599 -- of a protected interface we must construct an equivalent
2600 -- signature to that of the overriding operation. For regular
2601 -- parameters we can just use the type of the formal, but for
2602 -- access to subprogram parameters we need to reanalyze the
2603 -- parameter type to create local entities for the signature of
2604 -- the subprogram type. Using the entities of the overriding
2605 -- subprogram will result in out-of-scope errors in the back-end.
2607 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2608 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2611 New_Occurrence_Of
(Etype
(Parameter_Type
(Formal
)), Loc
);
2614 Append_To
(New_Formals
,
2615 Make_Parameter_Specification
(Loc
,
2616 Defining_Identifier
=>
2617 Make_Defining_Identifier
(Loc
,
2618 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2619 In_Present
=> In_Present
(Formal
),
2620 Out_Present
=> Out_Present
(Formal
),
2621 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
2622 Parameter_Type
=> Param_Type
));
2628 end Replicate_Formals
;
2632 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2633 First_Param
: Node_Id
:= Empty
;
2635 Iface_Elmt
: Elmt_Id
;
2636 Iface_Op
: Entity_Id
;
2637 Iface_Op_Elmt
: Elmt_Id
;
2638 Overridden_Subp
: Entity_Id
;
2640 -- Start of processing for Build_Wrapper_Spec
2643 -- No point in building wrappers for untagged concurrent types
2645 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2647 -- Check if this subprogram has a profile that matches some interface
2650 Check_Synchronized_Overriding
(Subp_Id
, Overridden_Subp
);
2652 if Present
(Overridden_Subp
) then
2654 First
(Parameter_Specifications
(Parent
(Overridden_Subp
)));
2656 -- An entry or a protected procedure can override a routine where the
2657 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2658 -- type. Since the wrapper must have the exact same signature as that of
2659 -- the overridden subprogram, we try to find the overriding candidate
2660 -- and use its controlling formal.
2662 -- Check every implemented interface
2664 elsif Present
(Interfaces
(Obj_Typ
)) then
2665 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2666 Search
: while Present
(Iface_Elmt
) loop
2667 Iface
:= Node
(Iface_Elmt
);
2669 -- Check every interface primitive
2671 if Present
(Primitive_Operations
(Iface
)) then
2672 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2673 while Present
(Iface_Op_Elmt
) loop
2674 Iface_Op
:= Node
(Iface_Op_Elmt
);
2676 -- Ignore predefined primitives
2678 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2679 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2681 -- The current primitive operation can be overridden by
2682 -- the generated entry wrapper.
2684 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2686 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2692 Next_Elmt
(Iface_Op_Elmt
);
2696 Next_Elmt
(Iface_Elmt
);
2700 -- Do not generate the wrapper if no interface primitive is covered by
2701 -- the subprogram and it is not a primitive declared between two views
2702 -- (see Process_Full_View).
2705 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2711 Wrapper_Id
: constant Entity_Id
:=
2712 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2713 New_Formals
: List_Id
;
2714 Obj_Param
: Node_Id
;
2715 Obj_Param_Typ
: Entity_Id
;
2718 -- Minimum decoration is needed to catch the entity in
2719 -- Sem_Ch6.Override_Dispatching_Operation.
2721 if Ekind
(Subp_Id
) = E_Function
then
2722 Set_Ekind
(Wrapper_Id
, E_Function
);
2724 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2727 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2728 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2729 Set_Is_Private_Primitive
(Wrapper_Id
,
2730 Is_Private_Primitive_Subprogram
(Subp_Id
));
2732 -- Process the formals
2734 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2736 -- A function with a controlling result and no first controlling
2737 -- formal needs no additional parameter.
2739 if Has_Controlling_Result
(Subp_Id
)
2741 (No
(First_Formal
(Subp_Id
))
2742 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2746 -- Routine Subp_Id has been found to override an interface primitive.
2747 -- If the interface operation has an access parameter, create a copy
2748 -- of it, with the same null exclusion indicator if present.
2750 elsif Present
(First_Param
) then
2751 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2753 Make_Access_Definition
(Loc
,
2755 New_Occurrence_Of
(Obj_Typ
, Loc
),
2756 Null_Exclusion_Present
=>
2757 Null_Exclusion_Present
(Parameter_Type
(First_Param
)),
2759 Constant_Present
(Parameter_Type
(First_Param
)));
2761 Obj_Param_Typ
:= New_Occurrence_Of
(Obj_Typ
, Loc
);
2765 Make_Parameter_Specification
(Loc
,
2766 Defining_Identifier
=>
2767 Make_Defining_Identifier
(Loc
,
2769 In_Present
=> In_Present
(First_Param
),
2770 Out_Present
=> Out_Present
(First_Param
),
2771 Parameter_Type
=> Obj_Param_Typ
);
2773 Prepend_To
(New_Formals
, Obj_Param
);
2775 -- If we are dealing with a primitive declared between two views,
2776 -- implemented by a synchronized operation, we need to create
2777 -- a default parameter. The mode of the parameter must match that
2778 -- of the primitive operation.
2781 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2784 Make_Parameter_Specification
(Loc
,
2785 Defining_Identifier
=>
2786 Make_Defining_Identifier
(Loc
, Name_uO
),
2788 In_Present
(Parent
(First_Entity
(Subp_Id
))),
2789 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2790 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2792 Prepend_To
(New_Formals
, Obj_Param
);
2795 -- Build the final spec. If it is a function with a controlling
2796 -- result, it is a primitive operation of the corresponding
2797 -- record type, so mark the spec accordingly.
2799 if Ekind
(Subp_Id
) = E_Function
then
2804 if Has_Controlling_Result
(Subp_Id
) then
2807 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2809 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2813 Make_Function_Specification
(Loc
,
2814 Defining_Unit_Name
=> Wrapper_Id
,
2815 Parameter_Specifications
=> New_Formals
,
2816 Result_Definition
=> Res_Def
);
2820 Make_Procedure_Specification
(Loc
,
2821 Defining_Unit_Name
=> Wrapper_Id
,
2822 Parameter_Specifications
=> New_Formals
);
2825 end Build_Wrapper_Spec
;
2827 -------------------------
2828 -- Build_Wrapper_Specs --
2829 -------------------------
2831 procedure Build_Wrapper_Specs
2837 Rec_Typ
: Entity_Id
;
2838 procedure Scan_Declarations
(L
: List_Id
);
2839 -- Common processing for visible and private declarations
2840 -- of a protected type.
2842 procedure Scan_Declarations
(L
: List_Id
) is
2844 Wrap_Decl
: Node_Id
;
2845 Wrap_Spec
: Node_Id
;
2853 while Present
(Decl
) loop
2856 if Nkind
(Decl
) = N_Entry_Declaration
2857 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2861 (Subp_Id
=> Defining_Identifier
(Decl
),
2863 Formals
=> Parameter_Specifications
(Decl
));
2865 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2868 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2871 Parameter_Specifications
(Specification
(Decl
)));
2874 if Present
(Wrap_Spec
) then
2876 Make_Subprogram_Declaration
(Loc
,
2877 Specification
=> Wrap_Spec
);
2879 Insert_After
(N
, Wrap_Decl
);
2882 Analyze
(Wrap_Decl
);
2887 end Scan_Declarations
;
2889 -- start of processing for Build_Wrapper_Specs
2892 if Is_Protected_Type
(Typ
) then
2893 Def
:= Protected_Definition
(Parent
(Typ
));
2894 else pragma Assert
(Is_Task_Type
(Typ
));
2895 Def
:= Task_Definition
(Parent
(Typ
));
2898 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2900 -- Generate wrapper specs for a concurrent type which implements an
2901 -- interface. Operations in both the visible and private parts may
2902 -- implement progenitor operations.
2904 if Present
(Interfaces
(Rec_Typ
)) and then Present
(Def
) then
2905 Scan_Declarations
(Visible_Declarations
(Def
));
2906 Scan_Declarations
(Private_Declarations
(Def
));
2908 end Build_Wrapper_Specs
;
2910 ---------------------------
2911 -- Build_Find_Body_Index --
2912 ---------------------------
2914 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2915 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2918 Has_F
: Boolean := False;
2920 If_St
: Node_Id
:= Empty
;
2923 Decls
: List_Id
:= New_List
;
2926 Siz
: Node_Id
:= Empty
;
2928 procedure Add_If_Clause
(Expr
: Node_Id
);
2929 -- Add test for range of current entry
2931 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2932 -- If a bound of an entry is given by a discriminant, retrieve the
2933 -- actual value of the discriminant from the enclosing object.
2939 procedure Add_If_Clause
(Expr
: Node_Id
) is
2941 Stats
: constant List_Id
:=
2943 Make_Simple_Return_Statement
(Loc
,
2944 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2947 -- Index for current entry body
2951 -- Compute total length of entry queues so far
2959 Right_Opnd
=> Expr
);
2964 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2967 -- Map entry queue indexes in the range of the current family
2968 -- into the current index, that designates the entry body.
2972 Make_Implicit_If_Statement
(Typ
,
2974 Then_Statements
=> Stats
,
2975 Elsif_Parts
=> New_List
);
2979 Append_To
(Elsif_Parts
(If_St
),
2980 Make_Elsif_Part
(Loc
,
2982 Then_Statements
=> Stats
));
2986 ------------------------------
2987 -- Convert_Discriminant_Ref --
2988 ------------------------------
2990 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2994 if Is_Entity_Name
(Bound
)
2995 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2998 Make_Selected_Component
(Loc
,
3000 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
3001 Make_Explicit_Dereference
(Loc
,
3002 Make_Identifier
(Loc
, Name_uObject
))),
3003 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
3004 Set_Etype
(B
, Etype
(Entity
(Bound
)));
3006 B
:= New_Copy_Tree
(Bound
);
3010 end Convert_Discriminant_Ref
;
3012 -- Start of processing for Build_Find_Body_Index
3015 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
3017 Ent
:= First_Entity
(Typ
);
3018 while Present
(Ent
) loop
3019 if Ekind
(Ent
) = E_Entry_Family
then
3029 -- If the protected type has no entry families, there is a one-one
3030 -- correspondence between entry queue and entry body.
3033 Make_Simple_Return_Statement
(Loc
,
3034 Expression
=> Make_Identifier
(Loc
, Name_uE
));
3037 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
3040 -- if E <= l1 then return 1;
3041 -- elsif E <= l1 + l2 then return 2;
3046 Ent
:= First_Entity
(Typ
);
3048 Add_Object_Pointer
(Loc
, Typ
, Decls
);
3050 while Present
(Ent
) loop
3051 if Ekind
(Ent
) = E_Entry
then
3052 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
3054 elsif Ekind
(Ent
) = E_Entry_Family
then
3055 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
3056 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
3057 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
3058 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
3067 Make_Simple_Return_Statement
(Loc
,
3068 Expression
=> Make_Integer_Literal
(Loc
, 1));
3070 elsif Nkind
(Ret
) = N_If_Statement
then
3072 -- Ranges are in increasing order, so last one doesn't need guard
3075 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
3078 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
3084 Make_Subprogram_Body
(Loc
,
3085 Specification
=> Spec
,
3086 Declarations
=> Decls
,
3087 Handled_Statement_Sequence
=>
3088 Make_Handled_Sequence_Of_Statements
(Loc
,
3089 Statements
=> New_List
(Ret
)));
3090 end Build_Find_Body_Index
;
3092 --------------------------------
3093 -- Build_Find_Body_Index_Spec --
3094 --------------------------------
3096 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
3097 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3098 Id
: constant Entity_Id
:=
3099 Make_Defining_Identifier
(Loc
,
3100 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
3101 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
3102 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
3106 Make_Function_Specification
(Loc
,
3107 Defining_Unit_Name
=> Id
,
3108 Parameter_Specifications
=> New_List
(
3109 Make_Parameter_Specification
(Loc
,
3110 Defining_Identifier
=> Parm1
,
3112 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3114 Make_Parameter_Specification
(Loc
,
3115 Defining_Identifier
=> Parm2
,
3117 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
3119 Result_Definition
=> New_Occurrence_Of
(
3120 RTE
(RE_Protected_Entry_Index
), Loc
));
3121 end Build_Find_Body_Index_Spec
;
3123 -----------------------------------------------
3124 -- Build_Lock_Free_Protected_Subprogram_Body --
3125 -----------------------------------------------
3127 function Build_Lock_Free_Protected_Subprogram_Body
3130 Unprot_Spec
: Node_Id
) return Node_Id
3132 Actuals
: constant List_Id
:= New_List
;
3133 Loc
: constant Source_Ptr
:= Sloc
(N
);
3134 Spec
: constant Node_Id
:= Specification
(N
);
3135 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
3137 Prot_Spec
: Node_Id
;
3141 -- Create the protected version of the body
3144 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
3146 -- Build the actual parameters which appear in the call to the
3147 -- unprotected version of the body.
3149 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
3150 while Present
(Formal
) loop
3152 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
3157 -- Function case, generate:
3158 -- return <Unprot_Func_Call>;
3160 if Nkind
(Spec
) = N_Function_Specification
then
3162 Make_Simple_Return_Statement
(Loc
,
3164 Make_Function_Call
(Loc
,
3166 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
3167 Parameter_Associations
=> Actuals
));
3169 -- Procedure case, call the unprotected version
3173 Make_Procedure_Call_Statement
(Loc
,
3175 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
3176 Parameter_Associations
=> Actuals
);
3180 Make_Subprogram_Body
(Loc
,
3181 Declarations
=> Empty_List
,
3182 Specification
=> Prot_Spec
,
3183 Handled_Statement_Sequence
=>
3184 Make_Handled_Sequence_Of_Statements
(Loc
,
3185 Statements
=> New_List
(Stmt
)));
3186 end Build_Lock_Free_Protected_Subprogram_Body
;
3188 -------------------------------------------------
3189 -- Build_Lock_Free_Unprotected_Subprogram_Body --
3190 -------------------------------------------------
3192 -- Procedures which meet the lock-free implementation requirements and
3193 -- reference a unique scalar component Comp are expanded in the following
3196 -- procedure P (...) is
3197 -- Expected_Comp : constant Comp_Type :=
3199 -- (System.Atomic_Primitives.Lock_Free_Read_N
3200 -- (_Object.Comp'Address));
3204 -- <original declarations before the object renaming declaration
3207 -- Desired_Comp : Comp_Type := Expected_Comp;
3208 -- Comp : Comp_Type renames Desired_Comp;
3210 -- <original delarations after the object renaming declaration
3214 -- <original statements>
3215 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3216 -- (_Object.Comp'Address,
3217 -- Interfaces.Unsigned_N (Expected_Comp),
3218 -- Interfaces.Unsigned_N (Desired_Comp));
3223 -- Each return and raise statement of P is transformed into an atomic
3226 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3227 -- (_Object.Comp'Address,
3228 -- Interfaces.Unsigned_N (Expected_Comp),
3229 -- Interfaces.Unsigned_N (Desired_Comp));
3231 -- <original statement>
3236 -- Functions which meet the lock-free implementation requirements and
3237 -- reference a unique scalar component Comp are expanded in the following
3240 -- function F (...) return ... is
3241 -- <original declarations before the object renaming declaration
3244 -- Expected_Comp : constant Comp_Type :=
3246 -- (System.Atomic_Primitives.Lock_Free_Read_N
3247 -- (_Object.Comp'Address));
3248 -- Comp : Comp_Type renames Expected_Comp;
3250 -- <original delarations after the object renaming declaration of
3254 -- <original statements>
3257 function Build_Lock_Free_Unprotected_Subprogram_Body
3259 Prot_Typ
: Node_Id
) return Node_Id
3261 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
3262 -- Subprograms which meet the lock-free implementation criteria are
3263 -- allowed to reference only one unique component. Return the prival
3264 -- of the said component.
3266 --------------------------
3267 -- Referenced_Component --
3268 --------------------------
3270 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
3273 Source_Comp
: Entity_Id
:= Empty
;
3276 -- Find the unique source component which N references in its
3279 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
3281 Element
: Lock_Free_Subprogram
renames
3282 Lock_Free_Subprogram_Table
.Table
(Index
);
3284 if Element
.Sub_Body
= N
then
3285 Source_Comp
:= Element
.Comp_Id
;
3291 if No
(Source_Comp
) then
3295 -- Find the prival which corresponds to the source component within
3296 -- the declarations of N.
3298 Decl
:= First
(Declarations
(N
));
3299 while Present
(Decl
) loop
3301 -- Privals appear as object renamings
3303 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
3304 Comp
:= Defining_Identifier
(Decl
);
3306 if Present
(Prival_Link
(Comp
))
3307 and then Prival_Link
(Comp
) = Source_Comp
3317 end Referenced_Component
;
3321 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
3322 Loc
: constant Source_Ptr
:= Sloc
(N
);
3323 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
3324 Decls
: List_Id
:= Declarations
(N
);
3326 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
3329 -- Add renamings for the protection object, discriminals, privals, and
3330 -- the entry index constant for use by debugger.
3332 Debug_Private_Data_Declarations
(Decls
);
3334 -- Perform the lock-free expansion when the subprogram references a
3335 -- protected component.
3337 if Present
(Comp
) then
3338 Protected_Component_Ref
: declare
3339 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3340 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
3341 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
3343 Is_Procedure
: constant Boolean :=
3344 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
3345 -- Indicates if N is a protected procedure body
3347 Block_Decls
: List_Id
;
3348 Try_Write
: Entity_Id
;
3349 Desired_Comp
: Entity_Id
;
3352 Label_Id
: Entity_Id
:= Empty
;
3354 Expected_Comp
: Entity_Id
;
3357 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
3359 Unsigned
: Entity_Id
;
3361 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
3362 -- Transform a single node if it is a return statement, a raise
3363 -- statement or a reference to Comp.
3365 procedure Process_Stmts
(Stmts
: List_Id
);
3366 -- Given a statement sequence Stmts, wrap any return or raise
3367 -- statements in the following manner:
3369 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3370 -- (_Object.Comp'Address,
3371 -- Interfaces.Unsigned_N (Expected_Comp),
3372 -- Interfaces.Unsigned_N (Desired_Comp))
3383 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3385 procedure Wrap_Statement
(Stmt
: Node_Id
);
3386 -- Wrap an arbitrary statement inside an if statement where the
3387 -- condition does an atomic check on the state of the object.
3389 --------------------
3390 -- Wrap_Statement --
3391 --------------------
3393 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3395 -- The first time through, create the declaration of a label
3396 -- which is used to skip the remainder of source statements
3397 -- if the state of the object has changed.
3399 if No
(Label_Id
) then
3401 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3402 Set_Entity
(Label_Id
,
3403 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3407 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3408 -- (_Object.Comp'Address,
3409 -- Interfaces.Unsigned_N (Expected_Comp),
3410 -- Interfaces.Unsigned_N (Desired_Comp))
3418 Make_Implicit_If_Statement
(N
,
3420 Make_Function_Call
(Loc
,
3422 New_Occurrence_Of
(Try_Write
, Loc
),
3423 Parameter_Associations
=> New_List
(
3424 Make_Attribute_Reference
(Loc
,
3425 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3426 Attribute_Name
=> Name_Address
),
3428 Unchecked_Convert_To
(Unsigned
,
3429 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3431 Unchecked_Convert_To
(Unsigned
,
3432 New_Occurrence_Of
(Desired_Comp
, Loc
)))),
3434 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3436 Else_Statements
=> New_List
(
3437 Make_Goto_Statement
(Loc
,
3439 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3442 -- Start of processing for Process_Node
3445 -- Wrap each return and raise statement that appear inside a
3446 -- procedure. Skip the last return statement which is added by
3447 -- default since it is transformed into an exit statement.
3450 and then ((Nkind
(N
) = N_Simple_Return_Statement
3451 and then N
/= Last
(Stmts
))
3452 or else Nkind
(N
) = N_Extended_Return_Statement
3453 or else (Nkind_In
(N
, N_Raise_Constraint_Error
,
3454 N_Raise_Program_Error
,
3456 N_Raise_Storage_Error
)
3457 and then Comes_From_Source
(N
)))
3465 Set_Analyzed
(N
, False);
3470 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3476 procedure Process_Stmts
(Stmts
: List_Id
) is
3479 Stmt
:= First
(Stmts
);
3480 while Present
(Stmt
) loop
3481 Process_Nodes
(Stmt
);
3486 -- Start of processing for Protected_Component_Ref
3489 -- Get the type size
3491 if Known_Static_Esize
(Comp_Type
) then
3492 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3494 -- If the Esize (Object_Size) is unknown at compile time, look at
3495 -- the RM_Size (Value_Size) since it may have been set by an
3496 -- explicit representation clause.
3498 elsif Known_Static_RM_Size
(Comp_Type
) then
3499 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3501 -- Should not happen since this has already been checked in
3502 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3505 raise Program_Error
;
3508 -- Retrieve all relevant atomic routines and types
3512 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3513 Read
:= RTE
(RE_Lock_Free_Read_8
);
3514 Unsigned
:= RTE
(RE_Uint8
);
3517 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3518 Read
:= RTE
(RE_Lock_Free_Read_16
);
3519 Unsigned
:= RTE
(RE_Uint16
);
3522 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3523 Read
:= RTE
(RE_Lock_Free_Read_32
);
3524 Unsigned
:= RTE
(RE_Uint32
);
3527 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3528 Read
:= RTE
(RE_Lock_Free_Read_64
);
3529 Unsigned
:= RTE
(RE_Uint64
);
3532 raise Program_Error
;
3536 -- Expected_Comp : constant Comp_Type :=
3538 -- (System.Atomic_Primitives.Lock_Free_Read_N
3539 -- (_Object.Comp'Address));
3542 Make_Defining_Identifier
(Loc
,
3543 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3546 Make_Object_Declaration
(Loc
,
3547 Defining_Identifier
=> Expected_Comp
,
3548 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3549 Constant_Present
=> True,
3551 Unchecked_Convert_To
(Comp_Type
,
3552 Make_Function_Call
(Loc
,
3553 Name
=> New_Occurrence_Of
(Read
, Loc
),
3554 Parameter_Associations
=> New_List
(
3555 Make_Attribute_Reference
(Loc
,
3556 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3557 Attribute_Name
=> Name_Address
)))));
3559 -- Protected procedures
3561 if Is_Procedure
then
3562 -- Move the original declarations inside the generated block
3564 Block_Decls
:= Decls
;
3566 -- Reset the declarations list of the protected procedure to
3567 -- contain only Decl.
3569 Decls
:= New_List
(Decl
);
3572 -- Desired_Comp : Comp_Type := Expected_Comp;
3575 Make_Defining_Identifier
(Loc
,
3576 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3578 -- Insert the declarations of Expected_Comp and Desired_Comp in
3579 -- the block declarations right before the renaming of the
3580 -- protected component.
3582 Insert_Before
(Comp_Decl
,
3583 Make_Object_Declaration
(Loc
,
3584 Defining_Identifier
=> Desired_Comp
,
3585 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3587 New_Occurrence_Of
(Expected_Comp
, Loc
)));
3589 -- Protected function
3592 Desired_Comp
:= Expected_Comp
;
3594 -- Insert the declaration of Expected_Comp in the function
3595 -- declarations right before the renaming of the protected
3598 Insert_Before
(Comp_Decl
, Decl
);
3601 -- Rewrite the protected component renaming declaration to be a
3602 -- renaming of Desired_Comp.
3605 -- Comp : Comp_Type renames Desired_Comp;
3608 Make_Object_Renaming_Declaration
(Loc
,
3609 Defining_Identifier
=>
3610 Defining_Identifier
(Comp_Decl
),
3612 New_Occurrence_Of
(Comp_Type
, Loc
),
3614 New_Occurrence_Of
(Desired_Comp
, Loc
)));
3616 -- Wrap any return or raise statements in Stmts in same the manner
3617 -- described in Process_Stmts.
3619 Process_Stmts
(Stmts
);
3622 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3623 -- (_Object.Comp'Address,
3624 -- Interfaces.Unsigned_N (Expected_Comp),
3625 -- Interfaces.Unsigned_N (Desired_Comp))
3627 if Is_Procedure
then
3629 Make_Exit_Statement
(Loc
,
3631 Make_Function_Call
(Loc
,
3633 New_Occurrence_Of
(Try_Write
, Loc
),
3634 Parameter_Associations
=> New_List
(
3635 Make_Attribute_Reference
(Loc
,
3636 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3637 Attribute_Name
=> Name_Address
),
3639 Unchecked_Convert_To
(Unsigned
,
3640 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3642 Unchecked_Convert_To
(Unsigned
,
3643 New_Occurrence_Of
(Desired_Comp
, Loc
)))));
3645 -- Small optimization: transform the default return statement
3646 -- of a procedure into the atomic exit statement.
3648 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3649 Rewrite
(Last
(Stmts
), Stmt
);
3651 Append_To
(Stmts
, Stmt
);
3655 -- Create the declaration of the label used to skip the rest of
3656 -- the source statements when the object state changes.
3658 if Present
(Label_Id
) then
3659 Label
:= Make_Label
(Loc
, Label_Id
);
3661 Make_Implicit_Label_Declaration
(Loc
,
3662 Defining_Identifier
=> Entity
(Label_Id
),
3663 Label_Construct
=> Label
));
3664 Append_To
(Stmts
, Label
);
3676 if Is_Procedure
then
3679 Make_Loop_Statement
(Loc
,
3680 Statements
=> New_List
(
3681 Make_Block_Statement
(Loc
,
3682 Declarations
=> Block_Decls
,
3683 Handled_Statement_Sequence
=>
3684 Make_Handled_Sequence_Of_Statements
(Loc
,
3685 Statements
=> Stmts
))),
3686 End_Label
=> Empty
));
3690 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3691 end Protected_Component_Ref
;
3694 -- Make an unprotected version of the subprogram for use within the same
3695 -- object, with new name and extra parameter representing the object.
3698 Make_Subprogram_Body
(Loc
,
3700 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3701 Declarations
=> Decls
,
3702 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3703 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3705 -------------------------
3706 -- Build_Master_Entity --
3707 -------------------------
3709 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3710 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3712 Context_Id
: Entity_Id
;
3718 if Is_Itype
(Obj_Or_Typ
) then
3719 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3721 Par
:= Parent
(Obj_Or_Typ
);
3724 -- When creating a master for a record component which is either a task
3725 -- or access-to-task, the enclosing record is the master scope and the
3726 -- proper insertion point is the component list.
3728 if Is_Record_Type
(Current_Scope
) then
3730 Context_Id
:= Current_Scope
;
3731 Decls
:= List_Containing
(Context
);
3733 -- Default case for object declarations and access types. Note that the
3734 -- context is updated to the nearest enclosing body, block, package, or
3735 -- return statement.
3738 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3741 -- Do not create a master if one already exists or there is no task
3744 if Has_Master_Entity
(Context_Id
)
3745 or else Restriction_Active
(No_Task_Hierarchy
)
3750 -- Create a master, generate:
3751 -- _Master : constant Master_Id := Current_Master.all;
3754 Make_Object_Declaration
(Loc
,
3755 Defining_Identifier
=>
3756 Make_Defining_Identifier
(Loc
, Name_uMaster
),
3757 Constant_Present
=> True,
3758 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3760 Make_Explicit_Dereference
(Loc
,
3761 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
3763 -- The master is inserted at the start of the declarative list of the
3766 Prepend_To
(Decls
, Decl
);
3768 -- In certain cases where transient scopes are involved, the immediate
3769 -- scope is not always the proper master scope. Ensure that the master
3770 -- declaration and entity appear in the same context.
3772 if Context_Id
/= Current_Scope
then
3773 Push_Scope
(Context_Id
);
3780 -- Mark the enclosing scope and its associated construct as being task
3783 Set_Has_Master_Entity
(Context_Id
);
3785 while Present
(Context
)
3786 and then Nkind
(Context
) /= N_Compilation_Unit
3788 if Nkind_In
(Context
, N_Block_Statement
,
3792 Set_Is_Task_Master
(Context
);
3795 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3796 Context
:= Corresponding_Stub
(Parent
(Context
));
3799 Context
:= Parent
(Context
);
3801 end Build_Master_Entity
;
3803 ---------------------------
3804 -- Build_Master_Renaming --
3805 ---------------------------
3807 procedure Build_Master_Renaming
3808 (Ptr_Typ
: Entity_Id
;
3809 Ins_Nod
: Node_Id
:= Empty
)
3811 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3813 Master_Decl
: Node_Id
;
3814 Master_Id
: Entity_Id
;
3817 -- Nothing to do if there is no task hierarchy
3819 if Restriction_Active
(No_Task_Hierarchy
) then
3823 -- Determine the proper context to insert the master renaming
3825 if Present
(Ins_Nod
) then
3827 elsif Is_Itype
(Ptr_Typ
) then
3828 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3830 Context
:= Parent
(Ptr_Typ
);
3834 -- <Ptr_Typ>M : Master_Id renames _Master;
3837 Make_Defining_Identifier
(Loc
,
3838 New_External_Name
(Chars
(Ptr_Typ
), 'M'));
3841 Make_Object_Renaming_Declaration
(Loc
,
3842 Defining_Identifier
=> Master_Id
,
3843 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3844 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3846 Insert_Action
(Context
, Master_Decl
);
3848 -- The renamed master now services the access type
3850 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3851 end Build_Master_Renaming
;
3853 -----------------------------------------
3854 -- Build_Private_Protected_Declaration --
3855 -----------------------------------------
3857 function Build_Private_Protected_Declaration
3858 (N
: Node_Id
) return Entity_Id
3860 Loc
: constant Source_Ptr
:= Sloc
(N
);
3861 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3866 Spec_Id
: Entity_Id
;
3869 Formal
:= First_Formal
(Body_Id
);
3871 -- The protected operation always has at least one formal, namely the
3872 -- object itself, but it is only placed in the parameter list if
3873 -- expansion is enabled.
3875 if Present
(Formal
) or else Expander_Active
then
3876 Plist
:= Copy_Parameter_List
(Body_Id
);
3881 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
3883 Make_Procedure_Specification
(Loc
,
3884 Defining_Unit_Name
=>
3885 Make_Defining_Identifier
(Sloc
(Body_Id
),
3886 Chars
=> Chars
(Body_Id
)),
3887 Parameter_Specifications
=>
3891 Make_Function_Specification
(Loc
,
3892 Defining_Unit_Name
=>
3893 Make_Defining_Identifier
(Sloc
(Body_Id
),
3894 Chars
=> Chars
(Body_Id
)),
3895 Parameter_Specifications
=> Plist
,
3896 Result_Definition
=>
3897 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
3900 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> New_Spec
);
3901 Insert_Before
(N
, Decl
);
3902 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
3904 -- Indicate that the entity comes from source, to ensure that cross-
3905 -- reference information is properly generated. The body itself is
3906 -- rewritten during expansion, and the body entity will not appear in
3907 -- calls to the operation.
3909 Set_Comes_From_Source
(Spec_Id
, True);
3911 Set_Has_Completion
(Spec_Id
);
3912 Set_Convention
(Spec_Id
, Convention_Protected
);
3914 end Build_Private_Protected_Declaration
;
3916 ---------------------------
3917 -- Build_Protected_Entry --
3918 ---------------------------
3920 function Build_Protected_Entry
3923 Pid
: Node_Id
) return Node_Id
3925 Bod_Decls
: constant List_Id
:= New_List
;
3926 Decls
: constant List_Id
:= Declarations
(N
);
3927 End_Lab
: constant Node_Id
:=
3928 End_Label
(Handled_Statement_Sequence
(N
));
3929 End_Loc
: constant Source_Ptr
:=
3930 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3931 -- Used for the generated call to Complete_Entry_Body
3933 Loc
: constant Source_Ptr
:= Sloc
(N
);
3937 Bod_Stmts
: List_Id
;
3941 EH_Loc
: Source_Ptr
;
3942 -- Used for the exception handler, inserted at end of the body
3945 -- Set the source location on the exception handler only when debugging
3946 -- the expanded code (see Make_Implicit_Exception_Handler).
3948 if Debug_Generated_Code
then
3951 -- Otherwise the inserted code should not be visible to the debugger
3954 EH_Loc
:= No_Location
;
3958 Make_Defining_Identifier
(Loc
,
3959 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3960 Bod_Spec
:= Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Empty
);
3962 -- Add the following declarations:
3964 -- type poVP is access poV;
3965 -- _object : poVP := poVP (_O);
3967 -- where _O is the formal parameter associated with the concurrent
3968 -- object. These declarations are needed for Complete_Entry_Body.
3970 Add_Object_Pointer
(Loc
, Pid
, Bod_Decls
);
3972 -- Add renamings for all formals, the Protection object, discriminals,
3973 -- privals and the entry index constant for use by debugger.
3975 Add_Formal_Renamings
(Bod_Spec
, Bod_Decls
, Ent
, Loc
);
3976 Debug_Private_Data_Declarations
(Decls
);
3978 -- Put the declarations and the statements from the entry
3982 Make_Block_Statement
(Loc
,
3983 Declarations
=> Decls
,
3984 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
)));
3986 case Corresponding_Runtime_Package
(Pid
) is
3987 when System_Tasking_Protected_Objects_Entries
=>
3988 Append_To
(Bod_Stmts
,
3989 Make_Procedure_Call_Statement
(End_Loc
,
3991 New_Occurrence_Of
(RTE
(RE_Complete_Entry_Body
), Loc
),
3992 Parameter_Associations
=> New_List
(
3993 Make_Attribute_Reference
(End_Loc
,
3995 Make_Selected_Component
(End_Loc
,
3997 Make_Identifier
(End_Loc
, Name_uObject
),
3999 Make_Identifier
(End_Loc
, Name_uObject
)),
4000 Attribute_Name
=> Name_Unchecked_Access
))));
4002 when System_Tasking_Protected_Objects_Single_Entry
=>
4004 -- Historically, a call to Complete_Single_Entry_Body was
4005 -- inserted, but it was a null procedure.
4010 raise Program_Error
;
4013 -- When exceptions can not be propagated, we never need to call
4014 -- Exception_Complete_Entry_Body.
4016 if No_Exception_Handlers_Set
then
4018 Make_Subprogram_Body
(Loc
,
4019 Specification
=> Bod_Spec
,
4020 Declarations
=> Bod_Decls
,
4021 Handled_Statement_Sequence
=>
4022 Make_Handled_Sequence_Of_Statements
(Loc
,
4023 Statements
=> Bod_Stmts
,
4024 End_Label
=> End_Lab
));
4027 Ohandle
:= Make_Others_Choice
(Loc
);
4028 Set_All_Others
(Ohandle
);
4030 case Corresponding_Runtime_Package
(Pid
) is
4031 when System_Tasking_Protected_Objects_Entries
=>
4034 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
4036 when System_Tasking_Protected_Objects_Single_Entry
=>
4039 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
4042 raise Program_Error
;
4045 -- Establish link between subprogram body entity and source entry
4047 Set_Corresponding_Protected_Entry
(Bod_Id
, Ent
);
4049 -- Create body of entry procedure. The renaming declarations are
4050 -- placed ahead of the block that contains the actual entry body.
4053 Make_Subprogram_Body
(Loc
,
4054 Specification
=> Bod_Spec
,
4055 Declarations
=> Bod_Decls
,
4056 Handled_Statement_Sequence
=>
4057 Make_Handled_Sequence_Of_Statements
(Loc
,
4058 Statements
=> Bod_Stmts
,
4059 End_Label
=> End_Lab
,
4060 Exception_Handlers
=> New_List
(
4061 Make_Implicit_Exception_Handler
(EH_Loc
,
4062 Exception_Choices
=> New_List
(Ohandle
),
4064 Statements
=> New_List
(
4065 Make_Procedure_Call_Statement
(EH_Loc
,
4067 Parameter_Associations
=> New_List
(
4068 Make_Attribute_Reference
(EH_Loc
,
4070 Make_Selected_Component
(EH_Loc
,
4072 Make_Identifier
(EH_Loc
, Name_uObject
),
4074 Make_Identifier
(EH_Loc
, Name_uObject
)),
4075 Attribute_Name
=> Name_Unchecked_Access
),
4077 Make_Function_Call
(EH_Loc
,
4080 (RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
4082 end Build_Protected_Entry
;
4084 -----------------------------------------
4085 -- Build_Protected_Entry_Specification --
4086 -----------------------------------------
4088 function Build_Protected_Entry_Specification
4091 Ent_Id
: Entity_Id
) return Node_Id
4093 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4096 Set_Debug_Info_Needed
(Def_Id
);
4098 if Present
(Ent_Id
) then
4099 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
4103 Make_Procedure_Specification
(Loc
,
4104 Defining_Unit_Name
=> Def_Id
,
4105 Parameter_Specifications
=> New_List
(
4106 Make_Parameter_Specification
(Loc
,
4107 Defining_Identifier
=>
4108 Make_Defining_Identifier
(Loc
, Name_uO
),
4110 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
4112 Make_Parameter_Specification
(Loc
,
4113 Defining_Identifier
=> P
,
4115 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
4117 Make_Parameter_Specification
(Loc
,
4118 Defining_Identifier
=>
4119 Make_Defining_Identifier
(Loc
, Name_uE
),
4121 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))));
4122 end Build_Protected_Entry_Specification
;
4124 --------------------------
4125 -- Build_Protected_Spec --
4126 --------------------------
4128 function Build_Protected_Spec
4130 Obj_Type
: Entity_Id
;
4132 Unprotected
: Boolean := False) return List_Id
4134 Loc
: constant Source_Ptr
:= Sloc
(N
);
4137 New_Plist
: List_Id
;
4138 New_Param
: Node_Id
;
4141 New_Plist
:= New_List
;
4143 Formal
:= First_Formal
(Ident
);
4144 while Present
(Formal
) loop
4146 Make_Parameter_Specification
(Loc
,
4147 Defining_Identifier
=>
4148 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
4149 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
4150 In_Present
=> In_Present
(Parent
(Formal
)),
4151 Out_Present
=> Out_Present
(Parent
(Formal
)),
4152 Parameter_Type
=> New_Occurrence_Of
(Etype
(Formal
), Loc
));
4155 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
4158 Append
(New_Param
, New_Plist
);
4159 Next_Formal
(Formal
);
4162 -- If the subprogram is a procedure and the context is not an access
4163 -- to protected subprogram, the parameter is in-out. Otherwise it is
4167 Make_Parameter_Specification
(Loc
,
4168 Defining_Identifier
=>
4169 Make_Defining_Identifier
(Loc
, Name_uObject
),
4172 (Etype
(Ident
) = Standard_Void_Type
4173 and then not Is_RTE
(Obj_Type
, RE_Address
)),
4175 New_Occurrence_Of
(Obj_Type
, Loc
));
4176 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
4177 Prepend_To
(New_Plist
, Decl
);
4180 end Build_Protected_Spec
;
4182 ---------------------------------------
4183 -- Build_Protected_Sub_Specification --
4184 ---------------------------------------
4186 function Build_Protected_Sub_Specification
4188 Prot_Typ
: Entity_Id
;
4189 Mode
: Subprogram_Protection_Mode
) return Node_Id
4191 Loc
: constant Source_Ptr
:= Sloc
(N
);
4195 New_Plist
: List_Id
;
4198 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
4199 (Dispatching_Mode
=> ' ',
4200 Protected_Mode
=> 'P',
4201 Unprotected_Mode
=> 'N');
4204 if Ekind
(Defining_Unit_Name
(Specification
(N
))) = E_Subprogram_Body
4206 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
4211 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
4214 Build_Protected_Spec
4215 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
4216 Mode
= Unprotected_Mode
);
4218 Make_Defining_Identifier
(Loc
,
4219 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
4221 -- Reference the original nondispatching subprogram since the analysis
4222 -- of the object.operation notation may need its original name (see
4223 -- Sem_Ch4.Names_Match).
4225 if Mode
= Dispatching_Mode
then
4226 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
4227 Set_Original_Protected_Subprogram
(New_Id
, Def_Id
);
4230 -- The unprotected operation carries the user code, and debugging
4231 -- information must be generated for it, even though this spec does
4232 -- not come from source. It is also convenient to allow gdb to step
4233 -- into the protected operation, even though it only contains lock/
4236 Set_Debug_Info_Needed
(New_Id
);
4238 -- If a pragma Eliminate applies to the source entity, the internal
4239 -- subprograms will be eliminated as well.
4241 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
4243 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
4245 Make_Procedure_Specification
(Loc
,
4246 Defining_Unit_Name
=> New_Id
,
4247 Parameter_Specifications
=> New_Plist
);
4249 -- Create a new specification for the anonymous subprogram type
4253 Make_Function_Specification
(Loc
,
4254 Defining_Unit_Name
=> New_Id
,
4255 Parameter_Specifications
=> New_Plist
,
4256 Result_Definition
=>
4257 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
4259 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
4263 end Build_Protected_Sub_Specification
;
4265 -------------------------------------
4266 -- Build_Protected_Subprogram_Body --
4267 -------------------------------------
4269 function Build_Protected_Subprogram_Body
4272 N_Op_Spec
: Node_Id
) return Node_Id
4274 Loc
: constant Source_Ptr
:= Sloc
(N
);
4276 P_Op_Spec
: Node_Id
;
4279 Unprot_Call
: Node_Id
;
4281 Lock_Name
: Node_Id
;
4282 Lock_Stmt
: Node_Id
;
4284 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
4285 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
4287 Object_Parm
: Node_Id
;
4292 Op_Spec
:= Specification
(N
);
4293 Exc_Safe
:= Is_Exception_Safe
(N
);
4296 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
4298 -- Build a list of the formal parameters of the protected version of
4299 -- the subprogram to use as the actual parameters of the unprotected
4302 Uactuals
:= New_List
;
4303 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
4304 while Present
(Pformal
) loop
4305 Append_To
(Uactuals
,
4306 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
4310 -- Make a call to the unprotected version of the subprogram built above
4311 -- for use by the protected version built below.
4313 if Nkind
(Op_Spec
) = N_Function_Specification
then
4315 R
:= Make_Temporary
(Loc
, 'R');
4318 Make_Object_Declaration
(Loc
,
4319 Defining_Identifier
=> R
,
4320 Constant_Present
=> True,
4321 Object_Definition
=>
4322 New_Copy
(Result_Definition
(N_Op_Spec
)),
4324 Make_Function_Call
(Loc
,
4326 Make_Identifier
(Loc
,
4327 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4328 Parameter_Associations
=> Uactuals
));
4331 Make_Simple_Return_Statement
(Loc
,
4332 Expression
=> New_Occurrence_Of
(R
, Loc
));
4336 Make_Simple_Return_Statement
(Loc
,
4338 Make_Function_Call
(Loc
,
4340 Make_Identifier
(Loc
,
4341 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4342 Parameter_Associations
=> Uactuals
));
4345 Lock_Kind
:= RE_Lock_Read_Only
;
4349 Make_Procedure_Call_Statement
(Loc
,
4351 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4352 Parameter_Associations
=> Uactuals
);
4354 Lock_Kind
:= RE_Lock
;
4357 -- Wrap call in block that will be covered by an at_end handler
4359 if not Exc_Safe
then
4361 Make_Block_Statement
(Loc
,
4362 Handled_Statement_Sequence
=>
4363 Make_Handled_Sequence_Of_Statements
(Loc
,
4364 Statements
=> New_List
(Unprot_Call
)));
4367 -- Make the protected subprogram body. This locks the protected
4368 -- object and calls the unprotected version of the subprogram.
4370 case Corresponding_Runtime_Package
(Pid
) is
4371 when System_Tasking_Protected_Objects_Entries
=>
4372 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entries
), Loc
);
4374 when System_Tasking_Protected_Objects_Single_Entry
=>
4375 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entry
), Loc
);
4377 when System_Tasking_Protected_Objects
=>
4378 Lock_Name
:= New_Occurrence_Of
(RTE
(Lock_Kind
), Loc
);
4381 raise Program_Error
;
4385 Make_Attribute_Reference
(Loc
,
4387 Make_Selected_Component
(Loc
,
4388 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4389 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4390 Attribute_Name
=> Name_Unchecked_Access
);
4393 Make_Procedure_Call_Statement
(Loc
,
4395 Parameter_Associations
=> New_List
(Object_Parm
));
4397 if Abort_Allowed
then
4399 Build_Runtime_Call
(Loc
, RE_Abort_Defer
),
4403 Stmts
:= New_List
(Lock_Stmt
);
4406 if not Exc_Safe
then
4407 Append
(Unprot_Call
, Stmts
);
4409 if Nkind
(Op_Spec
) = N_Function_Specification
then
4411 Stmts
:= Empty_List
;
4413 Append
(Unprot_Call
, Stmts
);
4416 -- Historical note: Previously, call to the cleanup was inserted
4417 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4418 -- which is also shared by the 'not Exc_Safe' path.
4420 Build_Protected_Subprogram_Call_Cleanup
(Op_Spec
, Pid
, Loc
, Stmts
);
4422 if Nkind
(Op_Spec
) = N_Function_Specification
then
4423 Append_To
(Stmts
, Return_Stmt
);
4424 Append_To
(Pre_Stmts
,
4425 Make_Block_Statement
(Loc
,
4426 Declarations
=> New_List
(Unprot_Call
),
4427 Handled_Statement_Sequence
=>
4428 Make_Handled_Sequence_Of_Statements
(Loc
,
4429 Statements
=> Stmts
)));
4435 Make_Subprogram_Body
(Loc
,
4436 Declarations
=> Empty_List
,
4437 Specification
=> P_Op_Spec
,
4438 Handled_Statement_Sequence
=>
4439 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4441 -- Mark this subprogram as a protected subprogram body so that the
4442 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4443 -- path as otherwise the cleanup has already been inserted.
4445 if not Exc_Safe
then
4446 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4450 end Build_Protected_Subprogram_Body
;
4452 -------------------------------------
4453 -- Build_Protected_Subprogram_Call --
4454 -------------------------------------
4456 procedure Build_Protected_Subprogram_Call
4460 External
: Boolean := True)
4462 Loc
: constant Source_Ptr
:= Sloc
(N
);
4463 Sub
: constant Entity_Id
:= Entity
(Name
);
4469 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4472 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4475 if Present
(Parameter_Associations
(N
)) then
4476 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4481 -- If the type is an untagged derived type, convert to the root type,
4482 -- which is the one on which the operations are defined.
4484 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4485 and then not Is_Tagged_Type
(Etype
(Rec
))
4486 and then Is_Derived_Type
(Etype
(Rec
))
4488 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4489 Set_Subtype_Mark
(Rec
,
4490 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4493 Prepend
(Rec
, Params
);
4495 if Ekind
(Sub
) = E_Procedure
then
4497 Make_Procedure_Call_Statement
(Loc
,
4499 Parameter_Associations
=> Params
));
4502 pragma Assert
(Ekind
(Sub
) = E_Function
);
4504 Make_Function_Call
(Loc
,
4506 Parameter_Associations
=> Params
));
4508 -- Preserve type of call for subsequent processing (required for
4509 -- call to Wrap_Transient_Expression in the case of a shared passive
4512 Set_Etype
(N
, Etype
(New_Sub
));
4516 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
4517 and then Is_Entity_Name
(Expression
(Rec
))
4518 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
4520 Add_Shared_Var_Lock_Procs
(N
);
4522 end Build_Protected_Subprogram_Call
;
4524 ---------------------------------------------
4525 -- Build_Protected_Subprogram_Call_Cleanup --
4526 ---------------------------------------------
4528 procedure Build_Protected_Subprogram_Call_Cleanup
4537 -- If the associated protected object has entries, a protected
4538 -- procedure has to service entry queues. In this case generate:
4540 -- Service_Entries (_object._object'Access);
4542 if Nkind
(Op_Spec
) = N_Procedure_Specification
4543 and then Has_Entries
(Conc_Typ
)
4545 case Corresponding_Runtime_Package
(Conc_Typ
) is
4546 when System_Tasking_Protected_Objects_Entries
=>
4547 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entries
), Loc
);
4549 when System_Tasking_Protected_Objects_Single_Entry
=>
4550 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entry
), Loc
);
4553 raise Program_Error
;
4557 Make_Procedure_Call_Statement
(Loc
,
4559 Parameter_Associations
=> New_List
(
4560 Make_Attribute_Reference
(Loc
,
4562 Make_Selected_Component
(Loc
,
4563 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4564 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4565 Attribute_Name
=> Name_Unchecked_Access
))));
4569 -- Unlock (_object._object'Access);
4571 case Corresponding_Runtime_Package
(Conc_Typ
) is
4572 when System_Tasking_Protected_Objects_Entries
=>
4573 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entries
), Loc
);
4575 when System_Tasking_Protected_Objects_Single_Entry
=>
4576 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entry
), Loc
);
4578 when System_Tasking_Protected_Objects
=>
4579 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock
), Loc
);
4582 raise Program_Error
;
4586 Make_Procedure_Call_Statement
(Loc
,
4588 Parameter_Associations
=> New_List
(
4589 Make_Attribute_Reference
(Loc
,
4591 Make_Selected_Component
(Loc
,
4592 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4593 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4594 Attribute_Name
=> Name_Unchecked_Access
))));
4600 if Abort_Allowed
then
4601 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
4603 end Build_Protected_Subprogram_Call_Cleanup
;
4605 -------------------------
4606 -- Build_Selected_Name --
4607 -------------------------
4609 function Build_Selected_Name
4610 (Prefix
: Entity_Id
;
4611 Selector
: Entity_Id
;
4612 Append_Char
: Character := ' ') return Name_Id
4614 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4615 Select_Len
: Natural;
4618 Get_Name_String
(Chars
(Selector
));
4619 Select_Len
:= Name_Len
;
4620 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4621 Get_Name_String
(Chars
(Prefix
));
4623 -- If scope is anonymous type, discard suffix to recover name of
4624 -- single protected object. Otherwise use protected type name.
4626 if Name_Buffer
(Name_Len
) = 'T' then
4627 Name_Len
:= Name_Len
- 1;
4630 Add_Str_To_Name_Buffer
("__");
4631 for J
in 1 .. Select_Len
loop
4632 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4635 -- Now add the Append_Char if specified. The encoding to follow
4636 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4637 -- then the entity is associated to a protected type subprogram.
4638 -- Otherwise, it is a protected type entry. For each case, the
4639 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4641 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4643 if Append_Char
/= ' ' then
4644 if Append_Char
= 'P' or Append_Char
= 'N' then
4645 Add_Char_To_Name_Buffer
(Append_Char
);
4648 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4649 return New_External_Name
(Name_Find
, ' ', -1);
4654 end Build_Selected_Name
;
4656 -----------------------------
4657 -- Build_Simple_Entry_Call --
4658 -----------------------------
4660 -- A task entry call is converted to a call to Call_Simple
4663 -- P : parms := (parm, parm, parm);
4665 -- Call_Simple (acceptor-task, entry-index, P'Address);
4671 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4672 -- the parameters, and the constructed aggregate value contains either the
4673 -- parameters or, in the case of non-elementary types, references to these
4674 -- parameters. Then the address of this aggregate is passed to the runtime
4675 -- routine, along with the task id value and the task entry index value.
4676 -- Pnn is only required if parameters are present.
4678 -- The assignments after the call are present only in the case of in-out
4679 -- or out parameters for elementary types, and are used to assign back the
4680 -- resulting values of such parameters.
4682 -- Note: the reason that we insert a block here is that in the context
4683 -- of selects, conditional entry calls etc. the entry call statement
4684 -- appears on its own, not as an element of a list.
4686 -- A protected entry call is converted to a Protected_Entry_Call:
4689 -- P : E1_Params := (param, param, param);
4691 -- Bnn : Communications_Block;
4694 -- P : E1_Params := (param, param, param);
4695 -- Bnn : Communications_Block;
4698 -- Protected_Entry_Call (
4699 -- Object => po._object'Access,
4700 -- E => <entry index>;
4701 -- Uninterpreted_Data => P'Address;
4702 -- Mode => Simple_Call;
4709 procedure Build_Simple_Entry_Call
4718 -- If call has been inlined, nothing left to do
4720 if Nkind
(N
) = N_Block_Statement
then
4724 -- Convert entry call to Call_Simple call
4727 Loc
: constant Source_Ptr
:= Sloc
(N
);
4728 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4729 Stats
: constant List_Id
:= New_List
;
4732 Comm_Name
: Entity_Id
;
4736 Ent_Acc
: Entity_Id
;
4738 Iface_Tag
: Entity_Id
;
4739 Iface_Typ
: Entity_Id
;
4752 -- Simple entry and entry family cases merge here
4754 Ent
:= Entity
(Ename
);
4755 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4756 Conctyp
:= Etype
(Concval
);
4758 -- If prefix is an access type, dereference to obtain the task type
4760 if Is_Access_Type
(Conctyp
) then
4761 Conctyp
:= Designated_Type
(Conctyp
);
4764 -- Special case for protected subprogram calls
4766 if Is_Protected_Type
(Conctyp
)
4767 and then Is_Subprogram
(Entity
(Ename
))
4769 if not Is_Eliminated
(Entity
(Ename
)) then
4770 Build_Protected_Subprogram_Call
4771 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4778 -- First parameter is the Task_Id value from the task value or the
4779 -- Object from the protected object value, obtained by selecting
4780 -- the _Task_Id or _Object from the result of doing an unchecked
4781 -- conversion to convert the value to the corresponding record type.
4783 if Nkind
(Concval
) = N_Function_Call
4784 and then Is_Task_Type
(Conctyp
)
4785 and then Ada_Version
>= Ada_2005
4788 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4789 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4794 Make_Object_Declaration
(Loc
,
4795 Defining_Identifier
=> Obj
,
4796 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4797 Expression
=> ExpR
);
4798 Set_Etype
(Obj
, Conctyp
);
4799 Decls
:= New_List
(Decl
);
4800 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4807 Parm1
:= Concurrent_Ref
(Concval
);
4809 -- Second parameter is the entry index, computed by the routine
4810 -- provided for this purpose. The value of this expression is
4811 -- assigned to an intermediate variable to assure that any entry
4812 -- family index expressions are evaluated before the entry
4815 if not Is_Protected_Type
(Conctyp
)
4817 Corresponding_Runtime_Package
(Conctyp
) =
4818 System_Tasking_Protected_Objects_Entries
4820 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4823 Make_Object_Declaration
(Loc
,
4824 Defining_Identifier
=> X
,
4825 Object_Definition
=>
4826 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
4827 Expression
=> Actual_Index_Expression
(
4828 Loc
, Entity
(Ename
), Index
, Concval
));
4830 Append_To
(Decls
, Xdecl
);
4831 Parm2
:= New_Occurrence_Of
(X
, Loc
);
4838 -- The third parameter is the packaged parameters. If there are
4839 -- none, then it is just the null address, since nothing is passed.
4842 Parm3
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
4845 -- Case of parameters present, where third argument is the address
4846 -- of a packaged record containing the required parameter values.
4849 -- First build a list of parameter values, which are references to
4850 -- objects of the parameter types.
4854 Actual
:= First_Actual
(N
);
4855 Formal
:= First_Formal
(Ent
);
4856 while Present
(Actual
) loop
4858 -- If it is a by-copy type, copy it to a new variable. The
4859 -- packaged record has a field that points to this variable.
4861 if Is_By_Copy_Type
(Etype
(Actual
)) then
4863 Make_Object_Declaration
(Loc
,
4864 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4865 Aliased_Present
=> True,
4866 Object_Definition
=>
4867 New_Occurrence_Of
(Etype
(Formal
), Loc
));
4869 -- Mark the object as not needing initialization since the
4870 -- initialization is performed separately, avoiding errors
4871 -- on cases such as formals of null-excluding access types.
4873 Set_No_Initialization
(N_Node
);
4875 -- We must make a separate assignment statement for the
4876 -- case of limited types. We cannot assign it unless the
4877 -- Assignment_OK flag is set first. An out formal of an
4878 -- access type or whose type has a Default_Value must also
4879 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4880 -- but no constraint, predicate, or null-exclusion check is
4881 -- applied before the call.
4883 if Ekind
(Formal
) /= E_Out_Parameter
4884 or else Is_Access_Type
(Etype
(Formal
))
4886 (Is_Scalar_Type
(Etype
(Formal
))
4888 Present
(Default_Aspect_Value
(Etype
(Formal
))))
4891 New_Occurrence_Of
(Defining_Identifier
(N_Node
), Loc
);
4892 Set_Assignment_OK
(N_Var
);
4894 Make_Assignment_Statement
(Loc
,
4896 Expression
=> Relocate_Node
(Actual
)));
4898 -- Mark the object as internal, so we don't later reset
4899 -- No_Initialization flag in Default_Initialize_Object,
4900 -- which would lead to needless default initialization.
4901 -- We don't set this outside the if statement, because
4902 -- out scalar parameters without Default_Value do require
4903 -- default initialization if Initialize_Scalars applies.
4905 Set_Is_Internal
(Defining_Identifier
(N_Node
));
4907 -- If actual is an out parameter of a null-excluding
4908 -- access type, there is access check on entry, so set
4909 -- Suppress_Assignment_Checks on the generated statement
4910 -- that assigns the actual to the parameter block
4912 Set_Suppress_Assignment_Checks
(Last
(Stats
));
4915 Append
(N_Node
, Decls
);
4918 Make_Attribute_Reference
(Loc
,
4919 Attribute_Name
=> Name_Unchecked_Access
,
4922 (Defining_Identifier
(N_Node
), Loc
)));
4925 -- Interface class-wide formal
4927 if Ada_Version
>= Ada_2005
4928 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4929 and then Is_Interface
(Etype
(Formal
))
4931 Iface_Typ
:= Etype
(Etype
(Formal
));
4934 -- formal_iface_type! (actual.iface_tag)'reference
4937 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4938 pragma Assert
(Present
(Iface_Tag
));
4941 Make_Reference
(Loc
,
4942 Unchecked_Convert_To
(Iface_Typ
,
4943 Make_Selected_Component
(Loc
,
4945 Relocate_Node
(Actual
),
4947 New_Occurrence_Of
(Iface_Tag
, Loc
)))));
4953 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4957 Next_Actual
(Actual
);
4958 Next_Formal_With_Extras
(Formal
);
4961 -- Now build the declaration of parameters initialized with the
4962 -- aggregate containing this constructed parameter list.
4964 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4967 Make_Object_Declaration
(Loc
,
4968 Defining_Identifier
=> P
,
4969 Object_Definition
=>
4970 New_Occurrence_Of
(Designated_Type
(Ent_Acc
), Loc
),
4972 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4975 Make_Attribute_Reference
(Loc
,
4976 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4977 Attribute_Name
=> Name_Address
);
4979 Append
(Pdecl
, Decls
);
4982 -- Now we can create the call, case of protected type
4984 if Is_Protected_Type
(Conctyp
) then
4985 case Corresponding_Runtime_Package
(Conctyp
) is
4986 when System_Tasking_Protected_Objects_Entries
=>
4988 -- Change the type of the index declaration
4990 Set_Object_Definition
(Xdecl
,
4991 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
));
4993 -- Some additional declarations for protected entry calls
4999 -- Bnn : Communications_Block;
5001 Comm_Name
:= Make_Temporary
(Loc
, 'B');
5004 Make_Object_Declaration
(Loc
,
5005 Defining_Identifier
=> Comm_Name
,
5006 Object_Definition
=>
5008 (RTE
(RE_Communication_Block
), Loc
)));
5010 -- Some additional statements for protected entry calls
5012 -- Protected_Entry_Call (
5013 -- Object => po._object'Access,
5014 -- E => <entry index>;
5015 -- Uninterpreted_Data => P'Address;
5016 -- Mode => Simple_Call;
5020 Make_Procedure_Call_Statement
(Loc
,
5022 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
5024 Parameter_Associations
=> New_List
(
5025 Make_Attribute_Reference
(Loc
,
5026 Attribute_Name
=> Name_Unchecked_Access
,
5030 New_Occurrence_Of
(RTE
(RE_Simple_Call
), Loc
),
5031 New_Occurrence_Of
(Comm_Name
, Loc
)));
5033 when System_Tasking_Protected_Objects_Single_Entry
=>
5034 -- Protected_Single_Entry_Call (
5035 -- Object => po._object'Access,
5036 -- Uninterpreted_Data => P'Address);
5039 Make_Procedure_Call_Statement
(Loc
,
5042 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
5044 Parameter_Associations
=> New_List
(
5045 Make_Attribute_Reference
(Loc
,
5046 Attribute_Name
=> Name_Unchecked_Access
,
5051 raise Program_Error
;
5054 -- Case of task type
5058 Make_Procedure_Call_Statement
(Loc
,
5060 New_Occurrence_Of
(RTE
(RE_Call_Simple
), Loc
),
5061 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
5065 Append_To
(Stats
, Call
);
5067 -- If there are out or in/out parameters by copy add assignment
5068 -- statements for the result values.
5070 if Present
(Parms
) then
5071 Actual
:= First_Actual
(N
);
5072 Formal
:= First_Formal
(Ent
);
5074 Set_Assignment_OK
(Actual
);
5075 while Present
(Actual
) loop
5076 if Is_By_Copy_Type
(Etype
(Actual
))
5077 and then Ekind
(Formal
) /= E_In_Parameter
5080 Make_Assignment_Statement
(Loc
,
5081 Name
=> New_Copy
(Actual
),
5083 Make_Explicit_Dereference
(Loc
,
5084 Make_Selected_Component
(Loc
,
5085 Prefix
=> New_Occurrence_Of
(P
, Loc
),
5087 Make_Identifier
(Loc
, Chars
(Formal
)))));
5089 -- In all cases (including limited private types) we want
5090 -- the assignment to be valid.
5092 Set_Assignment_OK
(Name
(N_Node
));
5094 -- If the call is the triggering alternative in an
5095 -- asynchronous select, or the entry_call alternative of a
5096 -- conditional entry call, the assignments for in-out
5097 -- parameters are incorporated into the statement list that
5098 -- follows, so that there are executed only if the entry
5101 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
5102 and then N
= Triggering_Statement
(Parent
(N
)))
5104 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
5105 and then N
= Entry_Call_Statement
(Parent
(N
)))
5107 if No
(Statements
(Parent
(N
))) then
5108 Set_Statements
(Parent
(N
), New_List
);
5111 Prepend
(N_Node
, Statements
(Parent
(N
)));
5114 Insert_After
(Call
, N_Node
);
5118 Next_Actual
(Actual
);
5119 Next_Formal_With_Extras
(Formal
);
5123 -- Finally, create block and analyze it
5126 Make_Block_Statement
(Loc
,
5127 Declarations
=> Decls
,
5128 Handled_Statement_Sequence
=>
5129 Make_Handled_Sequence_Of_Statements
(Loc
,
5130 Statements
=> Stats
)));
5134 end Build_Simple_Entry_Call
;
5136 --------------------------------
5137 -- Build_Task_Activation_Call --
5138 --------------------------------
5140 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
5141 Loc
: constant Source_Ptr
:= Sloc
(N
);
5148 -- For sequential elaboration policy, all the tasks will be activated at
5149 -- the end of the elaboration.
5151 if Partition_Elaboration_Policy
= 'S' then
5155 -- Get the activation chain entity. Except in the case of a package
5156 -- body, this is in the node that was passed. For a package body, we
5157 -- have to find the corresponding package declaration node.
5159 if Nkind
(N
) = N_Package_Body
then
5160 P
:= Corresponding_Spec
(N
);
5163 exit when Nkind
(P
) = N_Package_Declaration
;
5166 Chain
:= Activation_Chain_Entity
(P
);
5169 Chain
:= Activation_Chain_Entity
(N
);
5172 if Present
(Chain
) then
5173 if Restricted_Profile
then
5174 Name
:= New_Occurrence_Of
5175 (RTE
(RE_Activate_Restricted_Tasks
), Loc
);
5177 Name
:= New_Occurrence_Of
5178 (RTE
(RE_Activate_Tasks
), Loc
);
5182 Make_Procedure_Call_Statement
(Loc
,
5184 Parameter_Associations
=>
5185 New_List
(Make_Attribute_Reference
(Loc
,
5186 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5187 Attribute_Name
=> Name_Unchecked_Access
)));
5189 if Nkind
(N
) = N_Package_Declaration
then
5190 if Present
(Corresponding_Body
(N
)) then
5193 elsif Present
(Private_Declarations
(Specification
(N
))) then
5194 Append
(Call
, Private_Declarations
(Specification
(N
)));
5197 Append
(Call
, Visible_Declarations
(Specification
(N
)));
5201 if Present
(Handled_Statement_Sequence
(N
)) then
5203 -- The call goes at the start of the statement sequence after
5204 -- the start of exception range label if one is present.
5210 Stm
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
5212 -- A special case, skip exception range label if one is
5213 -- present (from front end zcx processing).
5215 if Nkind
(Stm
) = N_Label
and then Exception_Junk
(Stm
) then
5219 -- Another special case, if the first statement is a block
5220 -- from optimization of a local raise to a goto, then the
5221 -- call goes inside this block.
5223 if Nkind
(Stm
) = N_Block_Statement
5224 and then Exception_Junk
(Stm
)
5227 First
(Statements
(Handled_Statement_Sequence
(Stm
)));
5230 -- Insertion point is after any exception label pushes,
5231 -- since we want it covered by any local handlers.
5233 while Nkind
(Stm
) in N_Push_xxx_Label
loop
5237 -- Now we have the proper insertion point
5239 Insert_Before
(Stm
, Call
);
5243 Set_Handled_Statement_Sequence
(N
,
5244 Make_Handled_Sequence_Of_Statements
(Loc
,
5245 Statements
=> New_List
(Call
)));
5250 Check_Task_Activation
(N
);
5252 end Build_Task_Activation_Call
;
5254 -------------------------------
5255 -- Build_Task_Allocate_Block --
5256 -------------------------------
5258 procedure Build_Task_Allocate_Block
5263 T
: constant Entity_Id
:= Entity
(Expression
(N
));
5264 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
5265 Loc
: constant Source_Ptr
:= Sloc
(N
);
5266 Chain
: constant Entity_Id
:=
5267 Make_Defining_Identifier
(Loc
, Name_uChain
);
5268 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5273 Make_Block_Statement
(Loc
,
5274 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5275 Declarations
=> New_List
(
5277 -- _Chain : Activation_Chain;
5279 Make_Object_Declaration
(Loc
,
5280 Defining_Identifier
=> Chain
,
5281 Aliased_Present
=> True,
5282 Object_Definition
=>
5283 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5285 Handled_Statement_Sequence
=>
5286 Make_Handled_Sequence_Of_Statements
(Loc
,
5288 Statements
=> New_List
(
5292 Make_Procedure_Call_Statement
(Loc
,
5293 Name
=> New_Occurrence_Of
(Init
, Loc
),
5294 Parameter_Associations
=> Args
),
5296 -- Activate_Tasks (_Chain);
5298 Make_Procedure_Call_Statement
(Loc
,
5299 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5300 Parameter_Associations
=> New_List
(
5301 Make_Attribute_Reference
(Loc
,
5302 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5303 Attribute_Name
=> Name_Unchecked_Access
))))),
5305 Has_Created_Identifier
=> True,
5306 Is_Task_Allocation_Block
=> True);
5309 Make_Implicit_Label_Declaration
(Loc
,
5310 Defining_Identifier
=> Blkent
,
5311 Label_Construct
=> Block
));
5313 Append_To
(Actions
, Block
);
5315 Set_Activation_Chain_Entity
(Block
, Chain
);
5316 end Build_Task_Allocate_Block
;
5318 -----------------------------------------------
5319 -- Build_Task_Allocate_Block_With_Init_Stmts --
5320 -----------------------------------------------
5322 procedure Build_Task_Allocate_Block_With_Init_Stmts
5325 Init_Stmts
: List_Id
)
5327 Loc
: constant Source_Ptr
:= Sloc
(N
);
5328 Chain
: constant Entity_Id
:=
5329 Make_Defining_Identifier
(Loc
, Name_uChain
);
5330 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5334 Append_To
(Init_Stmts
,
5335 Make_Procedure_Call_Statement
(Loc
,
5336 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5337 Parameter_Associations
=> New_List
(
5338 Make_Attribute_Reference
(Loc
,
5339 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5340 Attribute_Name
=> Name_Unchecked_Access
))));
5343 Make_Block_Statement
(Loc
,
5344 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5345 Declarations
=> New_List
(
5347 -- _Chain : Activation_Chain;
5349 Make_Object_Declaration
(Loc
,
5350 Defining_Identifier
=> Chain
,
5351 Aliased_Present
=> True,
5352 Object_Definition
=>
5353 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5355 Handled_Statement_Sequence
=>
5356 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5358 Has_Created_Identifier
=> True,
5359 Is_Task_Allocation_Block
=> True);
5362 Make_Implicit_Label_Declaration
(Loc
,
5363 Defining_Identifier
=> Blkent
,
5364 Label_Construct
=> Block
));
5366 Append_To
(Actions
, Block
);
5368 Set_Activation_Chain_Entity
(Block
, Chain
);
5369 end Build_Task_Allocate_Block_With_Init_Stmts
;
5371 -----------------------------------
5372 -- Build_Task_Proc_Specification --
5373 -----------------------------------
5375 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5376 Loc
: constant Source_Ptr
:= Sloc
(T
);
5377 Spec_Id
: Entity_Id
;
5380 -- Case of explicit task type, suffix TB
5382 if Comes_From_Source
(T
) then
5384 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), "TB"));
5386 -- Case of anonymous task type, suffix B
5390 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), 'B'));
5393 Set_Is_Internal
(Spec_Id
);
5395 -- Associate the procedure with the task, if this is the declaration
5396 -- (and not the body) of the procedure.
5398 if No
(Task_Body_Procedure
(T
)) then
5399 Set_Task_Body_Procedure
(T
, Spec_Id
);
5403 Make_Procedure_Specification
(Loc
,
5404 Defining_Unit_Name
=> Spec_Id
,
5405 Parameter_Specifications
=> New_List
(
5406 Make_Parameter_Specification
(Loc
,
5407 Defining_Identifier
=>
5408 Make_Defining_Identifier
(Loc
, Name_uTask
),
5410 Make_Access_Definition
(Loc
,
5412 New_Occurrence_Of
(Corresponding_Record_Type
(T
), Loc
)))));
5413 end Build_Task_Proc_Specification
;
5415 ---------------------------------------
5416 -- Build_Unprotected_Subprogram_Body --
5417 ---------------------------------------
5419 function Build_Unprotected_Subprogram_Body
5421 Pid
: Node_Id
) return Node_Id
5423 Decls
: constant List_Id
:= Declarations
(N
);
5426 -- Add renamings for the Protection object, discriminals, privals, and
5427 -- the entry index constant for use by debugger.
5429 Debug_Private_Data_Declarations
(Decls
);
5431 -- Make an unprotected version of the subprogram for use within the same
5432 -- object, with a new name and an additional parameter representing the
5436 Make_Subprogram_Body
(Sloc
(N
),
5438 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5439 Declarations
=> Decls
,
5440 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5441 end Build_Unprotected_Subprogram_Body
;
5443 ----------------------------
5444 -- Collect_Entry_Families --
5445 ----------------------------
5447 procedure Collect_Entry_Families
5450 Current_Node
: in out Node_Id
;
5451 Conctyp
: Entity_Id
)
5454 Efam_Decl
: Node_Id
;
5455 Efam_Type
: Entity_Id
;
5458 Efam
:= First_Entity
(Conctyp
);
5459 while Present
(Efam
) loop
5460 if Ekind
(Efam
) = E_Entry_Family
then
5461 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5466 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
5468 Bas_Decl
: Node_Id
:= Empty
;
5473 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
5475 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
5476 Bas
:= Make_Temporary
(Loc
, 'B');
5479 Make_Subtype_Declaration
(Loc
,
5480 Defining_Identifier
=> Bas
,
5481 Subtype_Indication
=>
5482 Make_Subtype_Indication
(Loc
,
5484 New_Occurrence_Of
(Standard_Integer
, Loc
),
5486 Make_Range_Constraint
(Loc
,
5487 Range_Expression
=> Make_Range
(Loc
,
5488 Make_Integer_Literal
5489 (Loc
, -Entry_Family_Bound
),
5490 Make_Integer_Literal
5491 (Loc
, Entry_Family_Bound
- 1)))));
5493 Insert_After
(Current_Node
, Bas_Decl
);
5494 Current_Node
:= Bas_Decl
;
5499 Make_Full_Type_Declaration
(Loc
,
5500 Defining_Identifier
=> Efam_Type
,
5502 Make_Unconstrained_Array_Definition
(Loc
,
5504 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
5506 Component_Definition
=>
5507 Make_Component_Definition
(Loc
,
5508 Aliased_Present
=> False,
5509 Subtype_Indication
=>
5510 New_Occurrence_Of
(Standard_Character
, Loc
))));
5513 Insert_After
(Current_Node
, Efam_Decl
);
5514 Current_Node
:= Efam_Decl
;
5515 Analyze
(Efam_Decl
);
5518 Make_Component_Declaration
(Loc
,
5519 Defining_Identifier
=>
5520 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5522 Component_Definition
=>
5523 Make_Component_Definition
(Loc
,
5524 Aliased_Present
=> False,
5525 Subtype_Indication
=>
5526 Make_Subtype_Indication
(Loc
,
5528 New_Occurrence_Of
(Efam_Type
, Loc
),
5531 Make_Index_Or_Discriminant_Constraint
(Loc
,
5532 Constraints
=> New_List
(
5534 (Etype
(Discrete_Subtype_Definition
5535 (Parent
(Efam
))), Loc
)))))));
5541 end Collect_Entry_Families
;
5543 -----------------------
5544 -- Concurrent_Object --
5545 -----------------------
5547 function Concurrent_Object
5548 (Spec_Id
: Entity_Id
;
5549 Conc_Typ
: Entity_Id
) return Entity_Id
5552 -- Parameter _O or _object
5554 if Is_Protected_Type
(Conc_Typ
) then
5555 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5560 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5561 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5563 end Concurrent_Object
;
5565 ----------------------
5566 -- Copy_Result_Type --
5567 ----------------------
5569 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5570 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5575 -- If the result type is an access_to_subprogram, we must create new
5576 -- entities for its spec.
5578 if Nkind
(New_Res
) = N_Access_Definition
5579 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5581 -- Provide new entities for the formals
5583 Par_Spec
:= First
(Parameter_Specifications
5584 (Access_To_Subprogram_Definition
(New_Res
)));
5585 while Present
(Par_Spec
) loop
5586 Formal
:= Defining_Identifier
(Par_Spec
);
5587 Set_Defining_Identifier
(Par_Spec
,
5588 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5594 end Copy_Result_Type
;
5596 --------------------
5597 -- Concurrent_Ref --
5598 --------------------
5600 -- The expression returned for a reference to a concurrent object has the
5603 -- taskV!(name)._Task_Id
5607 -- objectV!(name)._Object
5609 -- for a protected object. For the case of an access to a concurrent
5610 -- object, there is an extra explicit dereference:
5612 -- taskV!(name.all)._Task_Id
5613 -- objectV!(name.all)._Object
5615 -- here taskV and objectV are the types for the associated records, which
5616 -- contain the required _Task_Id and _Object fields for tasks and protected
5617 -- objects, respectively.
5619 -- For the case of a task type name, the expression is
5623 -- i.e. a call to the Self function which returns precisely this Task_Id
5625 -- For the case of a protected type name, the expression is
5629 -- which is a renaming of the _object field of the current object
5630 -- record, passed into protected operations as a parameter.
5632 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5633 Loc
: constant Source_Ptr
:= Sloc
(N
);
5634 Ntyp
: constant Entity_Id
:= Etype
(N
);
5638 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5639 -- Check whether the reference is to the immediately enclosing task
5640 -- type, or to an outer one (rare but legal).
5642 ---------------------
5643 -- Is_Current_Task --
5644 ---------------------
5646 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5650 Scop
:= Current_Scope
;
5651 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
5655 elsif Is_Task_Type
(Scop
) then
5658 -- If this is a procedure nested within the task type, we must
5659 -- assume that it can be called from an inner task, and therefore
5660 -- cannot treat it as a local reference.
5662 elsif Is_Overloadable
(Scop
) and then In_Open_Scopes
(T
) then
5666 Scop
:= Scope
(Scop
);
5670 -- We know that we are within the task body, so should have found it
5673 raise Program_Error
;
5674 end Is_Current_Task
;
5676 -- Start of processing for Concurrent_Ref
5679 if Is_Access_Type
(Ntyp
) then
5680 Dtyp
:= Designated_Type
(Ntyp
);
5682 if Is_Protected_Type
(Dtyp
) then
5683 Sel
:= Name_uObject
;
5685 Sel
:= Name_uTask_Id
;
5689 Make_Selected_Component
(Loc
,
5691 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5692 Make_Explicit_Dereference
(Loc
, N
)),
5693 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5695 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5696 if Is_Task_Type
(Entity
(N
)) then
5698 if Is_Current_Task
(Entity
(N
)) then
5700 Make_Function_Call
(Loc
,
5701 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
));
5706 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5707 T_Body
: constant Node_Id
:=
5708 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5712 Make_Object_Declaration
(Loc
,
5713 Defining_Identifier
=> T_Self
,
5714 Object_Definition
=>
5715 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5717 Make_Function_Call
(Loc
,
5718 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
)));
5719 Prepend
(Decl
, Declarations
(T_Body
));
5721 Set_Scope
(T_Self
, Entity
(N
));
5722 return New_Occurrence_Of
(T_Self
, Loc
);
5727 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5730 New_Occurrence_Of
(Find_Protection_Object
(Current_Scope
), Loc
);
5734 if Is_Protected_Type
(Ntyp
) then
5735 Sel
:= Name_uObject
;
5736 elsif Is_Task_Type
(Ntyp
) then
5737 Sel
:= Name_uTask_Id
;
5739 raise Program_Error
;
5743 Make_Selected_Component
(Loc
,
5745 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5747 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5751 ------------------------
5752 -- Convert_Concurrent --
5753 ------------------------
5755 function Convert_Concurrent
5757 Typ
: Entity_Id
) return Node_Id
5760 if not Is_Concurrent_Type
(Typ
) then
5764 Unchecked_Convert_To
5765 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5767 end Convert_Concurrent
;
5769 -------------------------------------
5770 -- Debug_Private_Data_Declarations --
5771 -------------------------------------
5773 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5774 Debug_Nod
: Node_Id
;
5778 Decl
:= First
(Decls
);
5779 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5781 -- Declaration for concurrent entity _object and its access type,
5782 -- along with the entry index subtype:
5783 -- type prot_typVP is access prot_typV;
5784 -- _object : prot_typVP := prot_typV (_O);
5785 -- subtype Jnn is <Type of Index> range Low .. High;
5787 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
5788 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5790 -- Declaration for the Protection object, discriminals, privals, and
5791 -- entry index constant:
5792 -- conc_typR : protection_typ renames _object._object;
5793 -- discr_nameD : discr_typ renames _object.discr_name;
5794 -- discr_nameD : discr_typ renames _task.discr_name;
5795 -- prival_name : comp_typ renames _object.comp_name;
5796 -- J : constant Jnn :=
5797 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5799 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5800 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5801 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5803 if Present
(Debug_Nod
) then
5804 Insert_After
(Decl
, Debug_Nod
);
5810 end Debug_Private_Data_Declarations
;
5812 ------------------------------
5813 -- Ensure_Statement_Present --
5814 ------------------------------
5816 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5820 if Opt
.Suppress_Control_Flow_Optimizations
5821 and then Is_Empty_List
(Statements
(Alt
))
5823 Stmt
:= Make_Null_Statement
(Loc
);
5825 -- Mark NULL statement as coming from source so that it is not
5826 -- eliminated by GIGI.
5828 -- Another covert channel. If this is a requirement, it must be
5829 -- documented in sinfo/einfo ???
5831 Set_Comes_From_Source
(Stmt
, True);
5833 Set_Statements
(Alt
, New_List
(Stmt
));
5835 end Ensure_Statement_Present
;
5837 ----------------------------
5838 -- Entry_Index_Expression --
5839 ----------------------------
5841 function Entry_Index_Expression
5845 Ttyp
: Entity_Id
) return Node_Id
5855 -- The queues of entries and entry families appear in textual order in
5856 -- the associated record. The entry index is computed as the sum of the
5857 -- number of queues for all entries that precede the designated one, to
5858 -- which is added the index expression, if this expression denotes a
5859 -- member of a family.
5861 -- The following is a place holder for the count of simple entries
5863 Num
:= Make_Integer_Literal
(Sloc
, 1);
5865 -- We construct an expression which is a series of addition operations.
5866 -- The first operand is the number of single entries that precede this
5867 -- one, the second operand is the index value relative to the start of
5868 -- the referenced family, and the remaining operands are the lengths of
5869 -- the entry families that precede this entry, i.e. the constructed
5872 -- number_simple_entries +
5873 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5874 -- family'length + ...
5876 -- where index-value is the given index value, and s is the index
5877 -- subtype (we have to use pos because the subtype might be an
5878 -- enumeration type preventing direct subtraction). Note that the task
5879 -- entry array is one-indexed.
5881 -- The upper bound of the entry family may be a discriminant, so we
5882 -- retrieve the lower bound explicitly to compute offset, rather than
5883 -- using the index subtype which may mention a discriminant.
5885 if Present
(Index
) then
5886 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
5894 Make_Attribute_Reference
(Sloc
,
5895 Attribute_Name
=> Name_Pos
,
5896 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
5897 Expressions
=> New_List
(Relocate_Node
(Index
))),
5905 -- Now add lengths of preceding entries and entry families
5907 Prev
:= First_Entity
(Ttyp
);
5908 while Chars
(Prev
) /= Chars
(Ent
)
5909 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5910 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5912 if Ekind
(Prev
) = E_Entry
then
5913 Set_Intval
(Num
, Intval
(Num
) + 1);
5915 elsif Ekind
(Prev
) = E_Entry_Family
then
5916 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
5917 Lo
:= Type_Low_Bound
(S
);
5918 Hi
:= Type_High_Bound
(S
);
5923 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5925 -- Other components are anonymous types to be ignored
5935 end Entry_Index_Expression
;
5937 ---------------------------
5938 -- Establish_Task_Master --
5939 ---------------------------
5941 procedure Establish_Task_Master
(N
: Node_Id
) is
5945 if Restriction_Active
(No_Task_Hierarchy
) = False then
5946 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5948 -- The block may have no declarations (and nevertheless be a task
5949 -- master) if it contains a call that may return an object that
5952 if No
(Declarations
(N
)) then
5953 Set_Declarations
(N
, New_List
(Call
));
5955 Prepend_To
(Declarations
(N
), Call
);
5960 end Establish_Task_Master
;
5962 --------------------------------
5963 -- Expand_Accept_Declarations --
5964 --------------------------------
5966 -- Part of the expansion of an accept statement involves the creation of
5967 -- a declaration that can be referenced from the statement sequence of
5972 -- This declaration is inserted immediately before the accept statement
5973 -- and it is important that it be inserted before the statements of the
5974 -- statement sequence are analyzed. Thus it would be too late to create
5975 -- this declaration in the Expand_N_Accept_Statement routine, which is
5976 -- why there is a separate procedure to be called directly from Sem_Ch9.
5978 -- Ann is used to hold the address of the record containing the parameters
5979 -- (see Expand_N_Entry_Call for more details on how this record is built).
5980 -- References to the parameters do an unchecked conversion of this address
5981 -- to a pointer to the required record type, and then access the field that
5982 -- holds the value of the required parameter. The entity for the address
5983 -- variable is held as the top stack element (i.e. the last element) of the
5984 -- Accept_Address stack in the corresponding entry entity, and this element
5985 -- must be set in place before the statements are processed.
5987 -- The above description applies to the case of a stand alone accept
5988 -- statement, i.e. one not appearing as part of a select alternative.
5990 -- For the case of an accept that appears as part of a select alternative
5991 -- of a selective accept, we must still create the declaration right away,
5992 -- since Ann is needed immediately, but there is an important difference:
5994 -- The declaration is inserted before the selective accept, not before
5995 -- the accept statement (which is not part of a list anyway, and so would
5996 -- not accommodate inserted declarations)
5998 -- We only need one address variable for the entire selective accept. So
5999 -- the Ann declaration is created only for the first accept alternative,
6000 -- and subsequent accept alternatives reference the same Ann variable.
6002 -- We can distinguish the two cases by seeing whether the accept statement
6003 -- is part of a list. If not, then it must be in an accept alternative.
6005 -- To expand the requeue statement, a label is provided at the end of the
6006 -- accept statement or alternative of which it is a part, so that the
6007 -- statement can be skipped after the requeue is complete. This label is
6008 -- created here rather than during the expansion of the accept statement,
6009 -- because it will be needed by any requeue statements within the accept,
6010 -- which are expanded before the accept.
6012 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
6013 Loc
: constant Source_Ptr
:= Sloc
(N
);
6014 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6015 Ann
: Entity_Id
:= Empty
;
6022 if Expander_Active
then
6024 -- If we have no handled statement sequence, we may need to build
6025 -- a dummy sequence consisting of a null statement. This can be
6026 -- skipped if the trivial accept optimization is permitted.
6028 if not Trivial_Accept_OK
6029 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6031 Set_Handled_Statement_Sequence
(N
,
6032 Make_Handled_Sequence_Of_Statements
(Loc
,
6033 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
6036 -- Create and declare two labels to be placed at the end of the
6037 -- accept statement. The first label is used to allow requeues to
6038 -- skip the remainder of entry processing. The second label is used
6039 -- to skip the remainder of entry processing if the rendezvous
6040 -- completes in the middle of the accept body.
6042 if Present
(Handled_Statement_Sequence
(N
)) then
6047 Ent
:= Make_Temporary
(Loc
, 'L');
6048 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
6050 Make_Implicit_Label_Declaration
(Loc
,
6051 Defining_Identifier
=> Ent
,
6052 Label_Construct
=> Lab
);
6053 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
6055 Ent
:= Make_Temporary
(Loc
, 'L');
6056 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
6058 Make_Implicit_Label_Declaration
(Loc
,
6059 Defining_Identifier
=> Ent
,
6060 Label_Construct
=> Lab
);
6061 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
6069 -- Case of stand alone accept statement
6071 if Is_List_Member
(N
) then
6073 if Present
(Handled_Statement_Sequence
(N
)) then
6074 Ann
:= Make_Temporary
(Loc
, 'A');
6077 Make_Object_Declaration
(Loc
,
6078 Defining_Identifier
=> Ann
,
6079 Object_Definition
=>
6080 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
6082 Insert_Before_And_Analyze
(N
, Adecl
);
6083 Insert_Before_And_Analyze
(N
, Ldecl
);
6084 Insert_Before_And_Analyze
(N
, Ldecl2
);
6087 -- Case of accept statement which is in an accept alternative
6091 Acc_Alt
: constant Node_Id
:= Parent
(N
);
6092 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
6096 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
6097 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
6099 -- ??? Consider a single label for select statements
6101 if Present
(Handled_Statement_Sequence
(N
)) then
6103 Statements
(Handled_Statement_Sequence
(N
)));
6107 Statements
(Handled_Statement_Sequence
(N
)));
6111 -- Find first accept alternative of the selective accept. A
6112 -- valid selective accept must have at least one accept in it.
6114 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
6116 while Nkind
(Alt
) /= N_Accept_Alternative
loop
6120 -- If this is the first accept statement, then we have to
6121 -- create the Ann variable, as for the stand alone case, except
6122 -- that it is inserted before the selective accept. Similarly,
6123 -- a label for requeue expansion must be declared.
6125 if N
= Accept_Statement
(Alt
) then
6126 Ann
:= Make_Temporary
(Loc
, 'A');
6128 Make_Object_Declaration
(Loc
,
6129 Defining_Identifier
=> Ann
,
6130 Object_Definition
=>
6131 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
6133 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
6135 -- If this is not the first accept statement, then find the Ann
6136 -- variable allocated by the first accept and use it.
6140 Node
(Last_Elmt
(Accept_Address
6141 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
6146 -- Merge here with Ann either created or referenced, and Adecl
6147 -- pointing to the corresponding declaration. Remaining processing
6148 -- is the same for the two cases.
6150 if Present
(Ann
) then
6151 Append_Elmt
(Ann
, Accept_Address
(Ent
));
6152 Set_Debug_Info_Needed
(Ann
);
6155 -- Create renaming declarations for the entry formals. Each reference
6156 -- to a formal becomes a dereference of a component of the parameter
6157 -- block, whose address is held in Ann. These declarations are
6158 -- eventually inserted into the accept block, and analyzed there so
6159 -- that they have the proper scope for gdb and do not conflict with
6160 -- other declarations.
6162 if Present
(Parameter_Specifications
(N
))
6163 and then Present
(Handled_Statement_Sequence
(N
))
6170 Renamed_Formal
: Node_Id
;
6174 Formal
:= First_Formal
(Ent
);
6176 while Present
(Formal
) loop
6177 Comp
:= Entry_Component
(Formal
);
6178 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
6180 Set_Etype
(New_F
, Etype
(Formal
));
6181 Set_Scope
(New_F
, Ent
);
6183 -- Now we set debug info needed on New_F even though it does
6184 -- not come from source, so that the debugger will get the
6185 -- right information for these generated names.
6187 Set_Debug_Info_Needed
(New_F
);
6189 if Ekind
(Formal
) = E_In_Parameter
then
6190 Set_Ekind
(New_F
, E_Constant
);
6192 Set_Ekind
(New_F
, E_Variable
);
6193 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
6196 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
6199 Make_Selected_Component
(Loc
,
6201 Unchecked_Convert_To
(
6202 Entry_Parameters_Type
(Ent
),
6203 New_Occurrence_Of
(Ann
, Loc
)),
6205 New_Occurrence_Of
(Comp
, Loc
));
6208 Build_Renamed_Formal_Declaration
6209 (New_F
, Formal
, Comp
, Renamed_Formal
);
6211 if No
(Declarations
(N
)) then
6212 Set_Declarations
(N
, New_List
);
6215 Append
(Decl
, Declarations
(N
));
6216 Set_Renamed_Object
(Formal
, New_F
);
6217 Next_Formal
(Formal
);
6224 end Expand_Accept_Declarations
;
6226 ---------------------------------------------
6227 -- Expand_Access_Protected_Subprogram_Type --
6228 ---------------------------------------------
6230 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
6231 Loc
: constant Source_Ptr
:= Sloc
(N
);
6232 T
: constant Entity_Id
:= Defining_Identifier
(N
);
6233 D_T
: constant Entity_Id
:= Designated_Type
(T
);
6234 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
6235 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
6236 P_List
: constant List_Id
:=
6237 Build_Protected_Spec
(N
, RTE
(RE_Address
), D_T
, False);
6245 -- Create access to subprogram with full signature
6247 if Etype
(D_T
) /= Standard_Void_Type
then
6249 Make_Access_Function_Definition
(Loc
,
6250 Parameter_Specifications
=> P_List
,
6251 Result_Definition
=>
6252 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
6256 Make_Access_Procedure_Definition
(Loc
,
6257 Parameter_Specifications
=> P_List
);
6261 Make_Full_Type_Declaration
(Loc
,
6262 Defining_Identifier
=> D_T2
,
6263 Type_Definition
=> Def1
);
6265 -- Declare the new types before the original one since the latter will
6266 -- refer to them through the Equivalent_Type slot.
6268 Insert_Before_And_Analyze
(N
, Decl1
);
6270 -- Associate the access to subprogram with its original access to
6271 -- protected subprogram type. Needed by the backend to know that this
6272 -- type corresponds with an access to protected subprogram type.
6274 Set_Original_Access_Type
(D_T2
, T
);
6276 -- Create Equivalent_Type, a record with two components for an access to
6277 -- object and an access to subprogram.
6280 Make_Component_Declaration
(Loc
,
6281 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
6282 Component_Definition
=>
6283 Make_Component_Definition
(Loc
,
6284 Aliased_Present
=> False,
6285 Subtype_Indication
=>
6286 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
6288 Make_Component_Declaration
(Loc
,
6289 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
6290 Component_Definition
=>
6291 Make_Component_Definition
(Loc
,
6292 Aliased_Present
=> False,
6293 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
6296 Make_Full_Type_Declaration
(Loc
,
6297 Defining_Identifier
=> E_T
,
6299 Make_Record_Definition
(Loc
,
6301 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
6303 Insert_Before_And_Analyze
(N
, Decl2
);
6304 Set_Equivalent_Type
(T
, E_T
);
6305 end Expand_Access_Protected_Subprogram_Type
;
6307 --------------------------
6308 -- Expand_Entry_Barrier --
6309 --------------------------
6311 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
6312 Cond
: constant Node_Id
:=
6313 Condition
(Entry_Body_Formal_Part
(N
));
6314 Prot
: constant Entity_Id
:= Scope
(Ent
);
6315 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
6316 Func
: Entity_Id
:= Empty
;
6318 Body_Decl
: Node_Id
;
6320 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
;
6321 -- Check whether entity in Barrier is external to protected type.
6322 -- If so, barrier may not be properly synchronized.
6324 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
;
6325 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6328 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean;
6329 -- Check whether entity name N denotes a component of the protected
6330 -- object. This is used to check the Simple_Barrier restriction.
6332 ----------------------
6333 -- Is_Global_Entity --
6334 ----------------------
6336 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
is
6341 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
6345 if Ekind
(E
) = E_Variable
then
6347 -- If the variable is local to the barrier function generated
6348 -- during expansion, it is ok. If expansion is not performed,
6349 -- then Func is Empty so this test cannot succeed.
6351 if Scope
(E
) = Func
then
6354 -- A protected call from a barrier to another object is ok
6356 elsif Ekind
(Etype
(E
)) = E_Protected_Type
then
6359 -- If the variable is within the package body we consider
6360 -- this safe. This is a common (if dubious) idiom.
6362 elsif S
= Scope
(Prot
)
6363 and then Ekind_In
(S
, E_Package
, E_Generic_Package
)
6364 and then Nkind
(Parent
(E
)) = N_Object_Declaration
6365 and then Nkind
(Parent
(Parent
(E
))) = N_Package_Body
6370 Error_Msg_N
("potentially unsynchronized barrier??", N
);
6371 Error_Msg_N
("\& should be private component of type??", N
);
6377 end Is_Global_Entity
;
6379 procedure Check_Unprotected_Barrier
is
6380 new Traverse_Proc
(Is_Global_Entity
);
6382 ----------------------------
6383 -- Is_Simple_Barrier_Name --
6384 ----------------------------
6386 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean is
6390 -- Check for case of _object.all.field (note that the explicit
6391 -- dereference gets inserted by analyze/expand of _object.field).
6393 if Expander_Active
then
6394 Renamed
:= Renamed_Object
(Entity
(N
));
6398 and then Nkind
(Renamed
) = N_Selected_Component
6399 and then Chars
(Prefix
(Prefix
(Renamed
))) = Name_uObject
;
6401 return Scope
(Entity
(N
)) = Current_Scope
;
6403 end Is_Simple_Barrier_Name
;
6405 ---------------------
6406 -- Is_Pure_Barrier --
6407 ---------------------
6409 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
is
6412 when N_Expanded_Name |
6414 if No
(Entity
(N
)) then
6418 case Ekind
(Entity
(N
)) is
6423 E_Enumeration_Literal
=>
6429 -- A variable in the protected type is expanded as a
6432 if Is_Simple_Barrier_Name
(N
) then
6440 when N_Integer_Literal |
6442 N_Character_Literal
=>
6447 if Ekind
(Entity
(N
)) = E_Operator
then
6451 when N_Short_Circuit
=>
6459 end Is_Pure_Barrier
;
6461 function Check_Pure_Barriers
is new Traverse_Func
(Is_Pure_Barrier
);
6463 -- Start of processing for Expand_Entry_Barrier
6466 if No_Run_Time_Mode
then
6467 Error_Msg_CRT
("entry barrier", N
);
6471 -- The body of the entry barrier must be analyzed in the context of the
6472 -- protected object, but its scope is external to it, just as any other
6473 -- unprotected version of a protected operation. The specification has
6474 -- been produced when the protected type declaration was elaborated. We
6475 -- build the body, insert it in the enclosing scope, but analyze it in
6476 -- the current context. A more uniform approach would be to treat the
6477 -- barrier just as a protected function, and discard the protected
6478 -- version of it because it is never called.
6480 if Expander_Active
then
6481 B_F
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6482 Func
:= Barrier_Function
(Ent
);
6483 Set_Corresponding_Spec
(B_F
, Func
);
6485 Body_Decl
:= Parent
(Corresponding_Body
(Spec_Decl
));
6487 if Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
6488 Body_Decl
:= Corresponding_Stub
(Parent
(Body_Decl
));
6491 Insert_Before_And_Analyze
(Body_Decl
, B_F
);
6493 Set_Discriminals
(Spec_Decl
);
6494 Set_Scope
(Func
, Scope
(Prot
));
6497 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6500 -- Check Pure_Barriers restriction
6502 if Check_Pure_Barriers
(Cond
) = Abandon
then
6503 Check_Restriction
(Pure_Barriers
, Cond
);
6506 -- The Ravenscar profile restricts barriers to simple variables declared
6507 -- within the protected object. We also allow Boolean constants, since
6508 -- these appear in several published examples and are also allowed by
6511 -- Note that after analysis variables in this context will be replaced
6512 -- by the corresponding prival, that is to say a renaming of a selected
6513 -- component of the form _Object.Var. If expansion is disabled, as
6514 -- within a generic, we check that the entity appears in the current
6517 if Is_Entity_Name
(Cond
) then
6519 -- A small optimization of useless renamings. If the scope of the
6520 -- entity of the condition is not the barrier function, then the
6521 -- condition does not reference any of the generated renamings
6522 -- within the function.
6524 if Expander_Active
and then Scope
(Entity
(Cond
)) /= Func
then
6525 Set_Declarations
(B_F
, Empty_List
);
6528 if Entity
(Cond
) = Standard_False
6530 Entity
(Cond
) = Standard_True
6534 elsif Is_Simple_Barrier_Name
(Cond
) then
6539 -- It is not a boolean variable or literal, so check the restriction.
6540 -- Note that it is safe to be calling Check_Restriction from here, even
6541 -- though this is part of the expander, since Expand_Entry_Barrier is
6542 -- called from Sem_Ch9 even in -gnatc mode.
6544 Check_Restriction
(Simple_Barriers
, Cond
);
6546 -- Emit warning if barrier contains global entities and is thus
6547 -- potentially unsynchronized.
6549 Check_Unprotected_Barrier
(Cond
);
6550 end Expand_Entry_Barrier
;
6552 ------------------------------
6553 -- Expand_N_Abort_Statement --
6554 ------------------------------
6556 -- Expand abort T1, T2, .. Tn; into:
6557 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6559 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6560 Loc
: constant Source_Ptr
:= Sloc
(N
);
6561 Tlist
: constant List_Id
:= Names
(N
);
6567 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6570 Tasknm
:= First
(Tlist
);
6572 while Present
(Tasknm
) loop
6575 -- A task interface class-wide type object is being aborted. Retrieve
6576 -- its _task_id by calling a dispatching routine.
6578 if Ada_Version
>= Ada_2005
6579 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6580 and then Is_Interface
(Etype
(Tasknm
))
6581 and then Is_Task_Interface
(Etype
(Tasknm
))
6583 Append_To
(Component_Associations
(Aggr
),
6584 Make_Component_Association
(Loc
,
6585 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6588 -- Task_Id (Tasknm._disp_get_task_id)
6590 Make_Unchecked_Type_Conversion
(Loc
,
6592 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6594 Make_Selected_Component
(Loc
,
6595 Prefix
=> New_Copy_Tree
(Tasknm
),
6597 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6600 Append_To
(Component_Associations
(Aggr
),
6601 Make_Component_Association
(Loc
,
6602 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6603 Expression
=> Concurrent_Ref
(Tasknm
)));
6610 Make_Procedure_Call_Statement
(Loc
,
6611 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Tasks
), Loc
),
6612 Parameter_Associations
=> New_List
(
6613 Make_Qualified_Expression
(Loc
,
6614 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_List
), Loc
),
6615 Expression
=> Aggr
))));
6618 end Expand_N_Abort_Statement
;
6620 -------------------------------
6621 -- Expand_N_Accept_Statement --
6622 -------------------------------
6624 -- This procedure handles expansion of accept statements that stand alone,
6625 -- i.e. they are not part of an accept alternative. The expansion of
6626 -- accept statement in accept alternatives is handled by the routines
6627 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6628 -- following description applies only to stand alone accept statements.
6630 -- If there is no handled statement sequence, or only null statements, then
6631 -- this is called a trivial accept, and the expansion is:
6633 -- Accept_Trivial (entry-index)
6635 -- If there is a handled statement sequence, then the expansion is:
6642 -- Accept_Call (entry-index, Ann);
6643 -- Renaming_Declarations for formals
6644 -- <statement sequence from N_Accept_Statement node>
6645 -- Complete_Rendezvous;
6650 -- <exception handler from N_Accept_Statement node>
6651 -- Complete_Rendezvous;
6653 -- <exception handler from N_Accept_Statement node>
6654 -- Complete_Rendezvous;
6659 -- when all others =>
6660 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6663 -- The first three declarations were already inserted ahead of the accept
6664 -- statement by the Expand_Accept_Declarations procedure, which was called
6665 -- directly from the semantics during analysis of the accept statement,
6666 -- before analyzing its contained statements.
6668 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6669 -- from possible expansion activity (the original source of course does
6670 -- not have any declarations associated with the accept statement, since
6671 -- an accept statement has no declarative part). In particular, if the
6672 -- expander is active, the first such declaration is the declaration of
6673 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6675 -- The two blocks are merged into a single block if the inner block has
6676 -- no exception handlers, but otherwise two blocks are required, since
6677 -- exceptions might be raised in the exception handlers of the inner
6678 -- block, and Exceptional_Complete_Rendezvous must be called.
6680 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6681 Loc
: constant Source_Ptr
:= Sloc
(N
);
6682 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6683 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6684 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6685 Eent
: constant Entity_Id
:= Entity
(Ename
);
6686 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6687 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6688 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6694 -- If the accept statement is not part of a list, then its parent must
6695 -- be an accept alternative, and, as described above, we do not do any
6696 -- expansion for such accept statements at this level.
6698 if not Is_List_Member
(N
) then
6699 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6702 -- Trivial accept case (no statement sequence, or null statements).
6703 -- If the accept statement has declarations, then just insert them
6704 -- before the procedure call.
6706 elsif Trivial_Accept_OK
6707 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6709 -- Remove declarations for renamings, because the parameter block
6710 -- will not be assigned.
6717 D
:= First
(Declarations
(N
));
6718 while Present
(D
) loop
6720 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6728 if Present
(Declarations
(N
)) then
6729 Insert_Actions
(N
, Declarations
(N
));
6733 Make_Procedure_Call_Statement
(Loc
,
6734 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Trivial
), Loc
),
6735 Parameter_Associations
=> New_List
(
6736 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6740 -- Discard Entry_Address that was created for it, so it will not be
6741 -- emitted if this accept statement is in the statement part of a
6742 -- delay alternative.
6744 if Present
(Stats
) then
6745 Remove_Last_Elmt
(Acstack
);
6748 -- Case of statement sequence present
6751 -- Construct the block, using the declarations from the accept
6752 -- statement if any to initialize the declarations of the block.
6754 Blkent
:= Make_Temporary
(Loc
, 'A');
6755 Set_Ekind
(Blkent
, E_Block
);
6756 Set_Etype
(Blkent
, Standard_Void_Type
);
6757 Set_Scope
(Blkent
, Current_Scope
);
6760 Make_Block_Statement
(Loc
,
6761 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
6762 Declarations
=> Declarations
(N
),
6763 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6765 -- For the analysis of the generated declarations, the parent node
6766 -- must be properly set.
6768 Set_Parent
(Block
, Parent
(N
));
6770 -- Prepend call to Accept_Call to main statement sequence If the
6771 -- accept has exception handlers, the statement sequence is wrapped
6772 -- in a block. Insert call and renaming declarations in the
6773 -- declarations of the block, so they are elaborated before the
6777 Make_Procedure_Call_Statement
(Loc
,
6778 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Call
), Loc
),
6779 Parameter_Associations
=> New_List
(
6780 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6781 New_Occurrence_Of
(Ann
, Loc
)));
6783 if Parent
(Stats
) = N
then
6784 Prepend
(Call
, Statements
(Stats
));
6786 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6791 Push_Scope
(Blkent
);
6799 D
:= First
(Declarations
(N
));
6800 while Present
(D
) loop
6803 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6805 -- The renaming declarations for the formals were created
6806 -- during analysis of the accept statement, and attached to
6807 -- the list of declarations. Place them now in the context
6808 -- of the accept block or subprogram.
6811 Typ
:= Entity
(Subtype_Mark
(D
));
6812 Insert_After
(Call
, D
);
6815 -- If the formal is class_wide, it does not have an actual
6816 -- subtype. The analysis of the renaming declaration creates
6817 -- one, but we need to retain the class-wide nature of the
6820 if Is_Class_Wide_Type
(Typ
) then
6821 Set_Etype
(Defining_Identifier
(D
), Typ
);
6832 -- Replace the accept statement by the new block
6837 -- Last step is to unstack the Accept_Address value
6839 Remove_Last_Elmt
(Acstack
);
6841 end Expand_N_Accept_Statement
;
6843 ----------------------------------
6844 -- Expand_N_Asynchronous_Select --
6845 ----------------------------------
6847 -- This procedure assumes that the trigger statement is an entry call or
6848 -- a dispatching procedure call. A delay alternative should already have
6849 -- been expanded into an entry call to the appropriate delay object Wait
6852 -- If the trigger is a task entry call, the select is implemented with
6853 -- a Task_Entry_Call:
6858 -- P : parms := (parm, parm, parm);
6860 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6862 -- procedure _clean is
6865 -- Cancel_Task_Entry_Call (C);
6872 -- (<acceptor-task>, -- Acceptor
6873 -- <entry-index>, -- E
6874 -- P'Address, -- Uninterpreted_Data
6875 -- Asynchronous_Call, -- Mode
6876 -- B); -- Rendezvous_Successful
6883 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6886 -- when Abort_Signal => Abort_Undefer;
6893 -- <triggered-statements>
6897 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6898 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6902 -- P : parms := (parm, parm, parm);
6904 -- Call_Simple (acceptor-task, entry-index, P'Address);
6910 -- so the task at hand is to convert the latter expansion into the former
6912 -- If the trigger is a protected entry call, the select is implemented
6913 -- with Protected_Entry_Call:
6916 -- P : E1_Params := (param, param, param);
6917 -- Bnn : Communications_Block;
6922 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6924 -- procedure _clean is
6927 -- if Enqueued (Bnn) then
6928 -- Cancel_Protected_Entry_Call (Bnn);
6935 -- Protected_Entry_Call
6936 -- (po._object'Access, -- Object
6937 -- <entry index>, -- E
6938 -- P'Address, -- Uninterpreted_Data
6939 -- Asynchronous_Call, -- Mode
6942 -- if Enqueued (Bnn) then
6946 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6949 -- when Abort_Signal => Abort_Undefer;
6952 -- if not Cancelled (Bnn) then
6953 -- <triggered-statements>
6957 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6961 -- P : E1_Params := (param, param, param);
6962 -- Bnn : Communications_Block;
6965 -- Protected_Entry_Call
6966 -- (po._object'Access, -- Object
6967 -- <entry index>, -- E
6968 -- P'Address, -- Uninterpreted_Data
6969 -- Simple_Call, -- Mode
6976 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6980 -- B : Boolean := False;
6981 -- Bnn : Communication_Block;
6982 -- C : Ada.Tags.Prim_Op_Kind;
6983 -- D : System.Storage_Elements.Dummy_Communication_Block;
6984 -- K : Ada.Tags.Tagged_Kind :=
6985 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6986 -- P : Parameters := (Param1 .. ParamN);
6991 -- if K = Ada.Tags.TK_Limited_Tagged
6992 -- or else K = Ada.Tags.TK_Tagged
6994 -- <dispatching-call>;
6995 -- <triggering-statements>;
6999 -- Ada.Tags.Get_Offset_Index
7000 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7002 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7004 -- if C = POK_Protected_Entry then
7006 -- procedure _clean is
7008 -- if Enqueued (Bnn) then
7009 -- Cancel_Protected_Entry_Call (Bnn);
7015 -- _Disp_Asynchronous_Select
7016 -- (<object>, S, P'Address, D, B);
7017 -- Bnn := Communication_Block (D);
7019 -- Param1 := P.Param1;
7021 -- ParamN := P.ParamN;
7023 -- if Enqueued (Bnn) then
7024 -- <abortable-statements>
7027 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7030 -- when Abort_Signal => Abort_Undefer;
7033 -- if not Cancelled (Bnn) then
7034 -- <triggering-statements>
7037 -- elsif C = POK_Task_Entry then
7039 -- procedure _clean is
7041 -- Cancel_Task_Entry_Call (U);
7047 -- _Disp_Asynchronous_Select
7048 -- (<object>, S, P'Address, D, B);
7049 -- Bnn := Communication_Bloc (D);
7051 -- Param1 := P.Param1;
7053 -- ParamN := P.ParamN;
7058 -- <abortable-statements>
7060 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7063 -- when Abort_Signal => Abort_Undefer;
7067 -- <triggering-statements>
7072 -- <dispatching-call>;
7073 -- <triggering-statements>
7078 -- The job is to convert this to the asynchronous form
7080 -- If the trigger is a delay statement, it will have been expanded into
7081 -- a call to one of the GNARL delay procedures. This routine will convert
7082 -- this into a protected entry call on a delay object and then continue
7083 -- processing as for a protected entry call trigger. This requires
7084 -- declaring a Delay_Block object and adding a pointer to this object to
7085 -- the parameter list of the delay procedure to form the parameter list of
7086 -- the entry call. This object is used by the runtime to queue the delay
7089 -- For a description of the use of P and the assignments after the call,
7090 -- see Expand_N_Entry_Call_Statement.
7092 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
7093 Loc
: constant Source_Ptr
:= Sloc
(N
);
7094 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
7095 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
7097 Abort_Block_Ent
: Entity_Id
;
7098 Abortable_Block
: Node_Id
;
7101 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7102 Blk_Typ
: Entity_Id
;
7104 Call_Ent
: Entity_Id
;
7105 Cancel_Param
: Entity_Id
;
7106 Cleanup_Block
: Node_Id
;
7107 Cleanup_Block_Ent
: Entity_Id
;
7108 Cleanup_Stmts
: List_Id
;
7109 Conc_Typ_Stmts
: List_Id
;
7111 Dblock_Ent
: Entity_Id
;
7116 Enqueue_Call
: Node_Id
;
7119 Handler_Stmt
: Node_Id
;
7121 Lim_Typ_Stmts
: List_Id
;
7127 ProtE_Stmts
: List_Id
;
7128 ProtP_Stmts
: List_Id
;
7131 TaskE_Stmts
: List_Id
;
7134 B
: Entity_Id
; -- Call status flag
7135 Bnn
: Entity_Id
; -- Communication block
7136 C
: Entity_Id
; -- Call kind
7137 K
: Entity_Id
; -- Tagged kind
7138 P
: Entity_Id
; -- Parameter block
7139 S
: Entity_Id
; -- Primitive operation slot
7140 T
: Entity_Id
; -- Additional status flag
7142 procedure Rewrite_Abortable_Part
;
7143 -- If the trigger is a dispatching call, the expansion inserts multiple
7144 -- copies of the abortable part. This is both inefficient, and may lead
7145 -- to duplicate definitions that the back-end will reject, when the
7146 -- abortable part includes loops. This procedure rewrites the abortable
7147 -- part into a call to a generated procedure.
7149 ----------------------------
7150 -- Rewrite_Abortable_Part --
7151 ----------------------------
7153 procedure Rewrite_Abortable_Part
is
7154 Proc
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7159 Make_Subprogram_Body
(Loc
,
7161 Make_Procedure_Specification
(Loc
, Defining_Unit_Name
=> Proc
),
7162 Declarations
=> New_List
,
7163 Handled_Statement_Sequence
=>
7164 Make_Handled_Sequence_Of_Statements
(Loc
, Astats
));
7165 Insert_Before
(N
, Decl
);
7168 -- Rewrite abortable part into a call to this procedure.
7172 Make_Procedure_Call_Statement
(Loc
,
7173 Name
=> New_Occurrence_Of
(Proc
, Loc
)));
7174 end Rewrite_Abortable_Part
;
7176 -- Start of processing for Expand_N_Asynchronous_Select
7179 -- Asynchronous select is not supported on restricted runtimes. Don't
7182 if Restricted_Profile
then
7186 Process_Statements_For_Controlled_Objects
(Trig
);
7187 Process_Statements_For_Controlled_Objects
(Abrt
);
7189 Ecall
:= Triggering_Statement
(Trig
);
7191 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
7193 -- Retrieve Astats and Tstats now because the finalization machinery may
7194 -- wrap them in blocks.
7196 Astats
:= Statements
(Abrt
);
7197 Tstats
:= Statements
(Trig
);
7199 -- The arguments in the call may require dynamic allocation, and the
7200 -- call statement may have been transformed into a block. The block
7201 -- may contain additional declarations for internal entities, and the
7202 -- original call is found by sequential search.
7204 if Nkind
(Ecall
) = N_Block_Statement
then
7205 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
7206 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
7207 N_Entry_Call_Statement
)
7213 -- This is either a dispatching call or a delay statement used as a
7214 -- trigger which was expanded into a procedure call.
7216 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
7217 if Ada_Version
>= Ada_2005
7219 (No
(Original_Node
(Ecall
))
7220 or else not Nkind_In
(Original_Node
(Ecall
),
7221 N_Delay_Relative_Statement
,
7222 N_Delay_Until_Statement
))
7224 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
7226 Rewrite_Abortable_Part
;
7230 -- Call status flag processing, generate:
7231 -- B : Boolean := False;
7233 B
:= Build_B
(Loc
, Decls
);
7235 -- Communication block processing, generate:
7236 -- Bnn : Communication_Block;
7238 Bnn
:= Make_Temporary
(Loc
, 'B');
7240 Make_Object_Declaration
(Loc
,
7241 Defining_Identifier
=> Bnn
,
7242 Object_Definition
=>
7243 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
7245 -- Call kind processing, generate:
7246 -- C : Ada.Tags.Prim_Op_Kind;
7248 C
:= Build_C
(Loc
, Decls
);
7250 -- Tagged kind processing, generate:
7251 -- K : Ada.Tags.Tagged_Kind :=
7252 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7254 -- Dummy communication block, generate:
7255 -- D : Dummy_Communication_Block;
7258 Make_Object_Declaration
(Loc
,
7259 Defining_Identifier
=>
7260 Make_Defining_Identifier
(Loc
, Name_uD
),
7261 Object_Definition
=>
7263 (RTE
(RE_Dummy_Communication_Block
), Loc
)));
7265 K
:= Build_K
(Loc
, Decls
, Obj
);
7267 -- Parameter block processing
7269 Blk_Typ
:= Build_Parameter_Block
7270 (Loc
, Actuals
, Formals
, Decls
);
7271 P
:= Parameter_Block_Pack
7272 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7274 -- Dispatch table slot processing, generate:
7277 S
:= Build_S
(Loc
, Decls
);
7279 -- Additional status flag processing, generate:
7282 T
:= Make_Temporary
(Loc
, 'T');
7284 Make_Object_Declaration
(Loc
,
7285 Defining_Identifier
=> T
,
7286 Object_Definition
=>
7287 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7289 ------------------------------
7290 -- Protected entry handling --
7291 ------------------------------
7294 -- Param1 := P.Param1;
7296 -- ParamN := P.ParamN;
7298 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7301 -- Bnn := Communication_Block (D);
7303 Prepend_To
(Cleanup_Stmts
,
7304 Make_Assignment_Statement
(Loc
,
7305 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
7307 Make_Unchecked_Type_Conversion
(Loc
,
7309 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7310 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7313 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7315 Prepend_To
(Cleanup_Stmts
,
7316 Make_Procedure_Call_Statement
(Loc
,
7320 (Etype
(Etype
(Obj
)), Name_uDisp_Asynchronous_Select
),
7322 Parameter_Associations
=>
7324 New_Copy_Tree
(Obj
), -- <object>
7325 New_Occurrence_Of
(S
, Loc
), -- S
7326 Make_Attribute_Reference
(Loc
, -- P'Address
7327 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7328 Attribute_Name
=> Name_Address
),
7329 Make_Identifier
(Loc
, Name_uD
), -- D
7330 New_Occurrence_Of
(B
, Loc
)))); -- B
7333 -- if Enqueued (Bnn) then
7334 -- <abortable-statements>
7337 Append_To
(Cleanup_Stmts
,
7338 Make_Implicit_If_Statement
(N
,
7340 Make_Function_Call
(Loc
,
7342 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7343 Parameter_Associations
=>
7344 New_List
(New_Occurrence_Of
(Bnn
, Loc
))),
7347 New_Copy_List_Tree
(Astats
)));
7349 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7350 -- will then generate a _clean for the communication block Bnn.
7354 -- procedure _clean is
7356 -- if Enqueued (Bnn) then
7357 -- Cancel_Protected_Entry_Call (Bnn);
7366 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7368 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
7370 -- Wrap the cleanup block in an exception handling block
7376 -- when Abort_Signal => Abort_Undefer;
7379 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7382 Make_Implicit_Label_Declaration
(Loc
,
7383 Defining_Identifier
=> Abort_Block_Ent
),
7386 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7389 -- if not Cancelled (Bnn) then
7390 -- <triggering-statements>
7393 Append_To
(ProtE_Stmts
,
7394 Make_Implicit_If_Statement
(N
,
7398 Make_Function_Call
(Loc
,
7400 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7401 Parameter_Associations
=>
7402 New_List
(New_Occurrence_Of
(Bnn
, Loc
)))),
7405 New_Copy_List_Tree
(Tstats
)));
7407 -------------------------
7408 -- Task entry handling --
7409 -------------------------
7412 -- Param1 := P.Param1;
7414 -- ParamN := P.ParamN;
7416 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7419 -- Bnn := Communication_Block (D);
7421 Append_To
(TaskE_Stmts
,
7422 Make_Assignment_Statement
(Loc
,
7424 New_Occurrence_Of
(Bnn
, Loc
),
7426 Make_Unchecked_Type_Conversion
(Loc
,
7428 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7429 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7432 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7434 Prepend_To
(TaskE_Stmts
,
7435 Make_Procedure_Call_Statement
(Loc
,
7438 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7439 Name_uDisp_Asynchronous_Select
),
7442 Parameter_Associations
=> New_List
(
7443 New_Copy_Tree
(Obj
), -- <object>
7444 New_Occurrence_Of
(S
, Loc
), -- S
7445 Make_Attribute_Reference
(Loc
, -- P'Address
7446 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7447 Attribute_Name
=> Name_Address
),
7448 Make_Identifier
(Loc
, Name_uD
), -- D
7449 New_Occurrence_Of
(B
, Loc
)))); -- B
7454 Prepend_To
(TaskE_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7458 -- <abortable-statements>
7460 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
7463 (Cleanup_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7465 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7466 -- will generate a _clean for the additional status flag.
7470 -- procedure _clean is
7472 -- Cancel_Task_Entry_Call (U);
7480 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7482 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
7484 -- Wrap the cleanup block in an exception handling block
7490 -- when Abort_Signal => Abort_Undefer;
7493 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7495 Append_To
(TaskE_Stmts
,
7496 Make_Implicit_Label_Declaration
(Loc
,
7497 Defining_Identifier
=> Abort_Block_Ent
));
7499 Append_To
(TaskE_Stmts
,
7501 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7505 -- <triggering-statements>
7508 Append_To
(TaskE_Stmts
,
7509 Make_Implicit_If_Statement
(N
,
7511 Make_Op_Not
(Loc
, Right_Opnd
=> New_Occurrence_Of
(T
, Loc
)),
7514 New_Copy_List_Tree
(Tstats
)));
7516 ----------------------------------
7517 -- Protected procedure handling --
7518 ----------------------------------
7521 -- <dispatching-call>;
7522 -- <triggering-statements>
7524 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7525 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7528 -- S := Ada.Tags.Get_Offset_Index
7529 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7532 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7535 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7537 Append_To
(Conc_Typ_Stmts
,
7538 Make_Procedure_Call_Statement
(Loc
,
7541 (Find_Prim_Op
(Etype
(Etype
(Obj
)),
7542 Name_uDisp_Get_Prim_Op_Kind
),
7544 Parameter_Associations
=>
7546 New_Copy_Tree
(Obj
),
7547 New_Occurrence_Of
(S
, Loc
),
7548 New_Occurrence_Of
(C
, Loc
))));
7551 -- if C = POK_Procedure_Entry then
7553 -- elsif C = POK_Task_Entry then
7559 Append_To
(Conc_Typ_Stmts
,
7560 Make_Implicit_If_Statement
(N
,
7564 New_Occurrence_Of
(C
, Loc
),
7566 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7573 Make_Elsif_Part
(Loc
,
7577 New_Occurrence_Of
(C
, Loc
),
7579 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
)),
7588 -- <dispatching-call>;
7589 -- <triggering-statements>
7591 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7592 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7595 -- if K = Ada.Tags.TK_Limited_Tagged
7596 -- or else K = Ada.Tags.TK_Tagged
7604 Make_Implicit_If_Statement
(N
,
7605 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
7606 Then_Statements
=> Lim_Typ_Stmts
,
7607 Else_Statements
=> Conc_Typ_Stmts
));
7610 Make_Block_Statement
(Loc
,
7613 Handled_Statement_Sequence
=>
7614 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7619 -- Delay triggering statement processing
7622 -- Add a Delay_Block object to the parameter list of the delay
7623 -- procedure to form the parameter list of the Wait entry call.
7625 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7627 Pdef
:= Entity
(Name
(Ecall
));
7629 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7631 New_Occurrence_Of
(RTE
(RE_Enqueue_Duration
), Loc
);
7633 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7635 New_Occurrence_Of
(RTE
(RE_Enqueue_Calendar
), Loc
);
7637 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7638 Enqueue_Call
:= New_Occurrence_Of
(RTE
(RE_Enqueue_RT
), Loc
);
7641 Append_To
(Parameter_Associations
(Ecall
),
7642 Make_Attribute_Reference
(Loc
,
7643 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7644 Attribute_Name
=> Name_Unchecked_Access
));
7646 -- Create the inner block to protect the abortable part
7648 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7650 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7653 Make_Block_Statement
(Loc
,
7654 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7655 Handled_Statement_Sequence
=>
7656 Make_Handled_Sequence_Of_Statements
(Loc
,
7657 Statements
=> Astats
),
7658 Has_Created_Identifier
=> True,
7659 Is_Asynchronous_Call_Block
=> True);
7661 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7664 Make_Implicit_If_Statement
(N
,
7666 Make_Function_Call
(Loc
,
7667 Name
=> Enqueue_Call
,
7668 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7670 New_List
(Make_Block_Statement
(Loc
,
7671 Handled_Statement_Sequence
=>
7672 Make_Handled_Sequence_Of_Statements
(Loc
,
7673 Statements
=> New_List
(
7674 Make_Implicit_Label_Declaration
(Loc
,
7675 Defining_Identifier
=> Blk_Ent
,
7676 Label_Construct
=> Abortable_Block
),
7678 Exception_Handlers
=> Hdle
)))));
7680 Stmts
:= New_List
(Ecall
);
7682 -- Construct statement sequence for new block
7685 Make_Implicit_If_Statement
(N
,
7687 Make_Function_Call
(Loc
,
7688 Name
=> New_Occurrence_Of
(
7689 RTE
(RE_Timed_Out
), Loc
),
7690 Parameter_Associations
=> New_List
(
7691 Make_Attribute_Reference
(Loc
,
7692 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7693 Attribute_Name
=> Name_Unchecked_Access
))),
7694 Then_Statements
=> Tstats
));
7696 -- The result is the new block
7698 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7701 Make_Block_Statement
(Loc
,
7702 Declarations
=> New_List
(
7703 Make_Object_Declaration
(Loc
,
7704 Defining_Identifier
=> Dblock_Ent
,
7705 Aliased_Present
=> True,
7706 Object_Definition
=>
7707 New_Occurrence_Of
(RTE
(RE_Delay_Block
), Loc
))),
7709 Handled_Statement_Sequence
=>
7710 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7720 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7721 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7723 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7724 Decls
:= Declarations
(Ecall
);
7726 if Is_Protected_Type
(Etype
(Concval
)) then
7728 -- Get the declarations of the block expanded from the entry call
7730 Decl
:= First
(Decls
);
7731 while Present
(Decl
)
7732 and then (Nkind
(Decl
) /= N_Object_Declaration
7733 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7734 RE_Communication_Block
))
7739 pragma Assert
(Present
(Decl
));
7740 Cancel_Param
:= Defining_Identifier
(Decl
);
7742 -- Change the mode of the Protected_Entry_Call call
7744 -- Protected_Entry_Call (
7745 -- Object => po._object'Access,
7746 -- E => <entry index>;
7747 -- Uninterpreted_Data => P'Address;
7748 -- Mode => Asynchronous_Call;
7751 -- Skip assignments to temporaries created for in-out parameters
7753 -- This makes unwarranted assumptions about the shape of the expanded
7754 -- tree for the call, and should be cleaned up ???
7756 Stmt
:= First
(Stmts
);
7757 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7763 Param
:= First
(Parameter_Associations
(Call
));
7764 while Present
(Param
)
7765 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7770 pragma Assert
(Present
(Param
));
7771 Rewrite
(Param
, New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7774 -- Append an if statement to execute the abortable part
7777 -- if Enqueued (Bnn) then
7780 Make_Implicit_If_Statement
(N
,
7782 Make_Function_Call
(Loc
,
7783 Name
=> New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7784 Parameter_Associations
=> New_List
(
7785 New_Occurrence_Of
(Cancel_Param
, Loc
))),
7786 Then_Statements
=> Astats
));
7789 Make_Block_Statement
(Loc
,
7790 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7791 Handled_Statement_Sequence
=>
7792 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7793 Has_Created_Identifier
=> True,
7794 Is_Asynchronous_Call_Block
=> True);
7796 -- Aborts are not deferred at beginning of exception handlers in
7799 if ZCX_Exceptions
then
7800 Handler_Stmt
:= Make_Null_Statement
(Loc
);
7803 Handler_Stmt
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
7807 Make_Block_Statement
(Loc
,
7808 Handled_Statement_Sequence
=>
7809 Make_Handled_Sequence_Of_Statements
(Loc
,
7810 Statements
=> New_List
(
7811 Make_Implicit_Label_Declaration
(Loc
,
7812 Defining_Identifier
=> Blk_Ent
,
7813 Label_Construct
=> Abortable_Block
),
7818 Exception_Handlers
=> New_List
(
7819 Make_Implicit_Exception_Handler
(Loc
,
7821 -- when Abort_Signal =>
7822 -- Abort_Undefer.all;
7824 Exception_Choices
=>
7825 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
7826 Statements
=> New_List
(Handler_Stmt
))))),
7828 -- if not Cancelled (Bnn) then
7829 -- triggered statements
7832 Make_Implicit_If_Statement
(N
,
7833 Condition
=> Make_Op_Not
(Loc
,
7835 Make_Function_Call
(Loc
,
7836 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7837 Parameter_Associations
=> New_List
(
7838 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7839 Then_Statements
=> Tstats
));
7841 -- Asynchronous task entry call
7848 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7850 -- Insert declaration of B in declarations of existing block
7853 Make_Object_Declaration
(Loc
,
7854 Defining_Identifier
=> B
,
7855 Object_Definition
=>
7856 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7858 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7860 -- Insert declaration of C in declarations of existing block
7863 Make_Object_Declaration
(Loc
,
7864 Defining_Identifier
=> Cancel_Param
,
7865 Object_Definition
=>
7866 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7868 -- Remove and save the call to Call_Simple
7870 Stmt
:= First
(Stmts
);
7872 -- Skip assignments to temporaries created for in-out parameters.
7873 -- This makes unwarranted assumptions about the shape of the expanded
7874 -- tree for the call, and should be cleaned up ???
7876 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7882 -- Create the inner block to protect the abortable part
7884 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7886 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7889 Make_Block_Statement
(Loc
,
7890 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7891 Handled_Statement_Sequence
=>
7892 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7893 Has_Created_Identifier
=> True,
7894 Is_Asynchronous_Call_Block
=> True);
7897 Make_Block_Statement
(Loc
,
7898 Handled_Statement_Sequence
=>
7899 Make_Handled_Sequence_Of_Statements
(Loc
,
7900 Statements
=> New_List
(
7901 Make_Implicit_Label_Declaration
(Loc
,
7902 Defining_Identifier
=> Blk_Ent
,
7903 Label_Construct
=> Abortable_Block
),
7905 Exception_Handlers
=> Hdle
)));
7907 -- Create new call statement
7909 Params
:= Parameter_Associations
(Call
);
7912 New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7913 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
7916 Make_Procedure_Call_Statement
(Loc
,
7917 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
7918 Parameter_Associations
=> Params
));
7920 -- Construct statement sequence for new block
7923 Make_Implicit_If_Statement
(N
,
7925 Make_Op_Not
(Loc
, New_Occurrence_Of
(Cancel_Param
, Loc
)),
7926 Then_Statements
=> Tstats
));
7928 -- Protected the call against abort
7930 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7933 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7935 -- The result is the new block
7938 Make_Block_Statement
(Loc
,
7939 Declarations
=> Decls
,
7940 Handled_Statement_Sequence
=>
7941 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7944 end Expand_N_Asynchronous_Select
;
7946 -------------------------------------
7947 -- Expand_N_Conditional_Entry_Call --
7948 -------------------------------------
7950 -- The conditional task entry call is converted to a call to
7955 -- P : parms := (parm, parm, parm);
7959 -- (<acceptor-task>, -- Acceptor
7960 -- <entry-index>, -- E
7961 -- P'Address, -- Uninterpreted_Data
7962 -- Conditional_Call, -- Mode
7963 -- B); -- Rendezvous_Successful
7968 -- normal-statements
7974 -- For a description of the use of P and the assignments after the call,
7975 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7976 -- conditional entry call has already been expanded (by the Expand_N_Entry
7977 -- _Call_Statement procedure) as follows:
7980 -- P : parms := (parm, parm, parm);
7982 -- ... info for in-out parameters
7983 -- Call_Simple (acceptor-task, entry-index, P'Address);
7989 -- so the task at hand is to convert the latter expansion into the former
7991 -- The conditional protected entry call is converted to a call to
7992 -- Protected_Entry_Call:
7995 -- P : parms := (parm, parm, parm);
7996 -- Bnn : Communications_Block;
7999 -- Protected_Entry_Call
8000 -- (po._object'Access, -- Object
8001 -- <entry index>, -- E
8002 -- P'Address, -- Uninterpreted_Data
8003 -- Conditional_Call, -- Mode
8008 -- if Cancelled (Bnn) then
8011 -- normal-statements
8015 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
8019 -- B : Boolean := False;
8020 -- C : Ada.Tags.Prim_Op_Kind;
8021 -- K : Ada.Tags.Tagged_Kind :=
8022 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8023 -- P : Parameters := (Param1 .. ParamN);
8027 -- if K = Ada.Tags.TK_Limited_Tagged
8028 -- or else K = Ada.Tags.TK_Tagged
8030 -- <dispatching-call>;
8031 -- <triggering-statements>
8035 -- Ada.Tags.Get_Offset_Index
8036 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
8038 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8040 -- if C = POK_Protected_Entry
8041 -- or else C = POK_Task_Entry
8043 -- Param1 := P.Param1;
8045 -- ParamN := P.ParamN;
8049 -- if C = POK_Procedure
8050 -- or else C = POK_Protected_Procedure
8051 -- or else C = POK_Task_Procedure
8053 -- <dispatching-call>;
8056 -- <triggering-statements>
8058 -- <else-statements>
8063 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
8064 Loc
: constant Source_Ptr
:= Sloc
(N
);
8065 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
8066 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
8069 Blk_Typ
: Entity_Id
;
8071 Call_Ent
: Entity_Id
;
8072 Conc_Typ_Stmts
: List_Id
;
8076 Lim_Typ_Stmts
: List_Id
;
8083 Transient_Blk
: Node_Id
;
8086 B
: Entity_Id
; -- Call status flag
8087 C
: Entity_Id
; -- Call kind
8088 K
: Entity_Id
; -- Tagged kind
8089 P
: Entity_Id
; -- Parameter block
8090 S
: Entity_Id
; -- Primitive operation slot
8093 Process_Statements_For_Controlled_Objects
(N
);
8095 if Ada_Version
>= Ada_2005
8096 and then Nkind
(Blk
) = N_Procedure_Call_Statement
8098 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
8103 -- Call status flag processing, generate:
8104 -- B : Boolean := False;
8106 B
:= Build_B
(Loc
, Decls
);
8108 -- Call kind processing, generate:
8109 -- C : Ada.Tags.Prim_Op_Kind;
8111 C
:= Build_C
(Loc
, Decls
);
8113 -- Tagged kind processing, generate:
8114 -- K : Ada.Tags.Tagged_Kind :=
8115 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8117 K
:= Build_K
(Loc
, Decls
, Obj
);
8119 -- Parameter block processing
8121 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
8122 P
:= Parameter_Block_Pack
8123 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
8125 -- Dispatch table slot processing, generate:
8128 S
:= Build_S
(Loc
, Decls
);
8131 -- S := Ada.Tags.Get_Offset_Index
8132 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
8135 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
8138 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8140 Append_To
(Conc_Typ_Stmts
,
8141 Make_Procedure_Call_Statement
(Loc
,
8144 Find_Prim_Op
(Etype
(Etype
(Obj
)),
8145 Name_uDisp_Conditional_Select
),
8147 Parameter_Associations
=>
8149 New_Copy_Tree
(Obj
), -- <object>
8150 New_Occurrence_Of
(S
, Loc
), -- S
8151 Make_Attribute_Reference
(Loc
, -- P'Address
8152 Prefix
=> New_Occurrence_Of
(P
, Loc
),
8153 Attribute_Name
=> Name_Address
),
8154 New_Occurrence_Of
(C
, Loc
), -- C
8155 New_Occurrence_Of
(B
, Loc
)))); -- B
8158 -- if C = POK_Protected_Entry
8159 -- or else C = POK_Task_Entry
8161 -- Param1 := P.Param1;
8163 -- ParamN := P.ParamN;
8166 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
8168 -- Generate the if statement only when the packed parameters need
8169 -- explicit assignments to their corresponding actuals.
8171 if Present
(Unpack
) then
8172 Append_To
(Conc_Typ_Stmts
,
8173 Make_Implicit_If_Statement
(N
,
8179 New_Occurrence_Of
(C
, Loc
),
8181 New_Occurrence_Of
(RTE
(
8182 RE_POK_Protected_Entry
), Loc
)),
8187 New_Occurrence_Of
(C
, Loc
),
8189 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
8191 Then_Statements
=> Unpack
));
8196 -- if C = POK_Procedure
8197 -- or else C = POK_Protected_Procedure
8198 -- or else C = POK_Task_Procedure
8200 -- <dispatching-call>
8202 -- <normal-statements>
8204 -- <else-statements>
8207 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
8209 Prepend_To
(N_Stats
,
8210 Make_Implicit_If_Statement
(N
,
8216 New_Occurrence_Of
(C
, Loc
),
8218 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
8225 New_Occurrence_Of
(C
, Loc
),
8227 New_Occurrence_Of
(RTE
(
8228 RE_POK_Protected_Procedure
), Loc
)),
8233 New_Occurrence_Of
(C
, Loc
),
8235 New_Occurrence_Of
(RTE
(
8236 RE_POK_Task_Procedure
), Loc
)))),
8241 Append_To
(Conc_Typ_Stmts
,
8242 Make_Implicit_If_Statement
(N
,
8243 Condition
=> New_Occurrence_Of
(B
, Loc
),
8244 Then_Statements
=> N_Stats
,
8245 Else_Statements
=> Else_Statements
(N
)));
8248 -- <dispatching-call>;
8249 -- <triggering-statements>
8251 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
8252 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
8255 -- if K = Ada.Tags.TK_Limited_Tagged
8256 -- or else K = Ada.Tags.TK_Tagged
8264 Make_Implicit_If_Statement
(N
,
8265 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
8266 Then_Statements
=> Lim_Typ_Stmts
,
8267 Else_Statements
=> Conc_Typ_Stmts
));
8270 Make_Block_Statement
(Loc
,
8273 Handled_Statement_Sequence
=>
8274 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8276 -- As described above, the entry alternative is transformed into a
8277 -- block that contains the gnulli call, and possibly assignment
8278 -- statements for in-out parameters. The gnulli call may itself be
8279 -- rewritten into a transient block if some unconstrained parameters
8280 -- require it. We need to retrieve the call to complete its parameter
8285 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
8287 if Present
(Transient_Blk
)
8288 and then Nkind
(Transient_Blk
) = N_Block_Statement
8290 Blk
:= Transient_Blk
;
8293 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
8294 Stmt
:= First
(Stmts
);
8295 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
8300 Params
:= Parameter_Associations
(Call
);
8302 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
8304 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8306 Param
:= First
(Params
);
8307 while Present
(Param
)
8308 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
8313 pragma Assert
(Present
(Param
));
8315 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8319 -- Find the Communication_Block parameter for the call to the
8320 -- Cancelled function.
8322 Decl
:= First
(Declarations
(Blk
));
8323 while Present
(Decl
)
8324 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
8325 RE_Communication_Block
)
8330 -- Add an if statement to execute the else part if the call
8331 -- does not succeed (as indicated by the Cancelled predicate).
8334 Make_Implicit_If_Statement
(N
,
8335 Condition
=> Make_Function_Call
(Loc
,
8336 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
8337 Parameter_Associations
=> New_List
(
8338 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))),
8339 Then_Statements
=> Else_Statements
(N
),
8340 Else_Statements
=> Statements
(Alt
)));
8343 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8345 -- Insert declaration of B in declarations of existing block
8347 if No
(Declarations
(Blk
)) then
8348 Set_Declarations
(Blk
, New_List
);
8351 Prepend_To
(Declarations
(Blk
),
8352 Make_Object_Declaration
(Loc
,
8353 Defining_Identifier
=> B
,
8354 Object_Definition
=>
8355 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8357 -- Create new call statement
8360 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8361 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
8364 Make_Procedure_Call_Statement
(Loc
,
8365 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
8366 Parameter_Associations
=> Params
));
8368 -- Construct statement sequence for new block
8371 Make_Implicit_If_Statement
(N
,
8372 Condition
=> New_Occurrence_Of
(B
, Loc
),
8373 Then_Statements
=> Statements
(Alt
),
8374 Else_Statements
=> Else_Statements
(N
)));
8377 -- The result is the new block
8380 Make_Block_Statement
(Loc
,
8381 Declarations
=> Declarations
(Blk
),
8382 Handled_Statement_Sequence
=>
8383 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8387 end Expand_N_Conditional_Entry_Call
;
8389 ---------------------------------------
8390 -- Expand_N_Delay_Relative_Statement --
8391 ---------------------------------------
8393 -- Delay statement is implemented as a procedure call to Delay_For
8394 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8395 -- simple delays imposed by the use of Protected Objects.
8397 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
8398 Loc
: constant Source_Ptr
:= Sloc
(N
);
8402 -- Try to use System.Relative_Delays.Delay_For only if available. This
8403 -- is the implementation used on restricted platforms when Ada.Calendar
8404 -- is not available.
8406 if RTE_Available
(RO_RD_Delay_For
) then
8407 Proc
:= RTE
(RO_RD_Delay_For
);
8409 -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error
8410 -- message if not available.
8413 Proc
:= RTE
(RO_CA_Delay_For
);
8417 Make_Procedure_Call_Statement
(Loc
,
8418 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8419 Parameter_Associations
=> New_List
(Expression
(N
))));
8421 end Expand_N_Delay_Relative_Statement
;
8423 ------------------------------------
8424 -- Expand_N_Delay_Until_Statement --
8425 ------------------------------------
8427 -- Delay Until statement is implemented as a procedure call to
8428 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8430 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
8431 Loc
: constant Source_Ptr
:= Sloc
(N
);
8435 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
8436 Typ
:= RTE
(RO_CA_Delay_Until
);
8438 Typ
:= RTE
(RO_RT_Delay_Until
);
8442 Make_Procedure_Call_Statement
(Loc
,
8443 Name
=> New_Occurrence_Of
(Typ
, Loc
),
8444 Parameter_Associations
=> New_List
(Expression
(N
))));
8447 end Expand_N_Delay_Until_Statement
;
8449 -------------------------
8450 -- Expand_N_Entry_Body --
8451 -------------------------
8453 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
8455 -- Associate discriminals with the next protected operation body to be
8458 if Present
(Next_Protected_Operation
(N
)) then
8459 Set_Discriminals
(Parent
(Current_Scope
));
8461 end Expand_N_Entry_Body
;
8463 -----------------------------------
8464 -- Expand_N_Entry_Call_Statement --
8465 -----------------------------------
8467 -- An entry call is expanded into GNARLI calls to implement a simple entry
8468 -- call (see Build_Simple_Entry_Call).
8470 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
8476 if No_Run_Time_Mode
then
8477 Error_Msg_CRT
("entry call", N
);
8481 -- If this entry call is part of an asynchronous select, don't expand it
8482 -- here; it will be expanded with the select statement. Don't expand
8483 -- timed entry calls either, as they are translated into asynchronous
8486 -- ??? This whole approach is questionable; it may be better to go back
8487 -- to allowing the expansion to take place and then attempting to fix it
8488 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8489 -- whether the expanded call is on a task or protected entry.
8491 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
8492 or else N
/= Triggering_Statement
(Parent
(N
)))
8493 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8494 or else N
/= Entry_Call_Statement
(Parent
(N
))
8495 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8497 Extract_Entry
(N
, Concval
, Ename
, Index
);
8498 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8500 end Expand_N_Entry_Call_Statement
;
8502 --------------------------------
8503 -- Expand_N_Entry_Declaration --
8504 --------------------------------
8506 -- If there are parameters, then first, each of the formals is marked by
8507 -- setting Is_Entry_Formal. Next a record type is built which is used to
8508 -- hold the parameter values. The name of this record type is entryP where
8509 -- entry is the name of the entry, with an additional corresponding access
8510 -- type called entryPA. The record type has matching components for each
8511 -- formal (the component names are the same as the formal names). For
8512 -- elementary types, the component type matches the formal type. For
8513 -- composite types, an access type is declared (with the name formalA)
8514 -- which designates the formal type, and the type of the component is this
8515 -- access type. Finally the Entry_Component of each formal is set to
8516 -- reference the corresponding record component.
8518 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8519 Loc
: constant Source_Ptr
:= Sloc
(N
);
8520 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8521 Components
: List_Id
;
8524 Last_Decl
: Node_Id
;
8525 Component
: Entity_Id
;
8528 Rec_Ent
: Entity_Id
;
8529 Acc_Ent
: Entity_Id
;
8532 Formal
:= First_Formal
(Entry_Ent
);
8535 -- Most processing is done only if parameters are present
8537 if Present
(Formal
) then
8538 Components
:= New_List
;
8540 -- Loop through formals
8542 while Present
(Formal
) loop
8543 Set_Is_Entry_Formal
(Formal
);
8545 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8546 Set_Entry_Component
(Formal
, Component
);
8547 Set_Entry_Formal
(Component
, Formal
);
8548 Ftype
:= Etype
(Formal
);
8550 -- Declare new access type and then append
8552 Ctype
:= Make_Temporary
(Loc
, 'A');
8553 Set_Is_Param_Block_Component_Type
(Ctype
);
8556 Make_Full_Type_Declaration
(Loc
,
8557 Defining_Identifier
=> Ctype
,
8559 Make_Access_To_Object_Definition
(Loc
,
8560 All_Present
=> True,
8561 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8562 Subtype_Indication
=> New_Occurrence_Of
(Ftype
, Loc
)));
8564 Insert_After
(Last_Decl
, Decl
);
8567 Append_To
(Components
,
8568 Make_Component_Declaration
(Loc
,
8569 Defining_Identifier
=> Component
,
8570 Component_Definition
=>
8571 Make_Component_Definition
(Loc
,
8572 Aliased_Present
=> False,
8573 Subtype_Indication
=> New_Occurrence_Of
(Ctype
, Loc
))));
8575 Next_Formal_With_Extras
(Formal
);
8578 -- Create the Entry_Parameter_Record declaration
8580 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8583 Make_Full_Type_Declaration
(Loc
,
8584 Defining_Identifier
=> Rec_Ent
,
8586 Make_Record_Definition
(Loc
,
8588 Make_Component_List
(Loc
,
8589 Component_Items
=> Components
)));
8591 Insert_After
(Last_Decl
, Decl
);
8594 -- Construct and link in the corresponding access type
8596 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8598 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8601 Make_Full_Type_Declaration
(Loc
,
8602 Defining_Identifier
=> Acc_Ent
,
8604 Make_Access_To_Object_Definition
(Loc
,
8605 All_Present
=> True,
8606 Subtype_Indication
=> New_Occurrence_Of
(Rec_Ent
, Loc
)));
8608 Insert_After
(Last_Decl
, Decl
);
8610 end Expand_N_Entry_Declaration
;
8612 -----------------------------
8613 -- Expand_N_Protected_Body --
8614 -----------------------------
8616 -- Protected bodies are expanded to the completion of the subprograms
8617 -- created for the corresponding protected type. These are a protected and
8618 -- unprotected version of each protected subprogram in the object, a
8619 -- function to calculate each entry barrier, and a procedure to execute the
8620 -- sequence of statements of each protected entry body. For example, for
8621 -- protected type ptype:
8624 -- (O : System.Address;
8625 -- E : Protected_Entry_Index)
8628 -- <discriminant renamings>
8629 -- <private object renamings>
8631 -- return <barrier expression>;
8634 -- procedure pprocN (_object : in out poV;...) is
8635 -- <discriminant renamings>
8636 -- <private object renamings>
8638 -- <sequence of statements>
8641 -- procedure pprocP (_object : in out poV;...) is
8642 -- procedure _clean is
8645 -- ptypeS (_object, Pn);
8646 -- Unlock (_object._object'Access);
8647 -- Abort_Undefer.all;
8652 -- Lock (_object._object'Access);
8653 -- pprocN (_object;...);
8658 -- function pfuncN (_object : poV;...) return Return_Type is
8659 -- <discriminant renamings>
8660 -- <private object renamings>
8662 -- <sequence of statements>
8665 -- function pfuncP (_object : poV) return Return_Type is
8666 -- procedure _clean is
8668 -- Unlock (_object._object'Access);
8669 -- Abort_Undefer.all;
8674 -- Lock (_object._object'Access);
8675 -- return pfuncN (_object);
8682 -- (O : System.Address;
8683 -- P : System.Address;
8684 -- E : Protected_Entry_Index)
8686 -- <discriminant renamings>
8687 -- <private object renamings>
8688 -- type poVP is access poV;
8689 -- _Object : ptVP := ptVP!(O);
8693 -- <statement sequence>
8694 -- Complete_Entry_Body (_Object._Object);
8696 -- when all others =>
8697 -- Exceptional_Complete_Entry_Body (
8698 -- _Object._Object, Get_GNAT_Exception);
8702 -- The type poV is the record created for the protected type to hold
8703 -- the state of the protected object.
8705 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8706 Loc
: constant Source_Ptr
:= Sloc
(N
);
8707 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8709 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8710 -- This flag indicates whether the lock free implementation is active
8712 Current_Node
: Node_Id
;
8713 Disp_Op_Body
: Node_Id
;
8714 New_Op_Body
: Node_Id
;
8718 function Build_Dispatching_Subprogram_Body
8721 Prot_Bod
: Node_Id
) return Node_Id
;
8722 -- Build a dispatching version of the protected subprogram body. The
8723 -- newly generated subprogram contains a call to the original protected
8724 -- body. The following code is generated:
8726 -- function <protected-function-name> (Param1 .. ParamN) return
8729 -- return <protected-function-name>P (Param1 .. ParamN);
8730 -- end <protected-function-name>;
8734 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8736 -- <protected-procedure-name>P (Param1 .. ParamN);
8737 -- end <protected-procedure-name>
8739 ---------------------------------------
8740 -- Build_Dispatching_Subprogram_Body --
8741 ---------------------------------------
8743 function Build_Dispatching_Subprogram_Body
8746 Prot_Bod
: Node_Id
) return Node_Id
8748 Loc
: constant Source_Ptr
:= Sloc
(N
);
8755 -- Generate a specification without a letter suffix in order to
8756 -- override an interface function or procedure.
8758 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8760 -- The formal parameters become the actuals of the protected function
8761 -- or procedure call.
8763 Actuals
:= New_List
;
8764 Formal
:= First
(Parameter_Specifications
(Spec
));
8765 while Present
(Formal
) loop
8767 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8771 if Nkind
(Spec
) = N_Procedure_Specification
then
8774 Make_Procedure_Call_Statement
(Loc
,
8776 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8777 Parameter_Associations
=> Actuals
));
8780 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8784 Make_Simple_Return_Statement
(Loc
,
8786 Make_Function_Call
(Loc
,
8788 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8789 Parameter_Associations
=> Actuals
)));
8793 Make_Subprogram_Body
(Loc
,
8794 Declarations
=> Empty_List
,
8795 Specification
=> Spec
,
8796 Handled_Statement_Sequence
=>
8797 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8798 end Build_Dispatching_Subprogram_Body
;
8800 -- Start of processing for Expand_N_Protected_Body
8803 if No_Run_Time_Mode
then
8804 Error_Msg_CRT
("protected body", N
);
8808 -- This is the proper body corresponding to a stub. The declarations
8809 -- must be inserted at the point of the stub, which in turn is in the
8810 -- declarative part of the parent unit.
8812 if Nkind
(Parent
(N
)) = N_Subunit
then
8813 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8818 Op_Body
:= First
(Declarations
(N
));
8820 -- The protected body is replaced with the bodies of its
8821 -- protected operations, and the declarations for internal objects
8822 -- that may have been created for entry family bounds.
8824 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8827 while Present
(Op_Body
) loop
8828 case Nkind
(Op_Body
) is
8829 when N_Subprogram_Declaration
=>
8832 when N_Subprogram_Body
=>
8834 -- Do not create bodies for eliminated operations
8836 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8837 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8839 if Lock_Free_Active
then
8841 Build_Lock_Free_Unprotected_Subprogram_Body
8845 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8848 Insert_After
(Current_Node
, New_Op_Body
);
8849 Current_Node
:= New_Op_Body
;
8850 Analyze
(New_Op_Body
);
8852 -- Build the corresponding protected operation. It may
8853 -- appear that this is needed only if this is a visible
8854 -- operation of the type, or if it is an interrupt handler,
8855 -- and this was the strategy used previously in GNAT.
8857 -- However, the operation may be exported through a 'Access
8858 -- to an external caller. This is the common idiom in code
8859 -- that uses the Ada 2005 Timing_Events package. As a result
8860 -- we need to produce the protected body for both visible
8861 -- and private operations, as well as operations that only
8862 -- have a body in the source, and for which we create a
8863 -- declaration in the protected body itself.
8865 if Present
(Corresponding_Spec
(Op_Body
)) then
8866 if Lock_Free_Active
then
8868 Build_Lock_Free_Protected_Subprogram_Body
8869 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8872 Build_Protected_Subprogram_Body
8873 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8876 Insert_After
(Current_Node
, New_Op_Body
);
8877 Analyze
(New_Op_Body
);
8879 Current_Node
:= New_Op_Body
;
8881 -- Generate an overriding primitive operation body for
8882 -- this subprogram if the protected type implements an
8885 if Ada_Version
>= Ada_2005
8887 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
8890 Build_Dispatching_Subprogram_Body
8891 (Op_Body
, Pid
, New_Op_Body
);
8893 Insert_After
(Current_Node
, Disp_Op_Body
);
8894 Analyze
(Disp_Op_Body
);
8896 Current_Node
:= Disp_Op_Body
;
8901 when N_Entry_Body
=>
8902 Op_Id
:= Defining_Identifier
(Op_Body
);
8903 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8905 Insert_After
(Current_Node
, New_Op_Body
);
8906 Current_Node
:= New_Op_Body
;
8907 Analyze
(New_Op_Body
);
8909 when N_Implicit_Label_Declaration
=>
8912 when N_Itype_Reference
=>
8913 Insert_After
(Current_Node
, New_Copy
(Op_Body
));
8915 when N_Freeze_Entity
=>
8916 New_Op_Body
:= New_Copy
(Op_Body
);
8918 if Present
(Entity
(Op_Body
))
8919 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8921 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8924 Insert_After
(Current_Node
, New_Op_Body
);
8925 Current_Node
:= New_Op_Body
;
8926 Analyze
(New_Op_Body
);
8929 New_Op_Body
:= New_Copy
(Op_Body
);
8930 Insert_After
(Current_Node
, New_Op_Body
);
8931 Current_Node
:= New_Op_Body
;
8932 Analyze
(New_Op_Body
);
8934 when N_Object_Declaration
=>
8935 pragma Assert
(not Comes_From_Source
(Op_Body
));
8936 New_Op_Body
:= New_Copy
(Op_Body
);
8937 Insert_After
(Current_Node
, New_Op_Body
);
8938 Current_Node
:= New_Op_Body
;
8939 Analyze
(New_Op_Body
);
8942 raise Program_Error
;
8949 -- Finally, create the body of the function that maps an entry index
8950 -- into the corresponding body index, except when there is no entry, or
8951 -- in a Ravenscar-like profile.
8953 if Corresponding_Runtime_Package
(Pid
) =
8954 System_Tasking_Protected_Objects_Entries
8956 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8957 Insert_After
(Current_Node
, New_Op_Body
);
8958 Current_Node
:= New_Op_Body
;
8959 Analyze
(New_Op_Body
);
8962 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8963 -- protected body. At this point all wrapper specs have been created,
8964 -- frozen and included in the dispatch table for the protected type.
8966 if Ada_Version
>= Ada_2005
then
8967 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8969 end Expand_N_Protected_Body
;
8971 -----------------------------------------
8972 -- Expand_N_Protected_Type_Declaration --
8973 -----------------------------------------
8975 -- First we create a corresponding record type declaration used to
8976 -- represent values of this protected type.
8977 -- The general form of this type declaration is
8979 -- type poV (discriminants) is record
8980 -- _Object : aliased <kind>Protection
8981 -- [(<entry count> [, <handler count>])];
8982 -- [entry_family : array (bounds) of Void;]
8983 -- <private data fields>
8986 -- The discriminants are present only if the corresponding protected type
8987 -- has discriminants, and they exactly mirror the protected type
8988 -- discriminants. The private data fields similarly mirror the private
8989 -- declarations of the protected type.
8991 -- The Object field is always present. It contains RTS specific data used
8992 -- to control the protected object. It is declared as Aliased so that it
8993 -- can be passed as a pointer to the RTS. This allows the protected record
8994 -- to be referenced within RTS data structures. An appropriate Protection
8995 -- type and discriminant are generated.
8997 -- The Service field is present for protected objects with entries. It
8998 -- contains sufficient information to allow the entry service procedure for
8999 -- this object to be called when the object is not known till runtime.
9001 -- One entry_family component is present for each entry family in the
9002 -- task definition (see Expand_N_Task_Type_Declaration).
9004 -- When a protected object is declared, an instance of the protected type
9005 -- value record is created. The elaboration of this declaration creates the
9006 -- correct bounds for the entry families, and also evaluates the priority
9007 -- expression if needed. The initialization routine for the protected type
9008 -- itself then calls Initialize_Protection with appropriate parameters to
9009 -- initialize the value of the Task_Id field. Install_Handlers may be also
9010 -- called if a pragma Attach_Handler applies.
9012 -- Note: this record is passed to the subprograms created by the expansion
9013 -- of protected subprograms and entries. It is an in parameter to protected
9014 -- functions and an in out parameter to procedures and entry bodies. The
9015 -- Entity_Id for this created record type is placed in the
9016 -- Corresponding_Record_Type field of the associated protected type entity.
9018 -- Next we create a procedure specifications for protected subprograms and
9019 -- entry bodies. For each protected subprograms two subprograms are
9020 -- created, an unprotected and a protected version. The unprotected version
9021 -- is called from within other operations of the same protected object.
9023 -- We also build the call to register the procedure if a pragma
9024 -- Interrupt_Handler applies.
9026 -- A single subprogram is created to service all entry bodies; it has an
9027 -- additional boolean out parameter indicating that the previous entry call
9028 -- made by the current task was serviced immediately, i.e. not by proxy.
9029 -- The O parameter contains a pointer to a record object of the type
9030 -- described above. An untyped interface is used here to allow this
9031 -- procedure to be called in places where the type of the object to be
9032 -- serviced is not known. This must be done, for example, when a call that
9033 -- may have been requeued is cancelled; the corresponding object must be
9034 -- serviced, but which object that is not known till runtime.
9037 -- (O : System.Address; P : out Boolean);
9038 -- procedure pprocN (_object : in out poV);
9039 -- procedure pproc (_object : in out poV);
9040 -- function pfuncN (_object : poV);
9041 -- function pfunc (_object : poV);
9044 -- Note that this must come after the record type declaration, since
9045 -- the specs refer to this type.
9047 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
9048 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
9049 Loc
: constant Source_Ptr
:= Sloc
(N
);
9050 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
9052 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
9053 -- This flag indicates whether the lock free implementation is active
9055 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
9056 -- This contains two lists; one for visible and one for private decls
9059 Body_Id
: Entity_Id
;
9062 Current_Node
: Node_Id
:= N
;
9064 Entries_Aggr
: Node_Id
;
9066 Object_Comp
: Node_Id
;
9070 procedure Check_Inlining
(Subp
: Entity_Id
);
9071 -- If the original operation has a pragma Inline, propagate the flag
9072 -- to the internal body, for possible inlining later on. The source
9073 -- operation is invisible to the back-end and is never actually called.
9075 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean;
9076 -- If a component size is not static then a warning will be emitted
9077 -- in Ravenscar or other restricted contexts. When a component is non-
9078 -- static because of a discriminant constraint we can specialize the
9079 -- warning by mentioning discriminants explicitly.
9081 procedure Expand_Entry_Declaration
(Decl
: Node_Id
);
9082 -- Create the entry barrier and the procedure body for entry declaration
9083 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
9085 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
9086 -- When compiling under the Ravenscar profile, private components must
9087 -- have a static size, or else a protected object will require heap
9088 -- allocation, violating the corresponding restriction. It is preferable
9089 -- to make this check here, because it provides a better error message
9090 -- than the back-end, which refers to the object as a whole.
9092 procedure Register_Handler
;
9093 -- For a protected operation that is an interrupt handler, add the
9094 -- freeze action that will register it as such.
9096 --------------------
9097 -- Check_Inlining --
9098 --------------------
9100 procedure Check_Inlining
(Subp
: Entity_Id
) is
9102 if Is_Inlined
(Subp
) then
9103 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
9104 Set_Is_Inlined
(Subp
, False);
9108 ------------------------
9109 -- Discriminated_Size --
9110 ------------------------
9112 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
9113 Typ
: constant Entity_Id
:= Etype
(Comp
);
9116 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
9117 -- Check whether the bound of an index is non-static and does denote
9118 -- a discriminant, in which case any protected object of the type
9119 -- will have a non-static size.
9121 ----------------------
9122 -- Non_Static_Bound --
9123 ----------------------
9125 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
9127 if Is_OK_Static_Expression
(Bound
) then
9130 elsif Is_Entity_Name
(Bound
)
9131 and then Present
(Discriminal_Link
(Entity
(Bound
)))
9138 end Non_Static_Bound
;
9140 -- Start of processing for Discriminated_Size
9143 if not Is_Array_Type
(Typ
) then
9147 if Ekind
(Typ
) = E_Array_Subtype
then
9148 Index
:= First_Index
(Typ
);
9149 while Present
(Index
) loop
9150 if Non_Static_Bound
(Low_Bound
(Index
))
9151 or else Non_Static_Bound
(High_Bound
(Index
))
9163 end Discriminated_Size
;
9165 ---------------------------
9166 -- Static_Component_Size --
9167 ---------------------------
9169 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
9170 Typ
: constant Entity_Id
:= Etype
(Comp
);
9174 if Is_Scalar_Type
(Typ
) then
9177 elsif Is_Array_Type
(Typ
) then
9178 return Compile_Time_Known_Bounds
(Typ
);
9180 elsif Is_Record_Type
(Typ
) then
9181 C
:= First_Component
(Typ
);
9182 while Present
(C
) loop
9183 if not Static_Component_Size
(C
) then
9192 -- Any other type will be checked by the back-end
9197 end Static_Component_Size
;
9199 ------------------------------
9200 -- Expand_Entry_Declaration --
9201 ------------------------------
9203 procedure Expand_Entry_Declaration
(Decl
: Node_Id
) is
9204 Ent_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
9210 E_Count
:= E_Count
+ 1;
9212 -- Create the protected body subprogram
9215 Make_Defining_Identifier
(Loc
,
9216 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'E'));
9217 Set_Protected_Body_Subprogram
(Ent_Id
, Bod_Id
);
9220 Make_Subprogram_Declaration
(Loc
,
9222 Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Ent_Id
));
9224 Insert_After
(Current_Node
, Subp
);
9225 Current_Node
:= Subp
;
9229 -- Build a wrapper procedure to handle contract cases, preconditions,
9230 -- and postconditions.
9232 Build_Contract_Wrapper
(Ent_Id
, N
);
9234 -- Create the barrier function
9237 Make_Defining_Identifier
(Loc
,
9238 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'B'));
9239 Set_Barrier_Function
(Ent_Id
, Bar_Id
);
9242 Make_Subprogram_Declaration
(Loc
,
9244 Build_Barrier_Function_Specification
(Loc
, Bar_Id
));
9245 Set_Is_Entry_Barrier_Function
(Subp
);
9247 Insert_After
(Current_Node
, Subp
);
9248 Current_Node
:= Subp
;
9252 Set_Protected_Body_Subprogram
(Bar_Id
, Bar_Id
);
9253 Set_Scope
(Bar_Id
, Scope
(Ent_Id
));
9255 -- Collect pointers to the protected subprogram and the barrier
9256 -- of the current entry, for insertion into Entry_Bodies_Array.
9258 Append_To
(Expressions
(Entries_Aggr
),
9259 Make_Aggregate
(Loc
,
9260 Expressions
=> New_List
(
9261 Make_Attribute_Reference
(Loc
,
9262 Prefix
=> New_Occurrence_Of
(Bar_Id
, Loc
),
9263 Attribute_Name
=> Name_Unrestricted_Access
),
9264 Make_Attribute_Reference
(Loc
,
9265 Prefix
=> New_Occurrence_Of
(Bod_Id
, Loc
),
9266 Attribute_Name
=> Name_Unrestricted_Access
))));
9267 end Expand_Entry_Declaration
;
9269 ----------------------
9270 -- Register_Handler --
9271 ----------------------
9273 procedure Register_Handler
is
9275 -- All semantic checks already done in Sem_Prag
9277 Prot_Proc
: constant Entity_Id
:=
9278 Defining_Unit_Name
(Specification
(Current_Node
));
9280 Proc_Address
: constant Node_Id
:=
9281 Make_Attribute_Reference
(Loc
,
9283 New_Occurrence_Of
(Prot_Proc
, Loc
),
9284 Attribute_Name
=> Name_Address
);
9286 RTS_Call
: constant Entity_Id
:=
9287 Make_Procedure_Call_Statement
(Loc
,
9290 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
9291 Parameter_Associations
=> New_List
(Proc_Address
));
9293 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
9294 end Register_Handler
;
9300 -- Start of processing for Expand_N_Protected_Type_Declaration
9303 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
9306 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
9309 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
9311 Qualify_Entity_Names
(N
);
9313 -- If the type has discriminants, their occurrences in the declaration
9314 -- have been replaced by the corresponding discriminals. For components
9315 -- that are constrained by discriminants, their homologues in the
9316 -- corresponding record type must refer to the discriminants of that
9317 -- record, so we must apply a new renaming to subtypes_indications:
9319 -- protected discriminant => discriminal => record discriminant
9321 -- This replacement is not applied to default expressions, for which
9322 -- the discriminal is correct.
9324 if Has_Discriminants
(Prot_Typ
) then
9330 Disc
:= First_Discriminant
(Prot_Typ
);
9331 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
9332 while Present
(Disc
) loop
9333 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
9334 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
9335 Next_Discriminant
(Disc
);
9341 -- Fill in the component declarations
9343 -- Add components for entry families. For each entry family, create an
9344 -- anonymous type declaration with the same size, and analyze the type.
9346 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
9348 pragma Assert
(Present
(Pdef
));
9350 Insert_After
(Current_Node
, Rec_Decl
);
9351 Current_Node
:= Rec_Decl
;
9353 -- Add private field components
9355 if Present
(Private_Declarations
(Pdef
)) then
9356 Priv
:= First
(Private_Declarations
(Pdef
));
9357 while Present
(Priv
) loop
9358 if Nkind
(Priv
) = N_Component_Declaration
then
9359 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
9361 -- When compiling for a restricted profile, the private
9362 -- components must have a static size. If not, this is an
9363 -- error for a single protected declaration, and rates a
9364 -- warning on a protected type declaration.
9366 if not Comes_From_Source
(Prot_Typ
) then
9368 -- It's ok to be checking this restriction at expansion
9369 -- time, because this is only for the restricted profile,
9370 -- which is not subject to strict RM conformance, so it
9371 -- is OK to miss this check in -gnatc mode.
9373 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
9375 (No_Implicit_Protected_Object_Allocations
, Priv
);
9377 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
9378 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9380 -- Any object of the type will be non-static.
9382 Error_Msg_N
("component has non-static size??", Priv
);
9384 ("\creation of protected object of type& will "
9385 & "violate restriction "
9386 & "No_Implicit_Heap_Allocations??", Priv
, Prot_Typ
);
9389 -- Object will be non-static if discriminants are.
9392 ("creation of protected object of type& with "
9393 & "non-static discriminants will violate"
9394 & " restriction No_Implicit_Heap_Allocations??",
9398 -- Likewise for No_Implicit_Protected_Object_Allocations
9400 elsif Restriction_Active
9401 (No_Implicit_Protected_Object_Allocations
)
9403 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9405 -- Any object of the type will be non-static.
9407 Error_Msg_N
("component has non-static size??", Priv
);
9409 ("\creation of protected object of type& will "
9410 & "violate restriction "
9411 & "No_Implicit_Protected_Object_Allocations??",
9414 -- Object will be non-static if discriminants are.
9417 ("creation of protected object of type& with "
9418 & "non-static discriminants will violate "
9420 & "No_Implicit_Protected_Object_Allocations??",
9426 -- The component definition consists of a subtype indication,
9427 -- or (in Ada 2005) an access definition. Make a copy of the
9428 -- proper definition.
9431 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
9432 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
9433 Nent
: constant Entity_Id
:=
9434 Make_Defining_Identifier
(Sloc
(Oent
),
9435 Chars
=> Chars
(Oent
));
9439 if Present
(Subtype_Indication
(Old_Comp
)) then
9441 Make_Component_Definition
(Sloc
(Oent
),
9442 Aliased_Present
=> False,
9443 Subtype_Indication
=>
9445 (Subtype_Indication
(Old_Comp
), Discr_Map
));
9448 Make_Component_Definition
(Sloc
(Oent
),
9449 Aliased_Present
=> False,
9450 Access_Definition
=>
9452 (Access_Definition
(Old_Comp
), Discr_Map
));
9456 Make_Component_Declaration
(Loc
,
9457 Defining_Identifier
=> Nent
,
9458 Component_Definition
=> New_Comp
,
9459 Expression
=> Expression
(Priv
));
9461 Set_Has_Per_Object_Constraint
(Nent
,
9462 Has_Per_Object_Constraint
(Oent
));
9464 Append_To
(Cdecls
, New_Priv
);
9467 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
9469 -- Make the unprotected version of the subprogram available
9470 -- for expansion of intra object calls. There is need for
9471 -- a protected version only if the subprogram is an interrupt
9472 -- handler, otherwise this operation can only be called from
9476 Make_Subprogram_Declaration
(Loc
,
9478 Build_Protected_Sub_Specification
9479 (Priv
, Prot_Typ
, Unprotected_Mode
));
9481 Insert_After
(Current_Node
, Sub
);
9484 Set_Protected_Body_Subprogram
9485 (Defining_Unit_Name
(Specification
(Priv
)),
9486 Defining_Unit_Name
(Specification
(Sub
)));
9487 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
9488 Current_Node
:= Sub
;
9491 Make_Subprogram_Declaration
(Loc
,
9493 Build_Protected_Sub_Specification
9494 (Priv
, Prot_Typ
, Protected_Mode
));
9496 Insert_After
(Current_Node
, Sub
);
9498 Current_Node
:= Sub
;
9500 if Is_Interrupt_Handler
9501 (Defining_Unit_Name
(Specification
(Priv
)))
9503 if not Restricted_Profile
then
9513 -- Except for the lock-free implementation, append the _Object field
9514 -- with the right type to the component list. We need to compute the
9515 -- number of entries, and in some cases the number of Attach_Handler
9518 if not Lock_Free_Active
then
9520 Entry_Count_Expr
: constant Node_Id
:=
9521 Build_Entry_Count_Expression
9522 (Prot_Typ
, Cdecls
, Loc
);
9523 Num_Attach_Handler
: Nat
:= 0;
9524 Protection_Subtype
: Node_Id
;
9528 if Has_Attach_Handler
(Prot_Typ
) then
9529 Ritem
:= First_Rep_Item
(Prot_Typ
);
9530 while Present
(Ritem
) loop
9531 if Nkind
(Ritem
) = N_Pragma
9532 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
9534 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
9537 Next_Rep_Item
(Ritem
);
9541 -- Determine the proper protection type. There are two special
9542 -- cases: 1) when the protected type has dynamic interrupt
9543 -- handlers, and 2) when it has static handlers and we use a
9544 -- restricted profile.
9546 if Has_Attach_Handler
(Prot_Typ
)
9547 and then not Restricted_Profile
9549 Protection_Subtype
:=
9550 Make_Subtype_Indication
(Loc
,
9553 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
9555 Make_Index_Or_Discriminant_Constraint
(Loc
,
9556 Constraints
=> New_List
(
9558 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
9560 elsif Has_Interrupt_Handler
(Prot_Typ
)
9561 and then not Restriction_Active
(No_Dynamic_Attachment
)
9563 Protection_Subtype
:=
9564 Make_Subtype_Indication
(Loc
,
9567 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
9569 Make_Index_Or_Discriminant_Constraint
(Loc
,
9570 Constraints
=> New_List
(Entry_Count_Expr
)));
9573 case Corresponding_Runtime_Package
(Prot_Typ
) is
9574 when System_Tasking_Protected_Objects_Entries
=>
9575 Protection_Subtype
:=
9576 Make_Subtype_Indication
(Loc
,
9579 (RTE
(RE_Protection_Entries
), Loc
),
9581 Make_Index_Or_Discriminant_Constraint
(Loc
,
9582 Constraints
=> New_List
(Entry_Count_Expr
)));
9584 when System_Tasking_Protected_Objects_Single_Entry
=>
9585 Protection_Subtype
:=
9586 New_Occurrence_Of
(RTE
(RE_Protection_Entry
), Loc
);
9588 when System_Tasking_Protected_Objects
=>
9589 Protection_Subtype
:=
9590 New_Occurrence_Of
(RTE
(RE_Protection
), Loc
);
9593 raise Program_Error
;
9598 Make_Component_Declaration
(Loc
,
9599 Defining_Identifier
=>
9600 Make_Defining_Identifier
(Loc
, Name_uObject
),
9601 Component_Definition
=>
9602 Make_Component_Definition
(Loc
,
9603 Aliased_Present
=> True,
9604 Subtype_Indication
=> Protection_Subtype
));
9607 -- Put the _Object component after the private component so that it
9608 -- be finalized early as required by 9.4 (20)
9610 Append_To
(Cdecls
, Object_Comp
);
9613 -- Analyze the record declaration immediately after construction,
9614 -- because the initialization procedure is needed for single object
9615 -- declarations before the next entity is analyzed (the freeze call
9616 -- that generates this initialization procedure is found below).
9618 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
9620 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9621 -- the corresponding record is frozen. If any wrappers are generated,
9622 -- Current_Node is updated accordingly.
9624 if Ada_Version
>= Ada_2005
then
9625 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
9628 -- Collect pointers to entry bodies and their barriers, to be placed
9629 -- in the Entry_Bodies_Array for the type. For each entry/family we
9630 -- add an expression to the aggregate which is the initial value of
9631 -- this array. The array is declared after all protected subprograms.
9633 if Has_Entries
(Prot_Typ
) then
9634 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
9636 Entries_Aggr
:= Empty
;
9639 -- Build two new procedure specifications for each protected subprogram;
9640 -- one to call from outside the object and one to call from inside.
9641 -- Build a barrier function and an entry body action procedure
9642 -- specification for each protected entry. Initialize the entry body
9643 -- array. If subprogram is flagged as eliminated, do not generate any
9644 -- internal operations.
9647 Comp
:= First
(Visible_Declarations
(Pdef
));
9648 while Present
(Comp
) loop
9649 if Nkind
(Comp
) = N_Subprogram_Declaration
then
9651 Make_Subprogram_Declaration
(Loc
,
9653 Build_Protected_Sub_Specification
9654 (Comp
, Prot_Typ
, Unprotected_Mode
));
9656 Insert_After
(Current_Node
, Sub
);
9659 Set_Protected_Body_Subprogram
9660 (Defining_Unit_Name
(Specification
(Comp
)),
9661 Defining_Unit_Name
(Specification
(Sub
)));
9662 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
9664 -- Make the protected version of the subprogram available for
9665 -- expansion of external calls.
9667 Current_Node
:= Sub
;
9670 Make_Subprogram_Declaration
(Loc
,
9672 Build_Protected_Sub_Specification
9673 (Comp
, Prot_Typ
, Protected_Mode
));
9675 Insert_After
(Current_Node
, Sub
);
9678 Current_Node
:= Sub
;
9680 -- Generate an overriding primitive operation specification for
9681 -- this subprogram if the protected type implements an interface
9682 -- and Build_Wrapper_Spec did not generate its wrapper.
9684 if Ada_Version
>= Ada_2005
9686 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9689 Found
: Boolean := False;
9690 Prim_Elmt
: Elmt_Id
;
9696 (Primitive_Operations
9697 (Corresponding_Record_Type
(Prot_Typ
)));
9699 while Present
(Prim_Elmt
) loop
9700 Prim_Op
:= Node
(Prim_Elmt
);
9702 if Is_Primitive_Wrapper
(Prim_Op
)
9703 and then Wrapped_Entity
(Prim_Op
) =
9704 Defining_Entity
(Specification
(Comp
))
9710 Next_Elmt
(Prim_Elmt
);
9715 Make_Subprogram_Declaration
(Loc
,
9717 Build_Protected_Sub_Specification
9718 (Comp
, Prot_Typ
, Dispatching_Mode
));
9720 Insert_After
(Current_Node
, Sub
);
9723 Current_Node
:= Sub
;
9728 -- If a pragma Interrupt_Handler applies, build and add a call to
9729 -- Register_Interrupt_Handler to the freezing actions of the
9730 -- protected version (Current_Node) of the subprogram:
9732 -- system.interrupts.register_interrupt_handler
9733 -- (prot_procP'address);
9735 if not Restricted_Profile
9736 and then Is_Interrupt_Handler
9737 (Defining_Unit_Name
(Specification
(Comp
)))
9742 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9743 Expand_Entry_Declaration
(Comp
);
9749 -- If there are some private entry declarations, expand it as if they
9750 -- were visible entries.
9752 if Present
(Private_Declarations
(Pdef
)) then
9753 Comp
:= First
(Private_Declarations
(Pdef
));
9754 while Present
(Comp
) loop
9755 if Nkind
(Comp
) = N_Entry_Declaration
then
9756 Expand_Entry_Declaration
(Comp
);
9763 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9764 -- all protected subprograms have been collected.
9766 if Has_Entries
(Prot_Typ
) then
9768 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9769 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9771 case Corresponding_Runtime_Package
(Prot_Typ
) is
9772 when System_Tasking_Protected_Objects_Entries
=>
9774 Make_Object_Declaration
(Loc
,
9775 Defining_Identifier
=> Body_Id
,
9776 Aliased_Present
=> True,
9777 Object_Definition
=>
9778 Make_Subtype_Indication
(Loc
,
9781 (RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9783 Make_Index_Or_Discriminant_Constraint
(Loc
,
9784 Constraints
=> New_List
(
9786 Make_Integer_Literal
(Loc
, 1),
9787 Make_Integer_Literal
(Loc
, E_Count
))))),
9788 Expression
=> Entries_Aggr
);
9790 when System_Tasking_Protected_Objects_Single_Entry
=>
9792 Make_Object_Declaration
(Loc
,
9793 Defining_Identifier
=> Body_Id
,
9794 Aliased_Present
=> True,
9795 Object_Definition
=>
9796 New_Occurrence_Of
(RTE
(RE_Entry_Body
), Loc
),
9798 Remove_Head
(Expressions
(Entries_Aggr
)));
9801 raise Program_Error
;
9804 -- A pointer to this array will be placed in the corresponding record
9805 -- by its initialization procedure so this needs to be analyzed here.
9807 Insert_After
(Current_Node
, Body_Arr
);
9808 Current_Node
:= Body_Arr
;
9811 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9813 -- Finally, build the function that maps an entry index into the
9814 -- corresponding body. A pointer to this function is placed in each
9815 -- object of the type. Except for a ravenscar-like profile (no abort,
9816 -- no entry queue, 1 entry)
9818 if Corresponding_Runtime_Package
(Prot_Typ
) =
9819 System_Tasking_Protected_Objects_Entries
9822 Make_Subprogram_Declaration
(Loc
,
9823 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9824 Insert_After
(Current_Node
, Sub
);
9828 end Expand_N_Protected_Type_Declaration
;
9830 --------------------------------
9831 -- Expand_N_Requeue_Statement --
9832 --------------------------------
9834 -- A nondispatching requeue statement is expanded into one of four GNARLI
9835 -- operations, depending on the source and destination (task or protected
9836 -- object). A dispatching requeue statement is expanded into a call to the
9837 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9838 -- jump around the remainder of processing for the original entry and, if
9839 -- the destination is (different) protected object, to attempt to service
9840 -- it. The following illustrates the various cases:
9843 -- (O : System.Address;
9844 -- P : System.Address;
9845 -- E : Protected_Entry_Index)
9847 -- <discriminant renamings>
9848 -- <private object renamings>
9849 -- type poVP is access poV;
9850 -- _object : ptVP := ptVP!(O);
9854 -- <start of statement sequence for entry>
9856 -- -- Requeue from one protected entry body to another protected
9859 -- Requeue_Protected_Entry (
9860 -- _object._object'Access,
9861 -- new._object'Access,
9866 -- <some more of the statement sequence for entry>
9868 -- -- Requeue from an entry body to a task entry
9870 -- Requeue_Protected_To_Task_Entry (
9876 -- <rest of statement sequence for entry>
9877 -- Complete_Entry_Body (_object._object);
9880 -- when all others =>
9881 -- Exceptional_Complete_Entry_Body (
9882 -- _object._object, Get_GNAT_Exception);
9886 -- Requeue of a task entry call to a task entry
9888 -- Accept_Call (E, Ann);
9889 -- <start of statement sequence for accept statement>
9890 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9892 -- <rest of statement sequence for accept statement>
9894 -- Complete_Rendezvous;
9897 -- when all others =>
9898 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9900 -- Requeue of a task entry call to a protected entry
9902 -- Accept_Call (E, Ann);
9903 -- <start of statement sequence for accept statement>
9904 -- Requeue_Task_To_Protected_Entry (
9905 -- new._object'Access,
9910 -- <rest of statement sequence for accept statement>
9912 -- Complete_Rendezvous;
9915 -- when all others =>
9916 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9918 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9919 -- marked by pragma Implemented (XXX, By_Entry).
9921 -- The requeue is inside a protected entry:
9924 -- (O : System.Address;
9925 -- P : System.Address;
9926 -- E : Protected_Entry_Index)
9928 -- <discriminant renamings>
9929 -- <private object renamings>
9930 -- type poVP is access poV;
9931 -- _object : ptVP := ptVP!(O);
9935 -- <start of statement sequence for entry>
9938 -- (<interface class-wide object>,
9941 -- Ada.Tags.Get_Offset_Index
9943 -- <interface dispatch table index of target entry>),
9947 -- <rest of statement sequence for entry>
9948 -- Complete_Entry_Body (_object._object);
9951 -- when all others =>
9952 -- Exceptional_Complete_Entry_Body (
9953 -- _object._object, Get_GNAT_Exception);
9957 -- The requeue is inside a task entry:
9959 -- Accept_Call (E, Ann);
9960 -- <start of statement sequence for accept statement>
9962 -- (<interface class-wide object>,
9965 -- Ada.Tags.Get_Offset_Index
9967 -- <interface dispatch table index of target entrt>),
9971 -- <rest of statement sequence for accept statement>
9973 -- Complete_Rendezvous;
9976 -- when all others =>
9977 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9979 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9980 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9981 -- statement is replaced by a dispatching call with actual parameters taken
9982 -- from the inner-most accept statement or entry body.
9984 -- Target.Primitive (Param1, ..., ParamN);
9986 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9987 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9991 -- S : constant Offset_Index :=
9992 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9993 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9996 -- if C = POK_Protected_Entry
9997 -- or else C = POK_Task_Entry
9999 -- <statements for dispatching requeue>
10001 -- elsif C = POK_Protected_Procedure then
10002 -- <dispatching call equivalent>
10005 -- raise Program_Error;
10009 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
10010 Loc
: constant Source_Ptr
:= Sloc
(N
);
10011 Conc_Typ
: Entity_Id
;
10015 Old_Typ
: Entity_Id
;
10017 function Build_Dispatching_Call_Equivalent
return Node_Id
;
10018 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10019 -- the form Concval.Ename. It is statically known that Ename is allowed
10020 -- to be implemented by a protected procedure. Create a dispatching call
10021 -- equivalent of Concval.Ename taking the actual parameters from the
10022 -- inner-most accept statement or entry body.
10024 function Build_Dispatching_Requeue
return Node_Id
;
10025 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10026 -- the form Concval.Ename. It is statically known that Ename is allowed
10027 -- to be implemented by a protected or a task entry. Create a call to
10028 -- primitive _Disp_Requeue which handles the low-level actions.
10030 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
10031 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10032 -- the form Concval.Ename. Ename is either marked by pragma Implemented
10033 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
10034 -- determines at runtime whether Ename denotes an entry or a procedure
10035 -- and perform the appropriate kind of dispatching select.
10037 function Build_Normal_Requeue
return Node_Id
;
10038 -- N denotes a nondispatching requeue statement to either a task or a
10039 -- protected entry. Build the appropriate runtime call to perform the
10042 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
10043 -- For a protected entry, create a return statement to skip the rest of
10044 -- the entry body. Otherwise, create a goto statement to skip the rest
10045 -- of a task accept statement. The lookup for the enclosing entry body
10046 -- or accept statement starts from Search.
10048 ---------------------------------------
10049 -- Build_Dispatching_Call_Equivalent --
10050 ---------------------------------------
10052 function Build_Dispatching_Call_Equivalent
return Node_Id
is
10053 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10054 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10061 -- Climb the parent chain looking for the inner-most entry body or
10062 -- accept statement.
10065 while Present
(Acc_Ent
)
10066 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
10069 Acc_Ent
:= Parent
(Acc_Ent
);
10072 -- A requeue statement should be housed inside an entry body or an
10073 -- accept statement at some level. If this is not the case, then the
10074 -- tree is malformed.
10076 pragma Assert
(Present
(Acc_Ent
));
10078 -- Recover the list of formal parameters
10080 if Nkind
(Acc_Ent
) = N_Entry_Body
then
10081 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
10084 Formals
:= Parameter_Specifications
(Acc_Ent
);
10086 -- Create the actual parameters for the dispatching call. These are
10087 -- simply copies of the entry body or accept statement formals in the
10088 -- same order as they appear.
10090 Actuals
:= No_List
;
10092 if Present
(Formals
) then
10093 Actuals
:= New_List
;
10094 Formal
:= First
(Formals
);
10095 while Present
(Formal
) loop
10096 Append_To
(Actuals
,
10097 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
10103 -- Obj.Call_Ent (Actuals);
10106 Make_Procedure_Call_Statement
(Loc
,
10108 Make_Selected_Component
(Loc
,
10109 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
10110 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
10112 Parameter_Associations
=> Actuals
);
10113 end Build_Dispatching_Call_Equivalent
;
10115 -------------------------------
10116 -- Build_Dispatching_Requeue --
10117 -------------------------------
10119 function Build_Dispatching_Requeue
return Node_Id
is
10120 Params
: constant List_Id
:= New_List
;
10123 -- Process the "with abort" parameter
10125 Prepend_To
(Params
,
10126 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10128 -- Process the entry wrapper's position in the primary dispatch
10129 -- table parameter. Generate:
10131 -- Ada.Tags.Get_Entry_Index
10132 -- (T => To_Tag_Ptr (Obj'Address).all,
10134 -- Ada.Tags.Get_Offset_Index
10135 -- (Ada.Tags.Tag (Concval),
10136 -- <interface dispatch table position of Ename>));
10138 -- Note that Obj'Address is recursively expanded into a call to
10139 -- Base_Address (Obj).
10141 if Tagged_Type_Expansion
then
10142 Prepend_To
(Params
,
10143 Make_Function_Call
(Loc
,
10144 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10145 Parameter_Associations
=> New_List
(
10147 Make_Explicit_Dereference
(Loc
,
10148 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
10149 Make_Attribute_Reference
(Loc
,
10150 Prefix
=> New_Copy_Tree
(Concval
),
10151 Attribute_Name
=> Name_Address
))),
10153 Make_Function_Call
(Loc
,
10154 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10155 Parameter_Associations
=> New_List
(
10156 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
10157 Make_Integer_Literal
(Loc
,
10158 DT_Position
(Entity
(Ename
))))))));
10163 Prepend_To
(Params
,
10164 Make_Function_Call
(Loc
,
10165 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10166 Parameter_Associations
=> New_List
(
10168 Make_Attribute_Reference
(Loc
,
10170 Attribute_Name
=> Name_Tag
),
10172 Make_Function_Call
(Loc
,
10173 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10175 Parameter_Associations
=> New_List
(
10179 Make_Attribute_Reference
(Loc
,
10181 Attribute_Name
=> Name_Tag
),
10185 Make_Attribute_Reference
(Loc
,
10186 Prefix
=> New_Occurrence_Of
(Etype
(Concval
), Loc
),
10187 Attribute_Name
=> Name_Tag
),
10191 Make_Integer_Literal
(Loc
,
10192 DT_Position
(Entity
(Ename
))))))));
10195 -- Specific actuals for protected to XXX requeue
10197 if Is_Protected_Type
(Old_Typ
) then
10198 Prepend_To
(Params
,
10199 Make_Attribute_Reference
(Loc
, -- _object'Address
10201 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10202 Attribute_Name
=> Name_Address
));
10204 Prepend_To
(Params
, -- True
10205 New_Occurrence_Of
(Standard_True
, Loc
));
10207 -- Specific actuals for task to XXX requeue
10210 pragma Assert
(Is_Task_Type
(Old_Typ
));
10212 Prepend_To
(Params
, -- null
10213 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
10215 Prepend_To
(Params
, -- False
10216 New_Occurrence_Of
(Standard_False
, Loc
));
10219 -- Add the object parameter
10221 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
10224 -- _Disp_Requeue (<Params>);
10226 -- Find entity for Disp_Requeue operation, which belongs to
10227 -- the type and may not be directly visible.
10234 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
10235 while Present
(Elmt
) loop
10237 exit when Chars
(Op
) = Name_uDisp_Requeue
;
10242 Make_Procedure_Call_Statement
(Loc
,
10243 Name
=> New_Occurrence_Of
(Op
, Loc
),
10244 Parameter_Associations
=> Params
);
10246 end Build_Dispatching_Requeue
;
10248 --------------------------------------
10249 -- Build_Dispatching_Requeue_To_Any --
10250 --------------------------------------
10252 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
10253 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10254 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10255 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
10265 -- Dispatch table slot processing, generate:
10268 S
:= Build_S
(Loc
, Decls
);
10270 -- Call kind processing, generate:
10271 -- C : Ada.Tags.Prim_Op_Kind;
10273 C
:= Build_C
(Loc
, Decls
);
10276 -- S := Ada.Tags.Get_Offset_Index
10277 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10279 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10282 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10285 Make_Procedure_Call_Statement
(Loc
,
10287 New_Occurrence_Of
(
10288 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10289 Name_uDisp_Get_Prim_Op_Kind
),
10291 Parameter_Associations
=> New_List
(
10292 New_Copy_Tree
(Obj
),
10293 New_Occurrence_Of
(S
, Loc
),
10294 New_Occurrence_Of
(C
, Loc
))));
10298 -- if C = POK_Protected_Entry
10299 -- or else C = POK_Task_Entry
10302 Make_Implicit_If_Statement
(N
,
10308 New_Occurrence_Of
(C
, Loc
),
10310 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
10315 New_Occurrence_Of
(C
, Loc
),
10317 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
10319 -- Dispatching requeue equivalent
10321 Then_Statements
=> New_List
(
10322 Build_Dispatching_Requeue
,
10325 -- elsif C = POK_Protected_Procedure then
10327 Elsif_Parts
=> New_List
(
10328 Make_Elsif_Part
(Loc
,
10332 New_Occurrence_Of
(C
, Loc
),
10334 New_Occurrence_Of
(
10335 RTE
(RE_POK_Protected_Procedure
), Loc
)),
10337 -- Dispatching call equivalent
10339 Then_Statements
=> New_List
(
10340 Build_Dispatching_Call_Equivalent
))),
10343 -- raise Program_Error;
10346 Else_Statements
=> New_List
(
10347 Make_Raise_Program_Error
(Loc
,
10348 Reason
=> PE_Explicit_Raise
))));
10350 -- Wrap everything into a block
10353 Make_Block_Statement
(Loc
,
10354 Declarations
=> Decls
,
10355 Handled_Statement_Sequence
=>
10356 Make_Handled_Sequence_Of_Statements
(Loc
,
10357 Statements
=> Stmts
));
10358 end Build_Dispatching_Requeue_To_Any
;
10360 --------------------------
10361 -- Build_Normal_Requeue --
10362 --------------------------
10364 function Build_Normal_Requeue
return Node_Id
is
10365 Params
: constant List_Id
:= New_List
;
10370 -- Process the "with abort" parameter
10372 Prepend_To
(Params
,
10373 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10375 -- Add the index expression to the parameters. It is common among all
10378 Prepend_To
(Params
,
10379 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
10381 if Is_Protected_Type
(Old_Typ
) then
10383 Self_Param
: Node_Id
;
10387 Make_Attribute_Reference
(Loc
,
10389 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10391 Name_Unchecked_Access
);
10393 -- Protected to protected requeue
10395 if Is_Protected_Type
(Conc_Typ
) then
10397 New_Occurrence_Of
(
10398 RTE
(RE_Requeue_Protected_Entry
), Loc
);
10401 Make_Attribute_Reference
(Loc
,
10403 Concurrent_Ref
(Concval
),
10405 Name_Unchecked_Access
);
10407 -- Protected to task requeue
10409 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10411 New_Occurrence_Of
(
10412 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
10414 Param
:= Concurrent_Ref
(Concval
);
10417 Prepend_To
(Params
, Param
);
10418 Prepend_To
(Params
, Self_Param
);
10421 else pragma Assert
(Is_Task_Type
(Old_Typ
));
10423 -- Task to protected requeue
10425 if Is_Protected_Type
(Conc_Typ
) then
10427 New_Occurrence_Of
(
10428 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
10431 Make_Attribute_Reference
(Loc
,
10433 Concurrent_Ref
(Concval
),
10435 Name_Unchecked_Access
);
10437 -- Task to task requeue
10439 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10441 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
);
10443 Param
:= Concurrent_Ref
(Concval
);
10446 Prepend_To
(Params
, Param
);
10450 Make_Procedure_Call_Statement
(Loc
,
10452 Parameter_Associations
=> Params
);
10453 end Build_Normal_Requeue
;
10455 --------------------------
10456 -- Build_Skip_Statement --
10457 --------------------------
10459 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
10460 Skip_Stmt
: Node_Id
;
10463 -- Build a return statement to skip the rest of the entire body
10465 if Is_Protected_Type
(Old_Typ
) then
10466 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
10468 -- If the requeue is within a task, find the end label of the
10469 -- enclosing accept statement and create a goto statement to it.
10477 -- Climb the parent chain looking for the enclosing accept
10480 Acc
:= Parent
(Search
);
10481 while Present
(Acc
)
10482 and then Nkind
(Acc
) /= N_Accept_Statement
10484 Acc
:= Parent
(Acc
);
10487 -- The last statement is the second label used for completing
10488 -- the rendezvous the usual way. The label we are looking for
10489 -- is right before it.
10492 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
10494 pragma Assert
(Nkind
(Label
) = N_Label
);
10496 -- Generate a goto statement to skip the rest of the accept
10499 Make_Goto_Statement
(Loc
,
10501 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
10505 Set_Analyzed
(Skip_Stmt
);
10508 end Build_Skip_Statement
;
10510 -- Start of processing for Expand_N_Requeue_Statement
10513 -- Extract the components of the entry call
10515 Extract_Entry
(N
, Concval
, Ename
, Index
);
10516 Conc_Typ
:= Etype
(Concval
);
10518 -- If the prefix is an access to class-wide type, dereference to get
10519 -- object and entry type.
10521 if Is_Access_Type
(Conc_Typ
) then
10522 Conc_Typ
:= Designated_Type
(Conc_Typ
);
10524 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Concval
)));
10525 Analyze_And_Resolve
(Concval
, Conc_Typ
);
10528 -- Examine the scope stack in order to find nearest enclosing protected
10529 -- or task type. This will constitute our invocation source.
10531 Old_Typ
:= Current_Scope
;
10532 while Present
(Old_Typ
)
10533 and then not Is_Protected_Type
(Old_Typ
)
10534 and then not Is_Task_Type
(Old_Typ
)
10536 Old_Typ
:= Scope
(Old_Typ
);
10539 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10540 -- Concval.Ename where the type of Concval is class-wide concurrent
10543 if Ada_Version
>= Ada_2012
10544 and then Present
(Concval
)
10545 and then Is_Class_Wide_Type
(Conc_Typ
)
10546 and then Is_Concurrent_Interface
(Conc_Typ
)
10549 Has_Impl
: Boolean := False;
10550 Impl_Kind
: Name_Id
:= No_Name
;
10553 -- Check whether the Ename is flagged by pragma Implemented
10555 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
10557 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
10560 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10561 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10563 if Has_Impl
and then Impl_Kind
= Name_By_Entry
then
10564 Rewrite
(N
, Build_Dispatching_Requeue
);
10566 Insert_After
(N
, Build_Skip_Statement
(N
));
10568 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10569 -- a protected procedure. In this case the requeue is transformed
10570 -- into a dispatching call.
10573 and then Impl_Kind
= Name_By_Protected_Procedure
10575 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
10578 -- The procedure_or_entry_NAME's implementation kind is either
10579 -- By_Any, Optional, or pragma Implemented was not applied at all.
10580 -- In this case a runtime test determines whether Ename denotes an
10581 -- entry or a protected procedure and performs the appropriate
10585 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
10590 -- Processing for regular (nondispatching) requeues
10593 Rewrite
(N
, Build_Normal_Requeue
);
10595 Insert_After
(N
, Build_Skip_Statement
(N
));
10597 end Expand_N_Requeue_Statement
;
10599 -------------------------------
10600 -- Expand_N_Selective_Accept --
10601 -------------------------------
10603 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10604 Loc
: constant Source_Ptr
:= Sloc
(N
);
10605 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10607 -- Note: in the below declarations a lot of new lists are allocated
10608 -- unconditionally which may well not end up being used. That's not
10609 -- a good idea since it wastes space gratuitously ???
10611 Accept_Case
: List_Id
;
10612 Accept_List
: constant List_Id
:= New_List
;
10615 Alt_List
: constant List_Id
:= New_List
;
10616 Alt_Stats
: List_Id
;
10617 Ann
: Entity_Id
:= Empty
;
10619 Check_Guard
: Boolean := True;
10621 Decls
: constant List_Id
:= New_List
;
10622 Stats
: constant List_Id
:= New_List
;
10623 Body_List
: constant List_Id
:= New_List
;
10624 Trailing_List
: constant List_Id
:= New_List
;
10627 Else_Present
: Boolean := False;
10628 Terminate_Alt
: Node_Id
:= Empty
;
10629 Select_Mode
: Node_Id
;
10631 Delay_Case
: List_Id
;
10632 Delay_Count
: Integer := 0;
10633 Delay_Val
: Entity_Id
;
10634 Delay_Index
: Entity_Id
;
10635 Delay_Min
: Entity_Id
;
10636 Delay_Num
: Pos
:= 1;
10637 Delay_Alt_List
: List_Id
:= New_List
;
10638 Delay_List
: constant List_Id
:= New_List
;
10642 First_Delay
: Boolean := True;
10643 Guard_Open
: Entity_Id
;
10649 Num_Accept
: Nat
:= 0;
10651 Time_Type
: Entity_Id
;
10652 Select_Call
: Node_Id
;
10654 Qnam
: constant Entity_Id
:=
10655 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10657 Xnam
: constant Entity_Id
:=
10658 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10660 -----------------------
10661 -- Local subprograms --
10662 -----------------------
10664 function Accept_Or_Raise
return List_Id
;
10665 -- For the rare case where delay alternatives all have guards, and
10666 -- all of them are closed, it is still possible that there were open
10667 -- accept alternatives with no callers. We must reexamine the
10668 -- Accept_List, and execute a selective wait with no else if some
10669 -- accept is open. If none, we raise program_error.
10671 procedure Add_Accept
(Alt
: Node_Id
);
10672 -- Process a single accept statement in a select alternative. Build
10673 -- procedure for body of accept, and add entry to dispatch table with
10674 -- expression for guard, in preparation for call to run time select.
10676 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10677 -- Manufacture a label using Num as a serial number and declare it.
10678 -- The declaration is appended to Decls. The label marks the trailing
10679 -- statements of an accept or delay alternative.
10681 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10682 -- Build call to Selective_Wait runtime routine
10684 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10685 -- Add code to compare value of delay with previous values, and
10686 -- generate case entry for trailing statements.
10688 procedure Process_Accept_Alternative
10692 -- Add code to call corresponding procedure, and branch to
10693 -- trailing statements, if any.
10695 ---------------------
10696 -- Accept_Or_Raise --
10697 ---------------------
10699 function Accept_Or_Raise
return List_Id
is
10702 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10705 -- We generate the following:
10707 -- for J in q'range loop
10708 -- if q(J).S /=null_task_entry then
10709 -- selective_wait (simple_mode,...);
10715 -- if no rendez_vous then
10716 -- raise program_error;
10719 -- Note that the code needs to know that the selector name
10720 -- in an Accept_Alternative is named S.
10722 Cond
:= Make_Op_Ne
(Loc
,
10724 Make_Selected_Component
(Loc
,
10726 Make_Indexed_Component
(Loc
,
10727 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10728 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))),
10729 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10731 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Loc
));
10733 Stats
:= New_List
(
10734 Make_Implicit_Loop_Statement
(N
,
10735 Iteration_Scheme
=>
10736 Make_Iteration_Scheme
(Loc
,
10737 Loop_Parameter_Specification
=>
10738 Make_Loop_Parameter_Specification
(Loc
,
10739 Defining_Identifier
=> J
,
10740 Discrete_Subtype_Definition
=>
10741 Make_Attribute_Reference
(Loc
,
10742 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10743 Attribute_Name
=> Name_Range
,
10744 Expressions
=> New_List
(
10745 Make_Integer_Literal
(Loc
, 1))))),
10747 Statements
=> New_List
(
10748 Make_Implicit_If_Statement
(N
,
10750 Then_Statements
=> New_List
(
10752 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)),
10753 Make_Exit_Statement
(Loc
))))));
10756 Make_Raise_Program_Error
(Loc
,
10757 Condition
=> Make_Op_Eq
(Loc
,
10758 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
10760 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
10761 Reason
=> PE_All_Guards_Closed
));
10764 end Accept_Or_Raise
;
10770 procedure Add_Accept
(Alt
: Node_Id
) is
10771 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10772 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10773 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10774 Eent
: constant Entity_Id
:= Entity
(Ename
);
10775 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10776 Null_Body
: Node_Id
;
10777 Proc_Body
: Node_Id
;
10778 PB_Ent
: Entity_Id
;
10784 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10787 if Present
(Condition
(Alt
)) then
10789 Make_If_Expression
(Eloc
, New_List
(
10791 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10792 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10795 Entry_Index_Expression
10796 (Eloc
, Eent
, Index
, Scope
(Eent
));
10799 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10800 Null_Body
:= New_Occurrence_Of
(Standard_False
, Eloc
);
10802 -- Always add call to Abort_Undefer when generating code, since
10803 -- this is what the runtime expects (abort deferred in
10804 -- Selective_Wait). In CodePeer mode this only confuses the
10805 -- analysis with unknown calls, so don't do it.
10807 if not CodePeer_Mode
then
10808 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10810 (First
(Statements
(Handled_Statement_Sequence
10811 (Accept_Statement
(Alt
)))),
10817 Make_Defining_Identifier
(Eloc
,
10818 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10820 if Comes_From_Source
(Alt
) then
10821 Set_Debug_Info_Needed
(PB_Ent
);
10825 Make_Subprogram_Body
(Eloc
,
10827 Make_Procedure_Specification
(Eloc
,
10828 Defining_Unit_Name
=> PB_Ent
),
10829 Declarations
=> Declarations
(Acc_Stm
),
10830 Handled_Statement_Sequence
=>
10831 Build_Accept_Body
(Accept_Statement
(Alt
)));
10833 -- During the analysis of the body of the accept statement, any
10834 -- zero cost exception handler records were collected in the
10835 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10836 -- This is where we move them to where they belong, namely the
10837 -- newly created procedure.
10839 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10840 Append
(Proc_Body
, Body_List
);
10843 Null_Body
:= New_Occurrence_Of
(Standard_True
, Eloc
);
10845 -- if accept statement has declarations, insert above, given that
10846 -- we are not creating a body for the accept.
10848 if Present
(Declarations
(Acc_Stm
)) then
10849 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10853 Append_To
(Accept_List
,
10854 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10856 Num_Accept
:= Num_Accept
+ 1;
10859 ----------------------------
10860 -- Make_And_Declare_Label --
10861 ----------------------------
10863 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10867 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10869 Make_Label
(Loc
, Lab_Id
);
10872 Make_Implicit_Label_Declaration
(Loc
,
10873 Defining_Identifier
=>
10874 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10875 Label_Construct
=> Lab
));
10878 end Make_And_Declare_Label
;
10880 ----------------------
10881 -- Make_Select_Call --
10882 ----------------------
10884 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10885 Params
: constant List_Id
:= New_List
;
10889 Make_Attribute_Reference
(Loc
,
10890 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10891 Attribute_Name
=> Name_Unchecked_Access
));
10892 Append_To
(Params
, Select_Mode
);
10893 Append_To
(Params
, New_Occurrence_Of
(Ann
, Loc
));
10894 Append_To
(Params
, New_Occurrence_Of
(Xnam
, Loc
));
10897 Make_Procedure_Call_Statement
(Loc
,
10898 Name
=> New_Occurrence_Of
(RTE
(RE_Selective_Wait
), Loc
),
10899 Parameter_Associations
=> Params
);
10900 end Make_Select_Call
;
10902 --------------------------------
10903 -- Process_Accept_Alternative --
10904 --------------------------------
10906 procedure Process_Accept_Alternative
10911 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10912 Alt_Stats
: List_Id
;
10915 Adjust_Condition
(Condition
(Alt
));
10917 -- Accept with body
10919 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10922 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10925 (Defining_Unit_Name
(Specification
(Proc
)),
10928 -- Accept with no body (followed by trailing statements)
10931 Alt_Stats
:= Empty_List
;
10934 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
10936 -- After the call, if any, branch to trailing statements, if any.
10937 -- We create a label for each, as well as the corresponding label
10940 if not Is_Empty_List
(Statements
(Alt
)) then
10941 Lab
:= Make_And_Declare_Label
(Index
);
10942 Append
(Lab
, Trailing_List
);
10943 Append_List
(Statements
(Alt
), Trailing_List
);
10944 Append_To
(Trailing_List
,
10945 Make_Goto_Statement
(Loc
,
10946 Name
=> New_Copy
(Identifier
(End_Lab
))));
10952 Append_To
(Alt_Stats
,
10953 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
10955 Append_To
(Alt_List
,
10956 Make_Case_Statement_Alternative
(Loc
,
10957 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
10958 Statements
=> Alt_Stats
));
10959 end Process_Accept_Alternative
;
10961 -------------------------------
10962 -- Process_Delay_Alternative --
10963 -------------------------------
10965 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
10966 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
10968 Delay_Alt
: List_Id
;
10971 -- Deal with C/Fortran boolean as delay condition
10973 Adjust_Condition
(Condition
(Alt
));
10975 -- Determine the smallest specified delay
10977 -- for each delay alternative generate:
10979 -- if guard-expression then
10980 -- Delay_Val := delay-expression;
10981 -- Guard_Open := True;
10982 -- if Delay_Val < Delay_Min then
10983 -- Delay_Min := Delay_Val;
10984 -- Delay_Index := Index;
10988 -- The enclosing if-statement is omitted if there is no guard
10990 if Delay_Count
= 1 or else First_Delay
then
10991 First_Delay
:= False;
10993 Delay_Alt
:= New_List
(
10994 Make_Assignment_Statement
(Loc
,
10995 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10996 Expression
=> Expression
(Delay_Statement
(Alt
))));
10998 if Delay_Count
> 1 then
10999 Append_To
(Delay_Alt
,
11000 Make_Assignment_Statement
(Loc
,
11001 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11002 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
11006 Delay_Alt
:= New_List
(
11007 Make_Assignment_Statement
(Loc
,
11008 Name
=> New_Occurrence_Of
(Delay_Val
, Loc
),
11009 Expression
=> Expression
(Delay_Statement
(Alt
))));
11011 if Time_Type
= Standard_Duration
then
11014 Left_Opnd
=> New_Occurrence_Of
(Delay_Val
, Loc
),
11015 Right_Opnd
=> New_Occurrence_Of
(Delay_Min
, Loc
));
11018 -- The scope of the time type must define a comparison
11019 -- operator. The scope itself may not be visible, so we
11020 -- construct a node with entity information to insure that
11021 -- semantic analysis can find the proper operator.
11024 Make_Function_Call
(Loc
,
11025 Name
=> Make_Selected_Component
(Loc
,
11027 New_Occurrence_Of
(Scope
(Time_Type
), Loc
),
11029 Make_Operator_Symbol
(Loc
,
11030 Chars
=> Name_Op_Lt
,
11031 Strval
=> No_String
)),
11032 Parameter_Associations
=>
11034 New_Occurrence_Of
(Delay_Val
, Loc
),
11035 New_Occurrence_Of
(Delay_Min
, Loc
)));
11037 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
11040 Append_To
(Delay_Alt
,
11041 Make_Implicit_If_Statement
(N
,
11043 Then_Statements
=> New_List
(
11044 Make_Assignment_Statement
(Loc
,
11045 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
11046 Expression
=> New_Occurrence_Of
(Delay_Val
, Loc
)),
11048 Make_Assignment_Statement
(Loc
,
11049 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11050 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
11053 if Check_Guard
then
11054 Append_To
(Delay_Alt
,
11055 Make_Assignment_Statement
(Loc
,
11056 Name
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11057 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11060 if Present
(Condition
(Alt
)) then
11061 Delay_Alt
:= New_List
(
11062 Make_Implicit_If_Statement
(N
,
11063 Condition
=> Condition
(Alt
),
11064 Then_Statements
=> Delay_Alt
));
11067 Append_List
(Delay_Alt
, Delay_List
);
11069 Ensure_Statement_Present
(Dloc
, Alt
);
11071 -- If the delay alternative has a statement part, add choice to the
11072 -- case statements for delays.
11074 if not Is_Empty_List
(Statements
(Alt
)) then
11076 if Delay_Count
= 1 then
11077 Append_List
(Statements
(Alt
), Delay_Alt_List
);
11080 Append_To
(Delay_Alt_List
,
11081 Make_Case_Statement_Alternative
(Loc
,
11082 Discrete_Choices
=> New_List
(
11083 Make_Integer_Literal
(Loc
, Index
)),
11084 Statements
=> Statements
(Alt
)));
11087 elsif Delay_Count
= 1 then
11089 -- If the single delay has no trailing statements, add a branch
11090 -- to the exit label to the selective wait.
11092 Delay_Alt_List
:= New_List
(
11093 Make_Goto_Statement
(Loc
,
11094 Name
=> New_Copy
(Identifier
(End_Lab
))));
11097 end Process_Delay_Alternative
;
11099 -- Start of processing for Expand_N_Selective_Accept
11102 Process_Statements_For_Controlled_Objects
(N
);
11104 -- First insert some declarations before the select. The first is:
11108 -- This variable holds the parameters passed to the accept body. This
11109 -- declaration has already been inserted by the time we get here by
11110 -- a call to Expand_Accept_Declarations made from the semantics when
11111 -- processing the first accept statement contained in the select. We
11112 -- can find this entity as Accept_Address (E), where E is any of the
11113 -- entries references by contained accept statements.
11115 -- The first step is to scan the list of Selective_Accept_Statements
11116 -- to find this entity, and also count the number of accepts, and
11117 -- determine if terminated, delay or else is present:
11121 Alt
:= First
(Alts
);
11122 while Present
(Alt
) loop
11123 Process_Statements_For_Controlled_Objects
(Alt
);
11125 if Nkind
(Alt
) = N_Accept_Alternative
then
11128 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11129 Delay_Count
:= Delay_Count
+ 1;
11131 -- If the delays are relative delays, the delay expressions have
11132 -- type Standard_Duration. Otherwise they must have some time type
11133 -- recognized by GNAT.
11135 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
11136 Time_Type
:= Standard_Duration
;
11138 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
11140 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
11141 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
11146 "& is not a time type (RM 9.6(6))",
11147 Expression
(Delay_Statement
(Alt
)), Time_Type
);
11148 Time_Type
:= Standard_Duration
;
11149 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
11153 if No
(Condition
(Alt
)) then
11155 -- This guard will always be open
11157 Check_Guard
:= False;
11160 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
11161 Adjust_Condition
(Condition
(Alt
));
11162 Terminate_Alt
:= Alt
;
11165 Num_Alts
:= Num_Alts
+ 1;
11169 Else_Present
:= Present
(Else_Statements
(N
));
11171 -- At the same time (see procedure Add_Accept) we build the accept list:
11173 -- Qnn : Accept_List (1 .. num-select) := (
11174 -- (null-body, entry-index),
11175 -- (null-body, entry-index),
11177 -- (null_body, entry-index));
11179 -- In the above declaration, null-body is True if the corresponding
11180 -- accept has no body, and false otherwise. The entry is either the
11181 -- entry index expression if there is no guard, or if a guard is
11182 -- present, then an if expression of the form:
11184 -- (if guard then entry-index else Null_Task_Entry)
11186 -- If a guard is statically known to be false, the entry can simply
11187 -- be omitted from the accept list.
11190 Make_Object_Declaration
(Loc
,
11191 Defining_Identifier
=> Qnam
,
11192 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11193 Aliased_Present
=> True,
11195 Make_Qualified_Expression
(Loc
,
11197 New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11199 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
11201 -- Then we declare the variable that holds the index for the accept
11202 -- that will be selected for service:
11204 -- Xnn : Select_Index;
11207 Make_Object_Declaration
(Loc
,
11208 Defining_Identifier
=> Xnam
,
11209 Object_Definition
=>
11210 New_Occurrence_Of
(RTE
(RE_Select_Index
), Loc
),
11212 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)));
11214 -- After this follow procedure declarations for each accept body
11216 -- procedure Pnn is
11221 -- where the ... are statements from the corresponding procedure body.
11222 -- No parameters are involved, since the parameters are passed via Ann
11223 -- and the parameter references have already been expanded to be direct
11224 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11225 -- any embedded tasking statements (which would normally be illegal in
11226 -- procedures), have been converted to calls to the tasking runtime so
11227 -- there is no problem in putting them into procedures.
11229 -- The original accept statement has been expanded into a block in
11230 -- the same fashion as for simple accepts (see Build_Accept_Body).
11232 -- Note: we don't really need to build these procedures for the case
11233 -- where no delay statement is present, but it is just as easy to
11234 -- build them unconditionally, and not significantly inefficient,
11235 -- since if they are short they will be inlined anyway.
11237 -- The procedure declarations have been assembled in Body_List
11239 -- If delays are present, we must compute the required delay.
11240 -- We first generate the declarations:
11242 -- Delay_Index : Boolean := 0;
11243 -- Delay_Min : Some_Time_Type.Time;
11244 -- Delay_Val : Some_Time_Type.Time;
11246 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11247 -- active delay that is actually chosen as the basis for the possible
11248 -- delay if an immediate rendez-vous is not possible.
11250 -- In the most common case there is a single delay statement, and this
11251 -- is handled specially.
11253 if Delay_Count
> 0 then
11255 -- Generate the required declarations
11258 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
11260 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
11262 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
11265 Make_Object_Declaration
(Loc
,
11266 Defining_Identifier
=> Delay_Val
,
11267 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
)));
11270 Make_Object_Declaration
(Loc
,
11271 Defining_Identifier
=> Delay_Index
,
11272 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11273 Expression
=> Make_Integer_Literal
(Loc
, 0)));
11276 Make_Object_Declaration
(Loc
,
11277 Defining_Identifier
=> Delay_Min
,
11278 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
),
11280 Unchecked_Convert_To
(Time_Type
,
11281 Make_Attribute_Reference
(Loc
,
11283 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
11284 Attribute_Name
=> Name_Last
))));
11286 -- Create Duration and Delay_Mode objects used for passing a delay
11289 D
:= Make_Temporary
(Loc
, 'D');
11290 M
:= Make_Temporary
(Loc
, 'M');
11296 -- Note that these values are defined in s-osprim.ads and must
11297 -- be kept in sync:
11299 -- Relative : constant := 0;
11300 -- Absolute_Calendar : constant := 1;
11301 -- Absolute_RT : constant := 2;
11303 if Time_Type
= Standard_Duration
then
11304 Discr
:= Make_Integer_Literal
(Loc
, 0);
11306 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11307 Discr
:= Make_Integer_Literal
(Loc
, 1);
11311 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11312 Discr
:= Make_Integer_Literal
(Loc
, 2);
11316 Make_Object_Declaration
(Loc
,
11317 Defining_Identifier
=> D
,
11318 Object_Definition
=>
11319 New_Occurrence_Of
(Standard_Duration
, Loc
)));
11322 Make_Object_Declaration
(Loc
,
11323 Defining_Identifier
=> M
,
11324 Object_Definition
=>
11325 New_Occurrence_Of
(Standard_Integer
, Loc
),
11326 Expression
=> Discr
));
11329 if Check_Guard
then
11331 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
11334 Make_Object_Declaration
(Loc
,
11335 Defining_Identifier
=> Guard_Open
,
11336 Object_Definition
=>
11337 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11339 New_Occurrence_Of
(Standard_False
, Loc
)));
11342 -- Delay_Count is zero, don't need M and D set (suppress warning)
11349 if Present
(Terminate_Alt
) then
11351 -- If the terminate alternative guard is False, use
11352 -- Simple_Mode; otherwise use Terminate_Mode.
11354 if Present
(Condition
(Terminate_Alt
)) then
11355 Select_Mode
:= Make_If_Expression
(Loc
,
11356 New_List
(Condition
(Terminate_Alt
),
11357 New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
),
11358 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)));
11360 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
);
11363 elsif Else_Present
or Delay_Count
> 0 then
11364 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Else_Mode
), Loc
);
11367 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
);
11370 Select_Call
:= Make_Select_Call
(Select_Mode
);
11371 Append
(Select_Call
, Stats
);
11373 -- Now generate code to act on the result. There is an entry
11374 -- in this case for each accept statement with a non-null body,
11375 -- followed by a branch to the statements that follow the Accept.
11376 -- In the absence of delay alternatives, we generate:
11379 -- when No_Rendezvous => -- omitted if simple mode
11394 -- Lab0: Else_Statements;
11397 -- Lab1: Trailing_Statements1;
11400 -- Lab2: Trailing_Statements2;
11405 -- Generate label for common exit
11407 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
11409 -- First entry is the default case, when no rendezvous is possible
11411 Choices
:= New_List
(New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
));
11413 if Else_Present
then
11415 -- If no rendezvous is possible, the else part is executed
11417 Lab
:= Make_And_Declare_Label
(0);
11418 Alt_Stats
:= New_List
(
11419 Make_Goto_Statement
(Loc
,
11420 Name
=> New_Copy
(Identifier
(Lab
))));
11422 Append
(Lab
, Trailing_List
);
11423 Append_List
(Else_Statements
(N
), Trailing_List
);
11424 Append_To
(Trailing_List
,
11425 Make_Goto_Statement
(Loc
,
11426 Name
=> New_Copy
(Identifier
(End_Lab
))));
11428 Alt_Stats
:= New_List
(
11429 Make_Goto_Statement
(Loc
,
11430 Name
=> New_Copy
(Identifier
(End_Lab
))));
11433 Append_To
(Alt_List
,
11434 Make_Case_Statement_Alternative
(Loc
,
11435 Discrete_Choices
=> Choices
,
11436 Statements
=> Alt_Stats
));
11438 -- We make use of the fact that Accept_Index is an integer type, and
11439 -- generate successive literals for entries for each accept. Only those
11440 -- for which there is a body or trailing statements get a case entry.
11442 Alt
:= First
(Select_Alternatives
(N
));
11443 Proc
:= First
(Body_List
);
11444 while Present
(Alt
) loop
11446 if Nkind
(Alt
) = N_Accept_Alternative
then
11447 Process_Accept_Alternative
(Alt
, Index
, Proc
);
11448 Index
:= Index
+ 1;
11451 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
11456 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11457 Process_Delay_Alternative
(Alt
, Delay_Num
);
11458 Delay_Num
:= Delay_Num
+ 1;
11464 -- An others choice is always added to the main case, as well
11465 -- as the delay case (to satisfy the compiler).
11467 Append_To
(Alt_List
,
11468 Make_Case_Statement_Alternative
(Loc
,
11469 Discrete_Choices
=>
11470 New_List
(Make_Others_Choice
(Loc
)),
11472 New_List
(Make_Goto_Statement
(Loc
,
11473 Name
=> New_Copy
(Identifier
(End_Lab
))))));
11475 Accept_Case
:= New_List
(
11476 Make_Case_Statement
(Loc
,
11477 Expression
=> New_Occurrence_Of
(Xnam
, Loc
),
11478 Alternatives
=> Alt_List
));
11480 Append_List
(Trailing_List
, Accept_Case
);
11481 Append_List
(Body_List
, Decls
);
11483 -- Construct case statement for trailing statements of delay
11484 -- alternatives, if there are several of them.
11486 if Delay_Count
> 1 then
11487 Append_To
(Delay_Alt_List
,
11488 Make_Case_Statement_Alternative
(Loc
,
11489 Discrete_Choices
=>
11490 New_List
(Make_Others_Choice
(Loc
)),
11492 New_List
(Make_Null_Statement
(Loc
))));
11494 Delay_Case
:= New_List
(
11495 Make_Case_Statement
(Loc
,
11496 Expression
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11497 Alternatives
=> Delay_Alt_List
));
11499 Delay_Case
:= Delay_Alt_List
;
11502 -- If there are no delay alternatives, we append the case statement
11503 -- to the statement list.
11505 if Delay_Count
= 0 then
11506 Append_List
(Accept_Case
, Stats
);
11508 -- Delay alternatives present
11511 -- If delay alternatives are present we generate:
11513 -- find minimum delay.
11514 -- DX := minimum delay;
11515 -- M := <delay mode>;
11516 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11519 -- if X = No_Rendezvous then
11520 -- case statement for delay statements.
11522 -- case statement for accept alternatives.
11533 -- The type of the delay expression is known to be legal
11535 if Time_Type
= Standard_Duration
then
11536 Conv
:= New_Occurrence_Of
(Delay_Min
, Loc
);
11538 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11539 Conv
:= Make_Function_Call
(Loc
,
11540 New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
11541 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11545 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11547 Conv
:= Make_Function_Call
(Loc
,
11548 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
11549 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11552 Stmt
:= Make_Assignment_Statement
(Loc
,
11553 Name
=> New_Occurrence_Of
(D
, Loc
),
11554 Expression
=> Conv
);
11556 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11558 Parms
:= Parameter_Associations
(Select_Call
);
11560 Parm
:= First
(Parms
);
11561 while Present
(Parm
) and then Parm
/= Select_Mode
loop
11565 pragma Assert
(Present
(Parm
));
11566 Rewrite
(Parm
, New_Occurrence_Of
(RTE
(RE_Delay_Mode
), Loc
));
11569 -- Prepare two new parameters of Duration and Delay_Mode type
11570 -- which represent the value and the mode of the minimum delay.
11573 Insert_After
(Parm
, New_Occurrence_Of
(M
, Loc
));
11574 Insert_After
(Parm
, New_Occurrence_Of
(D
, Loc
));
11576 -- Create a call to RTS
11578 Rewrite
(Select_Call
,
11579 Make_Procedure_Call_Statement
(Loc
,
11580 Name
=> New_Occurrence_Of
(RTE
(RE_Timed_Selective_Wait
), Loc
),
11581 Parameter_Associations
=> Parms
));
11583 -- This new call should follow the calculation of the minimum
11586 Insert_List_Before
(Select_Call
, Delay_List
);
11588 if Check_Guard
then
11590 Make_Implicit_If_Statement
(N
,
11591 Condition
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11592 Then_Statements
=> New_List
(
11593 New_Copy_Tree
(Stmt
),
11594 New_Copy_Tree
(Select_Call
)),
11595 Else_Statements
=> Accept_Or_Raise
);
11596 Rewrite
(Select_Call
, Stmt
);
11598 Insert_Before
(Select_Call
, Stmt
);
11602 Make_Implicit_If_Statement
(N
,
11603 Condition
=> Make_Op_Eq
(Loc
,
11604 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
11606 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
11608 Then_Statements
=> Delay_Case
,
11609 Else_Statements
=> Accept_Case
);
11611 Append
(Cases
, Stats
);
11615 Append
(End_Lab
, Stats
);
11617 -- Replace accept statement with appropriate block
11620 Make_Block_Statement
(Loc
,
11621 Declarations
=> Decls
,
11622 Handled_Statement_Sequence
=>
11623 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11626 -- Note: have to worry more about abort deferral in above code ???
11628 -- Final step is to unstack the Accept_Address entries for all accept
11629 -- statements appearing in accept alternatives in the select statement
11631 Alt
:= First
(Alts
);
11632 while Present
(Alt
) loop
11633 if Nkind
(Alt
) = N_Accept_Alternative
then
11634 Remove_Last_Elmt
(Accept_Address
11635 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11640 end Expand_N_Selective_Accept
;
11642 -------------------------------------------
11643 -- Expand_N_Single_Protected_Declaration --
11644 -------------------------------------------
11646 -- A single protected declaration should never be present after semantic
11647 -- analysis because it is transformed into a protected type declaration
11648 -- and an accompanying anonymous object. This routine ensures that the
11649 -- transformation takes place.
11651 procedure Expand_N_Single_Protected_Declaration
(N
: Node_Id
) is
11653 raise Program_Error
;
11654 end Expand_N_Single_Protected_Declaration
;
11656 --------------------------------------
11657 -- Expand_N_Single_Task_Declaration --
11658 --------------------------------------
11660 -- A single task declaration should never be present after semantic
11661 -- analysis because it is transformed into a task type declaration and
11662 -- an accompanying anonymous object. This routine ensures that the
11663 -- transformation takes place.
11665 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11667 raise Program_Error
;
11668 end Expand_N_Single_Task_Declaration
;
11670 ------------------------
11671 -- Expand_N_Task_Body --
11672 ------------------------
11674 -- Given a task body
11676 -- task body tname is
11682 -- This expansion routine converts it into a procedure and sets the
11683 -- elaboration flag for the procedure to true, to represent the fact
11684 -- that the task body is now elaborated:
11686 -- procedure tnameB (_Task : access tnameV) is
11687 -- discriminal : dtype renames _Task.discriminant;
11689 -- procedure _clean is
11691 -- Abort_Defer.all;
11693 -- Abort_Undefer.all;
11698 -- Abort_Undefer.all;
11700 -- System.Task_Stages.Complete_Activation;
11708 -- In addition, if the task body is an activator, then a call to activate
11709 -- tasks is added at the start of the statements, before the call to
11710 -- Complete_Activation, and if in addition the task is a master then it
11711 -- must be established as a master. These calls are inserted and analyzed
11712 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11715 -- There is one discriminal declaration line generated for each
11716 -- discriminant that is present to provide an easy reference point for
11717 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11719 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11720 -- task body procedures have a profile (Arg : System.Address). That is
11721 -- needed because GNARLI has to use the same access-to-subprogram type
11722 -- for all task types. We depend here on knowing that in GNAT, passing
11723 -- an address argument by value is identical to passing a record value
11724 -- by access (in either case a single pointer is passed), so even though
11725 -- this procedure has the wrong profile. In fact it's all OK, since the
11726 -- callings sequence is identical.
11728 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11729 Loc
: constant Source_Ptr
:= Sloc
(N
);
11730 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11734 Insert_Nod
: Node_Id
;
11735 -- Used to determine the proper location of wrapper body insertions
11738 -- if no task body procedure, means we had an error in configurable
11739 -- run-time mode, and there is no point in proceeding further.
11741 if No
(Task_Body_Procedure
(Ttyp
)) then
11745 -- Add renaming declarations for discriminals and a declaration for the
11746 -- entry family index (if applicable).
11748 Install_Private_Data_Declarations
11749 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11751 -- Add a call to Abort_Undefer at the very beginning of the task
11752 -- body since this body is called with abort still deferred.
11754 if Abort_Allowed
then
11755 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11757 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11761 -- The statement part has already been protected with an at_end and
11762 -- cleanup actions. The call to Complete_Activation must be placed
11763 -- at the head of the sequence of statements of that block. The
11764 -- declarations have been merged in this sequence of statements but
11765 -- the first real statement is accessible from the First_Real_Statement
11766 -- field (which was set for exactly this purpose).
11768 if Restricted_Profile
then
11769 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11771 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11775 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11779 Make_Subprogram_Body
(Loc
,
11780 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11781 Declarations
=> Declarations
(N
),
11782 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11783 Set_Is_Task_Body_Procedure
(New_N
);
11785 -- If the task contains generic instantiations, cleanup actions are
11786 -- delayed until after instantiation. Transfer the activation chain to
11787 -- the subprogram, to insure that the activation call is properly
11788 -- generated. It the task body contains inner tasks, indicate that the
11789 -- subprogram is a task master.
11791 if Delay_Cleanups
(Ttyp
) then
11792 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11793 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11796 Rewrite
(N
, New_N
);
11799 -- Set elaboration flag immediately after task body. If the body is a
11800 -- subunit, the flag is set in the declarative part containing the stub.
11802 if Nkind
(Parent
(N
)) /= N_Subunit
then
11804 Make_Assignment_Statement
(Loc
,
11806 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11807 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11810 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11811 -- the task body. At this point all wrapper specs have been created,
11812 -- frozen and included in the dispatch table for the task type.
11814 if Ada_Version
>= Ada_2005
then
11815 if Nkind
(Parent
(N
)) = N_Subunit
then
11816 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11821 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11823 end Expand_N_Task_Body
;
11825 ------------------------------------
11826 -- Expand_N_Task_Type_Declaration --
11827 ------------------------------------
11829 -- We have several things to do. First we must create a Boolean flag used
11830 -- to mark if the body is elaborated yet. This variable gets set to True
11831 -- when the body of the task is elaborated (we can't rely on the normal
11832 -- ABE mechanism for the task body, since we need to pass an access to
11833 -- this elaboration boolean to the runtime routines).
11835 -- taskE : aliased Boolean := False;
11837 -- Next a variable is declared to hold the task stack size (either the
11838 -- default : Unspecified_Size, or a value that is set by a pragma
11839 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11840 -- the variable is initialized with this value:
11842 -- taskZ : Size_Type := Unspecified_Size;
11844 -- taskZ : Size_Type := Size_Type (size_expression);
11846 -- Note: No variable is needed to hold the task relative deadline since
11847 -- its value would never be static because the parameter is of a private
11848 -- type (Ada.Real_Time.Time_Span).
11850 -- Next we create a corresponding record type declaration used to represent
11851 -- values of this task. The general form of this type declaration is
11853 -- type taskV (discriminants) is record
11854 -- _Task_Id : Task_Id;
11855 -- entry_family : array (bounds) of Void;
11856 -- _Priority : Integer := priority_expression;
11857 -- _Size : Size_Type := size_expression;
11858 -- _Task_Info : Task_Info_Type := task_info_expression;
11859 -- _CPU : Integer := cpu_range_expression;
11860 -- _Relative_Deadline : Time_Span := time_span_expression;
11861 -- _Domain : Dispatching_Domain := dd_expression;
11864 -- The discriminants are present only if the corresponding task type has
11865 -- discriminants, and they exactly mirror the task type discriminants.
11867 -- The Id field is always present. It contains the Task_Id value, as set by
11868 -- the call to Create_Task. Note that although the task is limited, the
11869 -- task value record type is not limited, so there is no problem in passing
11870 -- this field as an out parameter to Create_Task.
11872 -- One entry_family component is present for each entry family in the task
11873 -- definition. The bounds correspond to the bounds of the entry family
11874 -- (which may depend on discriminants). The element type is void, since we
11875 -- only need the bounds information for determining the entry index. Note
11876 -- that the use of an anonymous array would normally be illegal in this
11877 -- context, but this is a parser check, and the semantics is quite prepared
11878 -- to handle such a case.
11880 -- The _Size field is present only if a Storage_Size pragma appears in the
11881 -- task definition. The expression captures the argument that was present
11882 -- in the pragma, and is used to override the task stack size otherwise
11883 -- associated with the task type.
11885 -- The _Priority field is present only if the task entity has a Priority or
11886 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11887 -- definition clause). It will be filled at the freeze point, when the
11888 -- record init proc is built, to capture the expression of the rep item
11889 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11890 -- here since aspect evaluations are delayed till the freeze point.
11892 -- The _Task_Info field is present only if a Task_Info pragma appears in
11893 -- the task definition. The expression captures the argument that was
11894 -- present in the pragma, and is used to provide the Task_Image parameter
11895 -- to the call to Create_Task.
11897 -- The _CPU field is present only if the task entity has a CPU rep item
11898 -- (pragma, aspect specification or attribute definition clause). It will
11899 -- be filled at the freeze point, when the record init proc is built, to
11900 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11901 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11902 -- are delayed till the freeze point.
11904 -- The _Relative_Deadline field is present only if a Relative_Deadline
11905 -- pragma appears in the task definition. The expression captures the
11906 -- argument that was present in the pragma, and is used to provide the
11907 -- Relative_Deadline parameter to the call to Create_Task.
11909 -- The _Domain field is present only if the task entity has a
11910 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11911 -- definition clause). It will be filled at the freeze point, when the
11912 -- record init proc is built, to capture the expression of the rep item
11913 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11914 -- here since aspect evaluations are delayed till the freeze point.
11916 -- When a task is declared, an instance of the task value record is
11917 -- created. The elaboration of this declaration creates the correct bounds
11918 -- for the entry families, and also evaluates the size, priority, and
11919 -- task_Info expressions if needed. The initialization routine for the task
11920 -- type itself then calls Create_Task with appropriate parameters to
11921 -- initialize the value of the Task_Id field.
11923 -- Note: the address of this record is passed as the "Discriminants"
11924 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11925 -- body procedure, it does not matter that it does not quite match the
11926 -- GNARLI model of what is being passed (the record contains more than just
11927 -- the discriminants, but the discriminants can be found from the record
11930 -- The Entity_Id for this created record type is placed in the
11931 -- Corresponding_Record_Type field of the associated task type entity.
11933 -- Next we create a procedure specification for the task body procedure:
11935 -- procedure taskB (_Task : access taskV);
11937 -- Note that this must come after the record type declaration, since
11938 -- the spec refers to this type. It turns out that the initialization
11939 -- procedure for the value type references the task body spec, but that's
11940 -- fine, since it won't be generated till the freeze point for the type,
11941 -- which is certainly after the task body spec declaration.
11943 -- Finally, we set the task index value field of the entry attribute in
11944 -- the case of a simple entry.
11946 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
11947 Loc
: constant Source_Ptr
:= Sloc
(N
);
11948 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
11949 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
11950 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
11951 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
11953 Body_Decl
: Node_Id
;
11955 Decl_Stack
: Node_Id
;
11956 Elab_Decl
: Node_Id
;
11957 Ent_Stack
: Entity_Id
;
11958 Proc_Spec
: Node_Id
;
11959 Rec_Decl
: Node_Id
;
11960 Rec_Ent
: Entity_Id
;
11961 Size_Decl
: Entity_Id
;
11962 Task_Size
: Node_Id
;
11964 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
11965 -- Searches the task definition T for the first occurrence of the pragma
11966 -- Relative Deadline. The caller has ensured that the pragma is present
11967 -- in the task definition. Note that this routine cannot be implemented
11968 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11969 -- not chained because their expansion into a procedure call statement
11970 -- would cause a break in the chain.
11972 ----------------------------------
11973 -- Get_Relative_Deadline_Pragma --
11974 ----------------------------------
11976 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
11980 N
:= First
(Visible_Declarations
(T
));
11981 while Present
(N
) loop
11982 if Nkind
(N
) = N_Pragma
11983 and then Pragma_Name
(N
) = Name_Relative_Deadline
11991 N
:= First
(Private_Declarations
(T
));
11992 while Present
(N
) loop
11993 if Nkind
(N
) = N_Pragma
11994 and then Pragma_Name
(N
) = Name_Relative_Deadline
12002 raise Program_Error
;
12003 end Get_Relative_Deadline_Pragma
;
12005 -- Start of processing for Expand_N_Task_Type_Declaration
12008 -- If already expanded, nothing to do
12010 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
12014 -- Here we will do the expansion
12016 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
12018 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
12019 Cdecls
:= Component_Items
(Component_List
12020 (Type_Definition
(Rec_Decl
)));
12022 Qualify_Entity_Names
(N
);
12024 -- First create the elaboration variable
12027 Make_Object_Declaration
(Loc
,
12028 Defining_Identifier
=>
12029 Make_Defining_Identifier
(Sloc
(Tasktyp
),
12030 Chars
=> New_External_Name
(Tasknm
, 'E')),
12031 Aliased_Present
=> True,
12032 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
12033 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
12035 Insert_After
(N
, Elab_Decl
);
12037 -- Next create the declaration of the size variable (tasknmZ)
12039 Set_Storage_Size_Variable
(Tasktyp
,
12040 Make_Defining_Identifier
(Sloc
(Tasktyp
),
12041 Chars
=> New_External_Name
(Tasknm
, 'Z')));
12043 if Present
(Taskdef
)
12044 and then Has_Storage_Size_Pragma
(Taskdef
)
12046 Is_OK_Static_Expression
12048 (First
(Pragma_Argument_Associations
12049 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
12052 Make_Object_Declaration
(Loc
,
12053 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
12054 Object_Definition
=>
12055 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12057 Convert_To
(RTE
(RE_Size_Type
),
12059 (Expression
(First
(Pragma_Argument_Associations
12061 (TaskId
, Name_Storage_Size
)))))));
12065 Make_Object_Declaration
(Loc
,
12066 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
12067 Object_Definition
=>
12068 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12070 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
12073 Insert_After
(Elab_Decl
, Size_Decl
);
12075 -- Next build the rest of the corresponding record declaration. This is
12076 -- done last, since the corresponding record initialization procedure
12077 -- will reference the previously created entities.
12079 -- Fill in the component declarations -- first the _Task_Id field
12082 Make_Component_Declaration
(Loc
,
12083 Defining_Identifier
=>
12084 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
12085 Component_Definition
=>
12086 Make_Component_Definition
(Loc
,
12087 Aliased_Present
=> False,
12088 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RO_ST_Task_Id
),
12091 -- Declare static ATCB (that is, created by the expander) if we are
12092 -- using the Restricted run time.
12094 if Restricted_Profile
then
12096 Make_Component_Declaration
(Loc
,
12097 Defining_Identifier
=>
12098 Make_Defining_Identifier
(Loc
, Name_uATCB
),
12100 Component_Definition
=>
12101 Make_Component_Definition
(Loc
,
12102 Aliased_Present
=> True,
12103 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12105 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
12108 Make_Index_Or_Discriminant_Constraint
(Loc
,
12110 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
12114 -- Declare static stack (that is, created by the expander) if we are
12115 -- using the Restricted run time on a bare board configuration.
12117 if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
12119 -- First we need to extract the appropriate stack size
12121 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
12123 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12125 Expr_N
: constant Node_Id
:=
12126 Expression
(First
(
12127 Pragma_Argument_Associations
(
12128 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
12129 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
12130 P
: constant Node_Id
:= Parent
(Expr_N
);
12133 -- The stack is defined inside the corresponding record.
12134 -- Therefore if the size of the stack is set by means of
12135 -- a discriminant, we must reference the discriminant of the
12136 -- corresponding record type.
12138 if Nkind
(Expr_N
) in N_Has_Entity
12139 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
12143 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
12145 Set_Parent
(Task_Size
, P
);
12146 Set_Etype
(Task_Size
, Etyp
);
12147 Set_Analyzed
(Task_Size
);
12150 Task_Size
:= Relocate_Node
(Expr_N
);
12156 New_Occurrence_Of
(RTE
(RE_Default_Stack_Size
), Loc
);
12159 Decl_Stack
:= Make_Component_Declaration
(Loc
,
12160 Defining_Identifier
=> Ent_Stack
,
12162 Component_Definition
=>
12163 Make_Component_Definition
(Loc
,
12164 Aliased_Present
=> True,
12165 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12167 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
12170 Make_Index_Or_Discriminant_Constraint
(Loc
,
12171 Constraints
=> New_List
(Make_Range
(Loc
,
12172 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
12173 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
12176 Append_To
(Cdecls
, Decl_Stack
);
12178 -- The appropriate alignment for the stack is ensured by the run-time
12179 -- code in charge of task creation.
12183 -- Add components for entry families
12185 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
12187 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12188 -- item is present.
12190 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
12192 Make_Component_Declaration
(Loc
,
12193 Defining_Identifier
=>
12194 Make_Defining_Identifier
(Loc
, Name_uPriority
),
12195 Component_Definition
=>
12196 Make_Component_Definition
(Loc
,
12197 Aliased_Present
=> False,
12198 Subtype_Indication
=>
12199 New_Occurrence_Of
(Standard_Integer
, Loc
))));
12202 -- Add the _Size component if a Storage_Size pragma is present
12204 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12206 Make_Component_Declaration
(Loc
,
12207 Defining_Identifier
=>
12208 Make_Defining_Identifier
(Loc
, Name_uSize
),
12210 Component_Definition
=>
12211 Make_Component_Definition
(Loc
,
12212 Aliased_Present
=> False,
12213 Subtype_Indication
=>
12214 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
)),
12217 Convert_To
(RTE
(RE_Size_Type
),
12219 Expression
(First
(
12220 Pragma_Argument_Associations
(
12221 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
12224 -- Add the _Task_Info component if a Task_Info pragma is present
12226 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
12228 Make_Component_Declaration
(Loc
,
12229 Defining_Identifier
=>
12230 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
12232 Component_Definition
=>
12233 Make_Component_Definition
(Loc
,
12234 Aliased_Present
=> False,
12235 Subtype_Indication
=>
12236 New_Occurrence_Of
(RTE
(RE_Task_Info_Type
), Loc
)),
12238 Expression
=> New_Copy
(
12239 Expression
(First
(
12240 Pragma_Argument_Associations
(
12242 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
12245 -- Add the _CPU component if a CPU rep item is present
12247 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
12249 Make_Component_Declaration
(Loc
,
12250 Defining_Identifier
=>
12251 Make_Defining_Identifier
(Loc
, Name_uCPU
),
12253 Component_Definition
=>
12254 Make_Component_Definition
(Loc
,
12255 Aliased_Present
=> False,
12256 Subtype_Indication
=>
12257 New_Occurrence_Of
(RTE
(RE_CPU_Range
), Loc
))));
12260 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12261 -- present. If we are using a restricted run time this component will
12262 -- not be added (deadlines are not allowed by the Ravenscar profile).
12264 if not Restricted_Profile
12265 and then Present
(Taskdef
)
12266 and then Has_Relative_Deadline_Pragma
(Taskdef
)
12269 Make_Component_Declaration
(Loc
,
12270 Defining_Identifier
=>
12271 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
12273 Component_Definition
=>
12274 Make_Component_Definition
(Loc
,
12275 Aliased_Present
=> False,
12276 Subtype_Indication
=>
12277 New_Occurrence_Of
(RTE
(RE_Time_Span
), Loc
)),
12280 Convert_To
(RTE
(RE_Time_Span
),
12282 Expression
(First
(
12283 Pragma_Argument_Associations
(
12284 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
12287 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12288 -- item is present. If we are using a restricted run time this component
12289 -- will not be added (dispatching domains are not allowed by the
12290 -- Ravenscar profile).
12292 if not Restricted_Profile
12295 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
12298 Make_Component_Declaration
(Loc
,
12299 Defining_Identifier
=>
12300 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
12302 Component_Definition
=>
12303 Make_Component_Definition
(Loc
,
12304 Aliased_Present
=> False,
12305 Subtype_Indication
=>
12307 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
12310 Insert_After
(Size_Decl
, Rec_Decl
);
12312 -- Analyze the record declaration immediately after construction,
12313 -- because the initialization procedure is needed for single task
12314 -- declarations before the next entity is analyzed.
12316 Analyze
(Rec_Decl
);
12318 -- Create the declaration of the task body procedure
12320 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
12322 Make_Subprogram_Declaration
(Loc
,
12323 Specification
=> Proc_Spec
);
12324 Set_Is_Task_Body_Procedure
(Body_Decl
);
12326 Insert_After
(Rec_Decl
, Body_Decl
);
12328 -- The subprogram does not comes from source, so we have to indicate the
12329 -- need for debugging information explicitly.
12331 if Comes_From_Source
(Original_Node
(N
)) then
12332 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
12335 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12336 -- the corresponding record has been frozen.
12338 if Ada_Version
>= Ada_2005
then
12339 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
12342 -- Ada 2005 (AI-345): We must defer freezing to allow further
12343 -- declaration of primitive subprograms covering task interfaces
12345 if Ada_Version
<= Ada_95
then
12347 -- Now we can freeze the corresponding record. This needs manually
12348 -- freezing, since it is really part of the task type, and the task
12349 -- type is frozen at this stage. We of course need the initialization
12350 -- procedure for this corresponding record type and we won't get it
12351 -- in time if we don't freeze now.
12354 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
12356 if Is_Non_Empty_List
(L
) then
12357 Insert_List_After
(Body_Decl
, L
);
12362 -- Complete the expansion of access types to the current task type, if
12363 -- any were declared.
12365 Expand_Previous_Access_Type
(Tasktyp
);
12367 -- Create wrappers for entries that have contract cases, preconditions
12368 -- and postconditions.
12374 Ent
:= First_Entity
(Tasktyp
);
12375 while Present
(Ent
) loop
12376 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
) then
12377 Build_Contract_Wrapper
(Ent
, N
);
12383 end Expand_N_Task_Type_Declaration
;
12385 -------------------------------
12386 -- Expand_N_Timed_Entry_Call --
12387 -------------------------------
12389 -- A timed entry call in normal case is not implemented using ATC mechanism
12390 -- anymore for efficiency reason.
12400 -- is expanded as follows:
12402 -- 1) When T.E is a task entry_call;
12406 -- X : Task_Entry_Index := <entry index>;
12407 -- DX : Duration := To_Duration (D);
12408 -- M : Delay_Mode := <discriminant>;
12409 -- P : parms := (parm, parm, parm);
12412 -- Timed_Protected_Entry_Call
12413 -- (<acceptor-task>, X, P'Address, DX, M, B);
12421 -- 2) When T.E is a protected entry_call;
12425 -- X : Protected_Entry_Index := <entry index>;
12426 -- DX : Duration := To_Duration (D);
12427 -- M : Delay_Mode := <discriminant>;
12428 -- P : parms := (parm, parm, parm);
12431 -- Timed_Protected_Entry_Call
12432 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12440 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12441 -- is no delay and the triggering statements are executed. We first
12442 -- determine the kind of the triggering call and then execute a
12443 -- synchronized operation or a direct call.
12446 -- B : Boolean := False;
12447 -- C : Ada.Tags.Prim_Op_Kind;
12448 -- DX : Duration := To_Duration (D)
12449 -- K : Ada.Tags.Tagged_Kind :=
12450 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12451 -- M : Integer :=...;
12452 -- P : Parameters := (Param1 .. ParamN);
12456 -- if K = Ada.Tags.TK_Limited_Tagged
12457 -- or else K = Ada.Tags.TK_Tagged
12459 -- <dispatching-call>;
12464 -- Ada.Tags.Get_Offset_Index
12465 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12467 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12469 -- if C = POK_Protected_Entry
12470 -- or else C = POK_Task_Entry
12472 -- Param1 := P.Param1;
12474 -- ParamN := P.ParamN;
12478 -- if C = POK_Procedure
12479 -- or else C = POK_Protected_Procedure
12480 -- or else C = POK_Task_Procedure
12482 -- <dispatching-call>;
12488 -- <triggering-statements>
12490 -- <timed-statements>
12494 -- The triggering statement and the sequence of timed statements have not
12495 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12496 -- global references if within an instantiation.
12498 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
12499 Loc
: constant Source_Ptr
:= Sloc
(N
);
12502 Blk_Typ
: Entity_Id
;
12504 Call_Ent
: Entity_Id
;
12505 Conc_Typ_Stmts
: List_Id
;
12507 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
12510 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
12512 D_Type
: Entity_Id
;
12515 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
12516 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
12521 Is_Disp_Select
: Boolean;
12522 Lim_Typ_Stmts
: List_Id
;
12531 B
: Entity_Id
; -- Call status flag
12532 C
: Entity_Id
; -- Call kind
12533 D
: Entity_Id
; -- Delay
12534 K
: Entity_Id
; -- Tagged kind
12535 M
: Entity_Id
; -- Delay mode
12536 P
: Entity_Id
; -- Parameter block
12537 S
: Entity_Id
; -- Primitive operation slot
12539 -- Start of processing for Expand_N_Timed_Entry_Call
12542 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12543 -- was already reported on spec, so do not attempt to expand the call.
12545 if Restriction_Active
(No_Select_Statements
) then
12549 Process_Statements_For_Controlled_Objects
(E_Alt
);
12550 Process_Statements_For_Controlled_Objects
(D_Alt
);
12552 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
12554 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12555 -- may wrap them in blocks.
12557 E_Stats
:= Statements
(E_Alt
);
12558 D_Stats
:= Statements
(D_Alt
);
12560 -- The arguments in the call may require dynamic allocation, and the
12561 -- call statement may have been transformed into a block. The block
12562 -- may contain additional declarations for internal entities, and the
12563 -- original call is found by sequential search.
12565 if Nkind
(E_Call
) = N_Block_Statement
then
12566 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
12567 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
12568 N_Entry_Call_Statement
)
12575 Ada_Version
>= Ada_2005
12576 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
12578 if Is_Disp_Select
then
12579 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
12585 -- B : Boolean := False;
12587 B
:= Build_B
(Loc
, Decls
);
12590 -- C : Ada.Tags.Prim_Op_Kind;
12592 C
:= Build_C
(Loc
, Decls
);
12594 -- Because the analysis of all statements was disabled, manually
12595 -- analyze the delay statement.
12598 D_Stat
:= Original_Node
(D_Stat
);
12601 -- Build an entry call using Simple_Entry_Call
12603 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
12604 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
12606 Decls
:= Declarations
(E_Call
);
12607 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
12616 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12619 Make_Object_Declaration
(Loc
,
12620 Defining_Identifier
=> B
,
12621 Object_Definition
=>
12622 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
12625 -- Duration and mode processing
12627 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12629 -- Use the type of the delay expression (Calendar or Real_Time) to
12630 -- generate the appropriate conversion.
12632 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12633 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12634 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12636 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12637 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12639 Make_Function_Call
(Loc
,
12640 Name
=> New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
12641 Parameter_Associations
=>
12642 New_List
(New_Copy
(Expression
(D_Stat
))));
12644 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12645 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12647 Make_Function_Call
(Loc
,
12648 Name
=> New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
12649 Parameter_Associations
=>
12650 New_List
(New_Copy
(Expression
(D_Stat
))));
12653 D
:= Make_Temporary
(Loc
, 'D');
12659 Make_Object_Declaration
(Loc
,
12660 Defining_Identifier
=> D
,
12661 Object_Definition
=> New_Occurrence_Of
(Standard_Duration
, Loc
)));
12663 M
:= Make_Temporary
(Loc
, 'M');
12666 -- M : Integer := (0 | 1 | 2);
12669 Make_Object_Declaration
(Loc
,
12670 Defining_Identifier
=> M
,
12671 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
12672 Expression
=> D_Disc
));
12674 -- Do the assignment at this stage only because the evaluation of the
12675 -- expression must not occur before (see ACVC C97302A).
12678 Make_Assignment_Statement
(Loc
,
12679 Name
=> New_Occurrence_Of
(D
, Loc
),
12680 Expression
=> D_Conv
));
12682 -- Parameter block processing
12684 -- Manually create the parameter block for dispatching calls. In the
12685 -- case of entries, the block has already been created during the call
12686 -- to Build_Simple_Entry_Call.
12688 if Is_Disp_Select
then
12690 -- Tagged kind processing, generate:
12691 -- K : Ada.Tags.Tagged_Kind :=
12692 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12694 K
:= Build_K
(Loc
, Decls
, Obj
);
12696 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12698 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12700 -- Dispatch table slot processing, generate:
12703 S
:= Build_S
(Loc
, Decls
);
12706 -- S := Ada.Tags.Get_Offset_Index
12707 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12710 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12713 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12715 -- where Obj is the controlling formal parameter, S is the dispatch
12716 -- table slot number of the dispatching operation, P is the wrapped
12717 -- parameter block, D is the duration, M is the duration mode, C is
12718 -- the call kind and B is the call status.
12720 Params
:= New_List
;
12722 Append_To
(Params
, New_Copy_Tree
(Obj
));
12723 Append_To
(Params
, New_Occurrence_Of
(S
, Loc
));
12725 Make_Attribute_Reference
(Loc
,
12726 Prefix
=> New_Occurrence_Of
(P
, Loc
),
12727 Attribute_Name
=> Name_Address
));
12728 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12729 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12730 Append_To
(Params
, New_Occurrence_Of
(C
, Loc
));
12731 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12733 Append_To
(Conc_Typ_Stmts
,
12734 Make_Procedure_Call_Statement
(Loc
,
12738 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12739 Parameter_Associations
=> Params
));
12742 -- if C = POK_Protected_Entry
12743 -- or else C = POK_Task_Entry
12745 -- Param1 := P.Param1;
12747 -- ParamN := P.ParamN;
12750 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12752 -- Generate the if statement only when the packed parameters need
12753 -- explicit assignments to their corresponding actuals.
12755 if Present
(Unpack
) then
12756 Append_To
(Conc_Typ_Stmts
,
12757 Make_Implicit_If_Statement
(N
,
12763 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12766 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12770 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12772 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
12774 Then_Statements
=> Unpack
));
12780 -- if C = POK_Procedure
12781 -- or else C = POK_Protected_Procedure
12782 -- or else C = POK_Task_Procedure
12784 -- <dispatching-call>
12788 N_Stats
:= New_List
(
12789 Make_Implicit_If_Statement
(N
,
12794 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12796 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
12802 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12804 New_Occurrence_Of
(RTE
(
12805 RE_POK_Protected_Procedure
), Loc
)),
12808 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12811 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12813 Then_Statements
=> New_List
(E_Call
)));
12815 Append_To
(Conc_Typ_Stmts
,
12816 Make_Implicit_If_Statement
(N
,
12817 Condition
=> New_Occurrence_Of
(B
, Loc
),
12818 Then_Statements
=> N_Stats
));
12821 -- <dispatching-call>;
12825 New_List
(New_Copy_Tree
(E_Call
),
12826 Make_Assignment_Statement
(Loc
,
12827 Name
=> New_Occurrence_Of
(B
, Loc
),
12828 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12831 -- if K = Ada.Tags.TK_Limited_Tagged
12832 -- or else K = Ada.Tags.TK_Tagged
12840 Make_Implicit_If_Statement
(N
,
12841 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
12842 Then_Statements
=> Lim_Typ_Stmts
,
12843 Else_Statements
=> Conc_Typ_Stmts
));
12848 -- <triggering-statements>
12850 -- <timed-statements>
12854 Make_Implicit_If_Statement
(N
,
12855 Condition
=> New_Occurrence_Of
(B
, Loc
),
12856 Then_Statements
=> E_Stats
,
12857 Else_Statements
=> D_Stats
));
12860 -- Simple case of a nondispatching trigger. Skip assignments to
12861 -- temporaries created for in-out parameters.
12863 -- This makes unwarranted assumptions about the shape of the expanded
12864 -- tree for the call, and should be cleaned up ???
12866 Stmt
:= First
(Stmts
);
12867 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
12871 -- Do the assignment at this stage only because the evaluation
12872 -- of the expression must not occur before (see ACVC C97302A).
12874 Insert_Before
(Stmt
,
12875 Make_Assignment_Statement
(Loc
,
12876 Name
=> New_Occurrence_Of
(D
, Loc
),
12877 Expression
=> D_Conv
));
12880 Params
:= Parameter_Associations
(Call
);
12882 -- For a protected type, we build a Timed_Protected_Entry_Call
12884 if Is_Protected_Type
(Etype
(Concval
)) then
12886 -- Create a new call statement
12888 Param
:= First
(Params
);
12889 while Present
(Param
)
12890 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
12895 Dummy
:= Remove_Next
(Next
(Param
));
12897 -- Remove garbage is following the Cancel_Param if present
12899 Dummy
:= Next
(Param
);
12901 -- Remove the mode of the Protected_Entry_Call call, then remove
12902 -- the Communication_Block of the Protected_Entry_Call call, and
12903 -- finally add Duration and a Delay_Mode parameter
12905 pragma Assert
(Present
(Param
));
12906 Rewrite
(Param
, New_Occurrence_Of
(D
, Loc
));
12908 Rewrite
(Dummy
, New_Occurrence_Of
(M
, Loc
));
12910 -- Add a Boolean flag for successful entry call
12912 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12914 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
12915 when System_Tasking_Protected_Objects_Entries
=>
12917 Make_Procedure_Call_Statement
(Loc
,
12920 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
12921 Parameter_Associations
=> Params
));
12924 raise Program_Error
;
12927 -- For the task case, build a Timed_Task_Entry_Call
12930 -- Create a new call statement
12932 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12933 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12934 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12937 Make_Procedure_Call_Statement
(Loc
,
12939 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
12940 Parameter_Associations
=> Params
));
12944 Make_Implicit_If_Statement
(N
,
12945 Condition
=> New_Occurrence_Of
(B
, Loc
),
12946 Then_Statements
=> E_Stats
,
12947 Else_Statements
=> D_Stats
));
12951 Make_Block_Statement
(Loc
,
12952 Declarations
=> Decls
,
12953 Handled_Statement_Sequence
=>
12954 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
12957 end Expand_N_Timed_Entry_Call
;
12959 ----------------------------------------
12960 -- Expand_Protected_Body_Declarations --
12961 ----------------------------------------
12963 procedure Expand_Protected_Body_Declarations
12965 Spec_Id
: Entity_Id
)
12968 if No_Run_Time_Mode
then
12969 Error_Msg_CRT
("protected body", N
);
12972 elsif Expander_Active
then
12974 -- Associate discriminals with the first subprogram or entry body to
12977 if Present
(First_Protected_Operation
(Declarations
(N
))) then
12978 Set_Discriminals
(Parent
(Spec_Id
));
12981 end Expand_Protected_Body_Declarations
;
12983 -------------------------
12984 -- External_Subprogram --
12985 -------------------------
12987 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
12988 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
12991 -- The internal and external subprograms follow each other on the entity
12992 -- chain. Note that previously private operations had no separate
12993 -- external subprogram. We now create one in all cases, because a
12994 -- private operation may actually appear in an external call, through
12995 -- a 'Access reference used for a callback.
12997 -- If the operation is a function that returns an anonymous access type,
12998 -- the corresponding itype appears before the operation, and must be
13001 -- This mechanism is fragile, there should be a real link between the
13002 -- two versions of the operation, but there is no place to put it ???
13004 if Is_Access_Type
(Next_Entity
(Subp
)) then
13005 return Next_Entity
(Next_Entity
(Subp
));
13007 return Next_Entity
(Subp
);
13009 end External_Subprogram
;
13011 ------------------------------
13012 -- Extract_Dispatching_Call --
13013 ------------------------------
13015 procedure Extract_Dispatching_Call
13017 Call_Ent
: out Entity_Id
;
13018 Object
: out Entity_Id
;
13019 Actuals
: out List_Id
;
13020 Formals
: out List_Id
)
13022 Call_Nam
: Node_Id
;
13025 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
13027 if Present
(Original_Node
(N
)) then
13028 Call_Nam
:= Name
(Original_Node
(N
));
13030 Call_Nam
:= Name
(N
);
13033 -- Retrieve the name of the dispatching procedure. It contains the
13034 -- dispatch table slot number.
13037 case Nkind
(Call_Nam
) is
13038 when N_Identifier
=>
13041 when N_Selected_Component
=>
13042 Call_Nam
:= Selector_Name
(Call_Nam
);
13045 raise Program_Error
;
13050 Actuals
:= Parameter_Associations
(N
);
13051 Call_Ent
:= Entity
(Call_Nam
);
13052 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
13053 Object
:= First
(Actuals
);
13055 if Present
(Original_Node
(Object
)) then
13056 Object
:= Original_Node
(Object
);
13059 -- If the type of the dispatching object is an access type then return
13060 -- an explicit dereference.
13062 if Is_Access_Type
(Etype
(Object
)) then
13063 Object
:= Make_Explicit_Dereference
(Sloc
(N
), Object
);
13066 end Extract_Dispatching_Call
;
13068 -------------------
13069 -- Extract_Entry --
13070 -------------------
13072 procedure Extract_Entry
13074 Concval
: out Node_Id
;
13075 Ename
: out Node_Id
;
13076 Index
: out Node_Id
)
13078 Nam
: constant Node_Id
:= Name
(N
);
13081 -- For a simple entry, the name is a selected component, with the
13082 -- prefix being the task value, and the selector being the entry.
13084 if Nkind
(Nam
) = N_Selected_Component
then
13085 Concval
:= Prefix
(Nam
);
13086 Ename
:= Selector_Name
(Nam
);
13089 -- For a member of an entry family, the name is an indexed component
13090 -- where the prefix is a selected component, whose prefix in turn is
13091 -- the task value, and whose selector is the entry family. The single
13092 -- expression in the expressions list of the indexed component is the
13093 -- subscript for the family.
13095 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
13096 Concval
:= Prefix
(Prefix
(Nam
));
13097 Ename
:= Selector_Name
(Prefix
(Nam
));
13098 Index
:= First
(Expressions
(Nam
));
13101 -- Through indirection, the type may actually be a limited view of a
13102 -- concurrent type. When compiling a call, the non-limited view of the
13103 -- type is visible.
13105 if From_Limited_With
(Etype
(Concval
)) then
13106 Set_Etype
(Concval
, Non_Limited_View
(Etype
(Concval
)));
13110 -------------------
13111 -- Family_Offset --
13112 -------------------
13114 function Family_Offset
13119 Cap
: Boolean) return Node_Id
13125 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
13126 -- If one of the bounds is a reference to a discriminant, replace with
13127 -- corresponding discriminal of type. Within the body of a task retrieve
13128 -- the renamed discriminant by simple visibility, using its generated
13129 -- name. Within a protected object, find the original discriminant and
13130 -- replace it with the discriminal of the current protected operation.
13132 ------------------------------
13133 -- Convert_Discriminant_Ref --
13134 ------------------------------
13136 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
13137 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
13142 if Is_Entity_Name
(Bound
)
13143 and then Ekind
(Entity
(Bound
)) = E_Discriminant
13145 if Is_Task_Type
(Ttyp
) and then Has_Completion
(Ttyp
) then
13146 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13147 Find_Direct_Name
(B
);
13149 elsif Is_Protected_Type
(Ttyp
) then
13150 D
:= First_Discriminant
(Ttyp
);
13151 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
13152 Next_Discriminant
(D
);
13155 B
:= New_Occurrence_Of
(Discriminal
(D
), Loc
);
13158 B
:= New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
13161 elsif Nkind
(Bound
) = N_Attribute_Reference
then
13165 B
:= New_Copy_Tree
(Bound
);
13169 Make_Attribute_Reference
(Loc
,
13170 Attribute_Name
=> Name_Pos
,
13171 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
13172 Expressions
=> New_List
(B
));
13173 end Convert_Discriminant_Ref
;
13175 -- Start of processing for Family_Offset
13178 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
13179 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
13182 if Is_Task_Type
(Ttyp
) then
13183 Ityp
:= RTE
(RE_Task_Entry_Index
);
13185 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13189 Make_Attribute_Reference
(Loc
,
13190 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13191 Attribute_Name
=> Name_Min
,
13192 Expressions
=> New_List
(
13194 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
13197 Make_Attribute_Reference
(Loc
,
13198 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13199 Attribute_Name
=> Name_Max
,
13200 Expressions
=> New_List
(
13202 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
13205 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
13212 function Family_Size
13217 Cap
: Boolean) return Node_Id
13222 if Is_Task_Type
(Ttyp
) then
13223 Ityp
:= RTE
(RE_Task_Entry_Index
);
13225 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13229 Make_Attribute_Reference
(Loc
,
13230 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13231 Attribute_Name
=> Name_Max
,
13232 Expressions
=> New_List
(
13234 Left_Opnd
=> Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
13235 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
13236 Make_Integer_Literal
(Loc
, 0)));
13239 ----------------------------
13240 -- Find_Enclosing_Context --
13241 ----------------------------
13243 procedure Find_Enclosing_Context
13245 Context
: out Node_Id
;
13246 Context_Id
: out Entity_Id
;
13247 Context_Decls
: out List_Id
)
13250 -- Traverse the parent chain looking for an enclosing body, block,
13251 -- package or return statement.
13253 Context
:= Parent
(N
);
13254 while Present
(Context
) loop
13255 if Nkind_In
(Context
, N_Entry_Body
,
13256 N_Extended_Return_Statement
,
13258 N_Package_Declaration
,
13264 -- Do not consider block created to protect a list of statements with
13265 -- an Abort_Defer / Abort_Undefer_Direct pair.
13267 elsif Nkind
(Context
) = N_Block_Statement
13268 and then not Is_Abort_Block
(Context
)
13273 Context
:= Parent
(Context
);
13276 pragma Assert
(Present
(Context
));
13278 -- Extract the constituents of the context
13280 if Nkind
(Context
) = N_Extended_Return_Statement
then
13281 Context_Decls
:= Return_Object_Declarations
(Context
);
13282 Context_Id
:= Return_Statement_Entity
(Context
);
13284 -- Package declarations and bodies use a common library-level activation
13285 -- chain or task master, therefore return the package declaration as the
13286 -- proper carrier for the appropriate flag.
13288 elsif Nkind
(Context
) = N_Package_Body
then
13289 Context_Decls
:= Declarations
(Context
);
13290 Context_Id
:= Corresponding_Spec
(Context
);
13291 Context
:= Parent
(Context_Id
);
13293 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
13294 Context
:= Parent
(Parent
(Context
));
13296 Context
:= Parent
(Context
);
13299 elsif Nkind
(Context
) = N_Package_Declaration
then
13300 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
13301 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13303 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13304 Context_Id
:= Defining_Identifier
(Context_Id
);
13308 if Nkind
(Context
) = N_Block_Statement
then
13309 Context_Id
:= Entity
(Identifier
(Context
));
13311 elsif Nkind
(Context
) = N_Entry_Body
then
13312 Context_Id
:= Defining_Identifier
(Context
);
13314 elsif Nkind
(Context
) = N_Subprogram_Body
then
13315 if Present
(Corresponding_Spec
(Context
)) then
13316 Context_Id
:= Corresponding_Spec
(Context
);
13318 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13320 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13321 Context_Id
:= Defining_Identifier
(Context_Id
);
13325 elsif Nkind
(Context
) = N_Task_Body
then
13326 Context_Id
:= Corresponding_Spec
(Context
);
13329 raise Program_Error
;
13332 Context_Decls
:= Declarations
(Context
);
13335 pragma Assert
(Present
(Context_Id
));
13336 pragma Assert
(Present
(Context_Decls
));
13337 end Find_Enclosing_Context
;
13339 -----------------------
13340 -- Find_Master_Scope --
13341 -----------------------
13343 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
13347 -- In Ada 2005, the master is the innermost enclosing scope that is not
13348 -- transient. If the enclosing block is the rewriting of a call or the
13349 -- scope is an extended return statement this is valid master. The
13350 -- master in an extended return is only used within the return, and is
13351 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13352 -- now before that overwriting occurs.
13356 if Ada_Version
>= Ada_2005
then
13357 while Is_Internal
(S
) loop
13358 if Nkind
(Parent
(S
)) = N_Block_Statement
13360 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
13364 elsif Ekind
(S
) = E_Return_Statement
then
13374 end Find_Master_Scope
;
13376 -------------------------------
13377 -- First_Protected_Operation --
13378 -------------------------------
13380 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
13381 First_Op
: Node_Id
;
13384 First_Op
:= First
(D
);
13385 while Present
(First_Op
)
13386 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
13392 end First_Protected_Operation
;
13394 ---------------------------------------
13395 -- Install_Private_Data_Declarations --
13396 ---------------------------------------
13398 procedure Install_Private_Data_Declarations
13400 Spec_Id
: Entity_Id
;
13401 Conc_Typ
: Entity_Id
;
13402 Body_Nod
: Node_Id
;
13404 Barrier
: Boolean := False;
13405 Family
: Boolean := False)
13407 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
13410 Insert_Node
: Node_Id
:= Empty
;
13411 Obj_Ent
: Entity_Id
;
13413 procedure Add
(Decl
: Node_Id
);
13414 -- Add a single declaration after Insert_Node. If this is the first
13415 -- addition, Decl is added to the front of Decls and it becomes the
13418 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
13419 -- The bounds of an entry index may depend on discriminants, create a
13420 -- reference to the corresponding prival. Otherwise return a duplicate
13421 -- of the original bound.
13427 procedure Add
(Decl
: Node_Id
) is
13429 if No
(Insert_Node
) then
13430 Prepend_To
(Decls
, Decl
);
13432 Insert_After
(Insert_Node
, Decl
);
13435 Insert_Node
:= Decl
;
13438 --------------------------
13439 -- Replace_Discriminant --
13440 --------------------------
13442 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
13444 if Nkind
(Bound
) = N_Identifier
13445 and then Is_Discriminal
(Entity
(Bound
))
13447 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13449 return Duplicate_Subexpr
(Bound
);
13453 -- Start of processing for Install_Private_Data_Declarations
13456 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13457 -- formal parameter _O, _object or _task depending on the context.
13459 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
13461 -- Special processing of _O for barrier functions, protected entries
13468 (Ekind
(Spec_Id
) = E_Entry
13469 or else Ekind
(Spec_Id
) = E_Entry_Family
))
13472 Conc_Rec
: constant Entity_Id
:=
13473 Corresponding_Record_Type
(Conc_Typ
);
13474 Typ_Id
: constant Entity_Id
:=
13475 Make_Defining_Identifier
(Loc
,
13476 New_External_Name
(Chars
(Conc_Rec
), 'P'));
13479 -- type prot_typVP is access prot_typV;
13482 Make_Full_Type_Declaration
(Loc
,
13483 Defining_Identifier
=> Typ_Id
,
13485 Make_Access_To_Object_Definition
(Loc
,
13486 Subtype_Indication
=>
13487 New_Occurrence_Of
(Conc_Rec
, Loc
)));
13491 -- _object : prot_typVP := prot_typV (_O);
13494 Make_Object_Declaration
(Loc
,
13495 Defining_Identifier
=>
13496 Make_Defining_Identifier
(Loc
, Name_uObject
),
13497 Object_Definition
=> New_Occurrence_Of
(Typ_Id
, Loc
),
13499 Unchecked_Convert_To
(Typ_Id
,
13500 New_Occurrence_Of
(Obj_Ent
, Loc
)));
13503 -- Set the reference to the concurrent object
13505 Obj_Ent
:= Defining_Identifier
(Decl
);
13509 -- Step 2: Create the Protection object and build its declaration for
13510 -- any protected entry (family) of subprogram. Note for the lock-free
13511 -- implementation, the Protection object is not needed anymore.
13513 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
13515 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
13519 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
13521 -- Determine the proper protection type
13523 if Has_Attach_Handler
(Conc_Typ
)
13524 and then not Restricted_Profile
13526 Prot_Typ
:= RE_Static_Interrupt_Protection
;
13528 elsif Has_Interrupt_Handler
(Conc_Typ
)
13529 and then not Restriction_Active
(No_Dynamic_Attachment
)
13531 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
13534 case Corresponding_Runtime_Package
(Conc_Typ
) is
13535 when System_Tasking_Protected_Objects_Entries
=>
13536 Prot_Typ
:= RE_Protection_Entries
;
13538 when System_Tasking_Protected_Objects_Single_Entry
=>
13539 Prot_Typ
:= RE_Protection_Entry
;
13541 when System_Tasking_Protected_Objects
=>
13542 Prot_Typ
:= RE_Protection
;
13545 raise Program_Error
;
13550 -- conc_typR : protection_typ renames _object._object;
13553 Make_Object_Renaming_Declaration
(Loc
,
13554 Defining_Identifier
=> Prot_Ent
,
13556 New_Occurrence_Of
(RTE
(Prot_Typ
), Loc
),
13558 Make_Selected_Component
(Loc
,
13559 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13560 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
13565 -- Step 3: Add discriminant renamings (if any)
13567 if Has_Discriminants
(Conc_Typ
) then
13572 D
:= First_Discriminant
(Conc_Typ
);
13573 while Present
(D
) loop
13575 -- Adjust the source location
13577 Set_Sloc
(Discriminal
(D
), Loc
);
13580 -- discr_name : discr_typ renames _object.discr_name;
13582 -- discr_name : discr_typ renames _task.discr_name;
13585 Make_Object_Renaming_Declaration
(Loc
,
13586 Defining_Identifier
=> Discriminal
(D
),
13587 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
13589 Make_Selected_Component
(Loc
,
13590 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13591 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
13594 Next_Discriminant
(D
);
13599 -- Step 4: Add private component renamings (if any)
13601 if Is_Protected
then
13602 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
13604 if Present
(Private_Declarations
(Def
)) then
13607 Comp_Id
: Entity_Id
;
13608 Decl_Id
: Entity_Id
;
13611 Comp
:= First
(Private_Declarations
(Def
));
13612 while Present
(Comp
) loop
13613 if Nkind
(Comp
) = N_Component_Declaration
then
13614 Comp_Id
:= Defining_Identifier
(Comp
);
13616 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
13618 -- Minimal decoration
13620 if Ekind
(Spec_Id
) = E_Function
then
13621 Set_Ekind
(Decl_Id
, E_Constant
);
13623 Set_Ekind
(Decl_Id
, E_Variable
);
13626 Set_Prival
(Comp_Id
, Decl_Id
);
13627 Set_Prival_Link
(Decl_Id
, Comp_Id
);
13628 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13631 -- comp_name : comp_typ renames _object.comp_name;
13634 Make_Object_Renaming_Declaration
(Loc
,
13635 Defining_Identifier
=> Decl_Id
,
13637 New_Occurrence_Of
(Etype
(Comp_Id
), Loc
),
13639 Make_Selected_Component
(Loc
,
13641 New_Occurrence_Of
(Obj_Ent
, Loc
),
13643 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
13653 -- Step 5: Add the declaration of the entry index and the associated
13654 -- type for barrier functions and entry families.
13656 if (Barrier
and Family
) or else Ekind
(Spec_Id
) = E_Entry_Family
then
13658 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13659 Index
: constant Entity_Id
:=
13660 Defining_Identifier
13661 (Entry_Index_Specification
13662 (Entry_Body_Formal_Part
(Body_Nod
)));
13663 Index_Con
: constant Entity_Id
:=
13664 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13666 Index_Typ
: Entity_Id
;
13670 -- Minimal decoration
13672 Set_Ekind
(Index_Con
, E_Constant
);
13673 Set_Entry_Index_Constant
(Index
, Index_Con
);
13674 Set_Discriminal_Link
(Index_Con
, Index
);
13676 -- Retrieve the bounds of the entry family
13678 High
:= Type_High_Bound
(Etype
(Index
));
13679 Low
:= Type_Low_Bound
(Etype
(Index
));
13681 -- In the simple case the entry family is given by a subtype
13682 -- mark and the index constant has the same type.
13684 if Is_Entity_Name
(Original_Node
(
13685 Discrete_Subtype_Definition
(Parent
(Index
))))
13687 Index_Typ
:= Etype
(Index
);
13689 -- Otherwise a new subtype declaration is required
13692 High
:= Replace_Bound
(High
);
13693 Low
:= Replace_Bound
(Low
);
13695 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13698 -- subtype Jnn is <Etype of Index> range Low .. High;
13701 Make_Subtype_Declaration
(Loc
,
13702 Defining_Identifier
=> Index_Typ
,
13703 Subtype_Indication
=>
13704 Make_Subtype_Indication
(Loc
,
13706 New_Occurrence_Of
(Base_Type
(Etype
(Index
)), Loc
),
13708 Make_Range_Constraint
(Loc
,
13709 Range_Expression
=>
13710 Make_Range
(Loc
, Low
, High
))));
13714 Set_Etype
(Index_Con
, Index_Typ
);
13716 -- Create the object which designates the index:
13717 -- J : constant Jnn :=
13718 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13720 -- where Jnn is the subtype created above or the original type of
13721 -- the index, _E is a formal of the protected body subprogram and
13722 -- <index expr> is the index of the first family member.
13725 Make_Object_Declaration
(Loc
,
13726 Defining_Identifier
=> Index_Con
,
13727 Constant_Present
=> True,
13728 Object_Definition
=>
13729 New_Occurrence_Of
(Index_Typ
, Loc
),
13732 Make_Attribute_Reference
(Loc
,
13734 New_Occurrence_Of
(Index_Typ
, Loc
),
13735 Attribute_Name
=> Name_Val
,
13737 Expressions
=> New_List
(
13741 Make_Op_Subtract
(Loc
,
13742 Left_Opnd
=> New_Occurrence_Of
(E
, Loc
),
13744 Entry_Index_Expression
(Loc
,
13745 Defining_Identifier
(Body_Nod
),
13749 Make_Attribute_Reference
(Loc
,
13751 New_Occurrence_Of
(Index_Typ
, Loc
),
13752 Attribute_Name
=> Name_Pos
,
13753 Expressions
=> New_List
(
13754 Make_Attribute_Reference
(Loc
,
13756 New_Occurrence_Of
(Index_Typ
, Loc
),
13757 Attribute_Name
=> Name_First
)))))));
13761 end Install_Private_Data_Declarations
;
13763 -----------------------
13764 -- Is_Exception_Safe --
13765 -----------------------
13767 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean is
13769 function Has_Side_Effect
(N
: Node_Id
) return Boolean;
13770 -- Return True whenever encountering a subprogram call or raise
13771 -- statement of any kind in the sequence of statements
13773 ---------------------
13774 -- Has_Side_Effect --
13775 ---------------------
13777 -- What is this doing buried two levels down in exp_ch9. It seems like a
13778 -- generally useful function, and indeed there may be code duplication
13779 -- going on here ???
13781 function Has_Side_Effect
(N
: Node_Id
) return Boolean is
13785 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean;
13786 -- Indicate whether N is a subprogram call or a raise statement
13788 ----------------------
13789 -- Is_Call_Or_Raise --
13790 ----------------------
13792 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean is
13794 return Nkind_In
(N
, N_Procedure_Call_Statement
,
13797 N_Raise_Constraint_Error
,
13798 N_Raise_Program_Error
,
13799 N_Raise_Storage_Error
);
13800 end Is_Call_Or_Raise
;
13802 -- Start of processing for Has_Side_Effect
13806 while Present
(Stmt
) loop
13807 if Is_Call_Or_Raise
(Stmt
) then
13811 -- An object declaration can also contain a function call or a
13812 -- raise statement.
13814 if Nkind
(Stmt
) = N_Object_Declaration
then
13815 Expr
:= Expression
(Stmt
);
13817 if Present
(Expr
) and then Is_Call_Or_Raise
(Expr
) then
13826 end Has_Side_Effect
;
13828 -- Start of processing for Is_Exception_Safe
13831 -- When exceptions can't be propagated, the subprogram returns normally
13833 if No_Exception_Handlers_Set
then
13837 -- If the checks handled by the back end are not disabled, we cannot
13838 -- ensure that no exception will be raised.
13840 if not Access_Checks_Suppressed
(Empty
)
13841 or else not Discriminant_Checks_Suppressed
(Empty
)
13842 or else not Range_Checks_Suppressed
(Empty
)
13843 or else not Index_Checks_Suppressed
(Empty
)
13844 or else Opt
.Stack_Checking_Enabled
13849 if Has_Side_Effect
(First
(Declarations
(Subprogram
)))
13852 (First
(Statements
(Handled_Statement_Sequence
(Subprogram
))))
13858 end Is_Exception_Safe
;
13860 ---------------------------------
13861 -- Is_Potentially_Large_Family --
13862 ---------------------------------
13864 function Is_Potentially_Large_Family
13865 (Base_Index
: Entity_Id
;
13866 Conctyp
: Entity_Id
;
13868 Hi
: Node_Id
) return Boolean
13871 return Scope
(Base_Index
) = Standard_Standard
13872 and then Base_Index
= Base_Type
(Standard_Integer
)
13873 and then Has_Discriminants
(Conctyp
)
13875 Present
(Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
13877 (Denotes_Discriminant
(Lo
, True)
13879 Denotes_Discriminant
(Hi
, True));
13880 end Is_Potentially_Large_Family
;
13882 -------------------------------------
13883 -- Is_Private_Primitive_Subprogram --
13884 -------------------------------------
13886 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13889 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13890 and then Is_Private_Primitive
(Id
);
13891 end Is_Private_Primitive_Subprogram
;
13897 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13898 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13899 Formal
: Entity_Id
;
13902 Formal
:= First_Formal
(Bod_Subp
);
13903 while Present
(Formal
) loop
13905 -- Look for formal parameter _E
13907 if Chars
(Formal
) = Name_uE
then
13911 Next_Formal
(Formal
);
13914 -- A protected body subprogram should always have the parameter in
13917 raise Program_Error
;
13920 --------------------------------
13921 -- Make_Initialize_Protection --
13922 --------------------------------
13924 function Make_Initialize_Protection
13925 (Protect_Rec
: Entity_Id
) return List_Id
13927 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
13930 Ptyp
: constant Node_Id
:=
13931 Corresponding_Concurrent_Type
(Protect_Rec
);
13933 L
: constant List_Id
:= New_List
;
13934 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
13935 Prio_Type
: Entity_Id
;
13936 Prio_Var
: Entity_Id
:= Empty
;
13937 Restricted
: constant Boolean := Restricted_Profile
;
13940 -- We may need two calls to properly initialize the object, one to
13941 -- Initialize_Protection, and possibly one to Install_Handlers if we
13942 -- have a pragma Attach_Handler.
13944 -- Get protected declaration. In the case of a task type declaration,
13945 -- this is simply the parent of the protected type entity. In the single
13946 -- protected object declaration, this parent will be the implicit type,
13947 -- and we can find the corresponding single protected object declaration
13948 -- by searching forward in the declaration list in the tree.
13950 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13951 -- of this type should have been removed during semantic analysis.
13953 Pdec
:= Parent
(Ptyp
);
13954 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
13955 N_Single_Protected_Declaration
)
13960 -- Build the parameter list for the call. Note that _Init is the name
13961 -- of the formal for the object to be initialized, which is the task
13962 -- value record itself.
13966 -- For lock-free implementation, skip initializations of the Protection
13969 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13971 -- Object parameter. This is a pointer to the object of type
13972 -- Protection used by the GNARL to control the protected object.
13975 Make_Attribute_Reference
(Loc
,
13977 Make_Selected_Component
(Loc
,
13978 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13979 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
13980 Attribute_Name
=> Name_Unchecked_Access
));
13982 -- Priority parameter. Set to Unspecified_Priority unless there is a
13983 -- Priority rep item, in which case we take the value from the pragma
13984 -- or attribute definition clause, or there is an Interrupt_Priority
13985 -- rep item and no Priority rep item, and we set the ceiling to
13986 -- Interrupt_Priority'Last, an implementation-defined value, see
13989 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
13991 Prio_Clause
: constant Node_Id
:=
13993 (Ptyp
, Name_Priority
, Check_Parents
=> False);
14000 if Nkind
(Prio_Clause
) = N_Pragma
then
14003 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
14005 -- Get_Rep_Item returns either priority pragma.
14007 if Pragma_Name
(Prio_Clause
) = Name_Priority
then
14008 Prio_Type
:= RTE
(RE_Any_Priority
);
14010 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
14013 -- Attribute definition clause Priority
14016 if Chars
(Prio_Clause
) = Name_Priority
then
14017 Prio_Type
:= RTE
(RE_Any_Priority
);
14019 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
14022 Prio
:= Expression
(Prio_Clause
);
14025 -- Always create a locale variable to capture the priority.
14026 -- The priority is also passed to Install_Restriced_Handlers.
14027 -- Note that it is really necessary to create this variable
14028 -- explicitly. It might be thought that removing side effects
14029 -- would the appropriate approach, but that could generate
14030 -- declarations improperly placed in the enclosing scope.
14032 Prio_Var
:= Make_Temporary
(Loc
, 'R', Prio
);
14034 Make_Object_Declaration
(Loc
,
14035 Defining_Identifier
=> Prio_Var
,
14036 Object_Definition
=> New_Occurrence_Of
(Prio_Type
, Loc
),
14037 Expression
=> Relocate_Node
(Prio
)));
14039 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14042 -- When no priority is specified but an xx_Handler pragma is, we
14043 -- default to System.Interrupts.Default_Interrupt_Priority, see
14046 elsif Has_Attach_Handler
(Ptyp
)
14047 or else Has_Interrupt_Handler
(Ptyp
)
14050 New_Occurrence_Of
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
14052 -- Normal case, no priority or xx_Handler specified, default priority
14056 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14059 -- Test for Compiler_Info parameter. This parameter allows entry body
14060 -- procedures and barrier functions to be called from the runtime. It
14061 -- is a pointer to the record generated by the compiler to represent
14062 -- the protected object.
14064 -- A protected type without entries that covers an interface and
14065 -- overrides the abstract routines with protected procedures is
14066 -- considered equivalent to a protected type with entries in the
14067 -- context of dispatching select statements.
14069 -- Protected types with interrupt handlers (when not using a
14070 -- restricted profile) are also considered equivalent to protected
14071 -- types with entries.
14073 -- The types which are used (Static_Interrupt_Protection and
14074 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14077 Pkg_Id
: constant RTU_Id
:= Corresponding_Runtime_Package
(Ptyp
);
14079 Called_Subp
: RE_Id
;
14083 when System_Tasking_Protected_Objects_Entries
=>
14084 Called_Subp
:= RE_Initialize_Protection_Entries
;
14086 -- Argument Compiler_Info
14089 Make_Attribute_Reference
(Loc
,
14090 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14091 Attribute_Name
=> Name_Address
));
14093 when System_Tasking_Protected_Objects_Single_Entry
=>
14094 Called_Subp
:= RE_Initialize_Protection_Entry
;
14096 -- Argument Compiler_Info
14099 Make_Attribute_Reference
(Loc
,
14100 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14101 Attribute_Name
=> Name_Address
));
14103 when System_Tasking_Protected_Objects
=>
14104 Called_Subp
:= RE_Initialize_Protection
;
14107 raise Program_Error
;
14110 -- Entry_Bodies parameter. This is a pointer to an array of
14111 -- pointers to the entry body procedures and barrier functions of
14112 -- the object. If the protected type has no entries this object
14113 -- will not exist, in this case, pass a null (it can happen when
14114 -- there are protected interrupt handlers or interfaces).
14117 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
14119 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14120 -- multiple entries).
14123 Make_Attribute_Reference
(Loc
,
14124 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14125 Attribute_Name
=> Name_Unrestricted_Access
));
14127 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14129 -- Find index mapping function (clumsy but ok for now)
14131 while Ekind
(P_Arr
) /= E_Function
loop
14132 Next_Entity
(P_Arr
);
14136 Make_Attribute_Reference
(Loc
,
14137 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14138 Attribute_Name
=> Name_Unrestricted_Access
));
14141 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
14143 -- This is the case where we have a protected object with
14144 -- interfaces and no entries, and the single entry restriction
14145 -- is in effect. We pass a null pointer for the entry
14146 -- parameter because there is no actual entry.
14148 Append_To
(Args
, Make_Null
(Loc
));
14150 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14152 -- This is the case where we have a protected object with no
14154 -- - either interrupt handlers with non restricted profile,
14156 -- Note that the types which are used for interrupt handlers
14157 -- (Static/Dynamic_Interrupt_Protection) are derived from
14158 -- Protection_Entries. We pass two null pointers because there
14159 -- is no actual entry, and the initialization procedure needs
14160 -- both Entry_Bodies and Find_Body_Index.
14162 Append_To
(Args
, Make_Null
(Loc
));
14163 Append_To
(Args
, Make_Null
(Loc
));
14167 Make_Procedure_Call_Statement
(Loc
,
14169 New_Occurrence_Of
(RTE
(Called_Subp
), Loc
),
14170 Parameter_Associations
=> Args
));
14174 if Has_Attach_Handler
(Ptyp
) then
14176 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14177 -- make the following call:
14179 -- Install_Handlers (_object,
14180 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14182 -- or, in the case of Ravenscar:
14184 -- Install_Restricted_Handlers
14185 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14188 Args
: constant List_Id
:= New_List
;
14189 Table
: constant List_Id
:= New_List
;
14190 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
14193 -- Build the Priority parameter (only for ravenscar)
14197 -- Priority comes from a pragma
14199 if Present
(Prio_Var
) then
14200 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14202 -- Priority is the default one
14207 (RTE
(RE_Default_Interrupt_Priority
), Loc
));
14211 -- Build the Attach_Handler table argument
14213 while Present
(Ritem
) loop
14214 if Nkind
(Ritem
) = N_Pragma
14215 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
14218 Handler
: constant Node_Id
:=
14219 First
(Pragma_Argument_Associations
(Ritem
));
14221 Interrupt
: constant Node_Id
:= Next
(Handler
);
14222 Expr
: constant Node_Id
:= Expression
(Interrupt
);
14226 Make_Aggregate
(Loc
, Expressions
=> New_List
(
14227 Unchecked_Convert_To
14228 (RTE
(RE_System_Interrupt_Id
), Expr
),
14229 Make_Attribute_Reference
(Loc
,
14231 Make_Selected_Component
(Loc
,
14233 Make_Identifier
(Loc
, Name_uInit
),
14235 Duplicate_Subexpr_No_Checks
14236 (Expression
(Handler
))),
14237 Attribute_Name
=> Name_Access
))));
14241 Next_Rep_Item
(Ritem
);
14244 -- Append the table argument we just built
14246 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
14248 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14249 -- call to the statements.
14252 -- Call a simplified version of Install_Handlers to be used
14253 -- when the Ravenscar restrictions are in effect
14254 -- (Install_Restricted_Handlers).
14257 Make_Procedure_Call_Statement
(Loc
,
14260 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
14261 Parameter_Associations
=> Args
));
14264 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14266 -- First, prepends the _object argument
14269 Make_Attribute_Reference
(Loc
,
14271 Make_Selected_Component
(Loc
,
14272 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14274 Make_Identifier
(Loc
, Name_uObject
)),
14275 Attribute_Name
=> Name_Unchecked_Access
));
14278 -- Then, insert call to Install_Handlers
14281 Make_Procedure_Call_Statement
(Loc
,
14283 New_Occurrence_Of
(RTE
(RE_Install_Handlers
), Loc
),
14284 Parameter_Associations
=> Args
));
14290 end Make_Initialize_Protection
;
14292 ---------------------------
14293 -- Make_Task_Create_Call --
14294 ---------------------------
14296 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
14297 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
14307 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
14308 Tnam
:= Chars
(Ttyp
);
14310 -- Get task declaration. In the case of a task type declaration, this is
14311 -- simply the parent of the task type entity. In the single task
14312 -- declaration, this parent will be the implicit type, and we can find
14313 -- the corresponding single task declaration by searching forward in the
14314 -- declaration list in the tree.
14316 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14317 -- this type should have been removed during semantic analysis.
14319 Tdec
:= Parent
(Ttyp
);
14320 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
14321 N_Single_Task_Declaration
)
14326 -- Now we can find the task definition from this declaration
14328 Tdef
:= Task_Definition
(Tdec
);
14330 -- Build the parameter list for the call. Note that _Init is the name
14331 -- of the formal for the object to be initialized, which is the task
14332 -- value record itself.
14336 -- Priority parameter. Set to Unspecified_Priority unless there is a
14337 -- Priority rep item, in which case we take the value from the rep item.
14339 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
14341 Make_Selected_Component
(Loc
,
14342 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14343 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
14346 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14349 -- Optional Stack parameter
14351 if Restricted_Profile
then
14353 -- If the stack has been preallocated by the expander then
14354 -- pass its address. Otherwise, pass a null address.
14356 if Preallocated_Stacks_On_Target
then
14358 Make_Attribute_Reference
(Loc
,
14360 Make_Selected_Component
(Loc
,
14361 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14362 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
14363 Attribute_Name
=> Name_Address
));
14367 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
14371 -- Size parameter. If no Storage_Size pragma is present, then
14372 -- the size is taken from the taskZ variable for the type, which
14373 -- is either Unspecified_Size, or has been reset by the use of
14374 -- a Storage_Size attribute definition clause. If a pragma is
14375 -- present, then the size is taken from the _Size field of the
14376 -- task value record, which was set from the pragma value.
14378 if Present
(Tdef
) and then Has_Storage_Size_Pragma
(Tdef
) then
14380 Make_Selected_Component
(Loc
,
14381 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14382 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
14386 New_Occurrence_Of
(Storage_Size_Variable
(Ttyp
), Loc
));
14389 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14390 -- Task_Info pragma, in which case we take the value from the pragma.
14392 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
14394 Make_Selected_Component
(Loc
,
14395 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14396 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
14400 New_Occurrence_Of
(RTE
(RE_Unspecified_Task_Info
), Loc
));
14403 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14404 -- in which case we take the value from the rep item. The parameter is
14405 -- passed as an Integer because in the case of unspecified CPU the
14406 -- value is not in the range of CPU_Range.
14408 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
14410 Convert_To
(Standard_Integer
,
14411 Make_Selected_Component
(Loc
,
14412 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14413 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
14416 New_Occurrence_Of
(RTE
(RE_Unspecified_CPU
), Loc
));
14419 if not Restricted_Profile
then
14421 -- Deadline parameter. If no Relative_Deadline pragma is present,
14422 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14423 -- the deadline is taken from the _Relative_Deadline field of the
14424 -- task value record, which was set from the pragma value. Note that
14425 -- this parameter must not be generated for the restricted profiles
14426 -- since Ravenscar does not allow deadlines.
14428 -- Case where pragma Relative_Deadline applies: use given value
14430 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
14432 Make_Selected_Component
(Loc
,
14433 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14435 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
14437 -- No pragma Relative_Deadline apply to the task
14441 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14444 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14445 -- present, then the dispatching domain is null. If a rep item is
14446 -- present, then the dispatching domain is taken from the
14447 -- _Dispatching_Domain field of the task value record, which was set
14448 -- from the rep item value.
14450 -- Case where Dispatching_Domain rep item applies: use given value
14453 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
14456 Make_Selected_Component
(Loc
,
14458 Make_Identifier
(Loc
, Name_uInit
),
14460 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
14462 -- No pragma or aspect Dispatching_Domain applies to the task
14465 Append_To
(Args
, Make_Null
(Loc
));
14468 -- Number of entries. This is an expression of the form:
14470 -- n + _Init.a'Length + _Init.a'B'Length + ...
14472 -- where a,b... are the entry family names for the task definition
14475 Build_Entry_Count_Expression
14480 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
14482 Append_To
(Args
, Ecount
);
14484 -- Master parameter. This is a reference to the _Master parameter of
14485 -- the initialization procedure, except in the case of the pragma
14486 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14487 -- System.Tasking.Library_Task_Level.
14489 if Restriction_Active
(No_Task_Hierarchy
) = False then
14490 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
14493 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
14497 -- State parameter. This is a pointer to the task body procedure. The
14498 -- required value is obtained by taking 'Unrestricted_Access of the task
14499 -- body procedure and converting it (with an unchecked conversion) to
14500 -- the type required by the task kernel. For further details, see the
14501 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14502 -- than 'Address in order to avoid creating trampolines.
14505 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
14506 Subp_Ptr_Typ
: constant Node_Id
:=
14507 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
14508 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
14511 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
14512 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
14514 -- Be sure to freeze a reference to the access-to-subprogram type,
14515 -- otherwise gigi will complain that it's in the wrong scope, because
14516 -- it's actually inside the init procedure for the record type that
14517 -- corresponds to the task type.
14519 Set_Itype
(Ref
, Subp_Ptr_Typ
);
14520 Append_Freeze_Action
(Task_Rec
, Ref
);
14523 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
14524 Make_Qualified_Expression
(Loc
,
14525 Subtype_Mark
=> New_Occurrence_Of
(Subp_Ptr_Typ
, Loc
),
14527 Make_Attribute_Reference
(Loc
,
14528 Prefix
=> New_Occurrence_Of
(Body_Proc
, Loc
),
14529 Attribute_Name
=> Name_Unrestricted_Access
))));
14532 -- Discriminants parameter. This is just the address of the task
14533 -- value record itself (which contains the discriminant values
14536 Make_Attribute_Reference
(Loc
,
14537 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14538 Attribute_Name
=> Name_Address
));
14540 -- Elaborated parameter. This is an access to the elaboration Boolean
14543 Make_Attribute_Reference
(Loc
,
14544 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
14545 Attribute_Name
=> Name_Unchecked_Access
));
14547 -- Add Chain parameter (not done for sequential elaboration policy, see
14548 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14550 if Partition_Elaboration_Policy
/= 'S' then
14551 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
14554 -- Task name parameter. Take this from the _Task_Id parameter to the
14555 -- init call unless there is a Task_Name pragma, in which case we take
14556 -- the value from the pragma.
14558 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
14559 -- Copy expression in full, because it may be dynamic and have
14566 (Pragma_Argument_Associations
14568 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
14571 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
14574 -- Created_Task parameter. This is the _Task_Id field of the task
14578 Make_Selected_Component
(Loc
,
14579 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14580 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
14586 if Restricted_Profile
then
14587 if Partition_Elaboration_Policy
= 'S' then
14588 Create_RE
:= RE_Create_Restricted_Task_Sequential
;
14590 Create_RE
:= RE_Create_Restricted_Task
;
14593 Create_RE
:= RE_Create_Task
;
14596 Name
:= New_Occurrence_Of
(RTE
(Create_RE
), Loc
);
14600 Make_Procedure_Call_Statement
(Loc
,
14602 Parameter_Associations
=> Args
);
14603 end Make_Task_Create_Call
;
14605 ------------------------------
14606 -- Next_Protected_Operation --
14607 ------------------------------
14609 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
14613 -- Check whether there is a subsequent body for a protected operation
14614 -- in the current protected body. In Ada2012 that includes expression
14615 -- functions that are completions.
14617 Next_Op
:= Next
(N
);
14618 while Present
(Next_Op
)
14619 and then not Nkind_In
(Next_Op
,
14620 N_Subprogram_Body
, N_Entry_Body
, N_Expression_Function
)
14626 end Next_Protected_Operation
;
14628 ---------------------
14629 -- Null_Statements --
14630 ---------------------
14632 function Null_Statements
(Stats
: List_Id
) return Boolean is
14636 Stmt
:= First
(Stats
);
14637 while Nkind
(Stmt
) /= N_Empty
14638 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
14640 (Nkind
(Stmt
) = N_Pragma
14642 Nam_In
(Pragma_Name
(Stmt
), Name_Unreferenced
,
14649 return Nkind
(Stmt
) = N_Empty
;
14650 end Null_Statements
;
14652 --------------------------
14653 -- Parameter_Block_Pack --
14654 --------------------------
14656 function Parameter_Block_Pack
14658 Blk_Typ
: Entity_Id
;
14662 Stmts
: List_Id
) return Node_Id
14664 Actual
: Entity_Id
;
14665 Expr
: Node_Id
:= Empty
;
14666 Formal
: Entity_Id
;
14667 Has_Param
: Boolean := False;
14670 Temp_Asn
: Node_Id
;
14671 Temp_Nam
: Node_Id
;
14674 Actual
:= First
(Actuals
);
14675 Formal
:= Defining_Identifier
(First
(Formals
));
14676 Params
:= New_List
;
14677 while Present
(Actual
) loop
14678 if Is_By_Copy_Type
(Etype
(Actual
)) then
14680 -- Jnn : aliased <formal-type>
14682 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14685 Make_Object_Declaration
(Loc
,
14686 Aliased_Present
=> True,
14687 Defining_Identifier
=> Temp_Nam
,
14688 Object_Definition
=>
14689 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
14691 if Ekind
(Formal
) /= E_Out_Parameter
then
14697 New_Occurrence_Of
(Temp_Nam
, Loc
);
14699 Set_Assignment_OK
(Temp_Asn
);
14702 Make_Assignment_Statement
(Loc
,
14704 Expression
=> New_Copy_Tree
(Actual
)));
14708 -- Jnn'unchecked_access
14711 Make_Attribute_Reference
(Loc
,
14712 Attribute_Name
=> Name_Unchecked_Access
,
14713 Prefix
=> New_Occurrence_Of
(Temp_Nam
, Loc
)));
14717 -- The controlling parameter is omitted
14720 if not Is_Controlling_Actual
(Actual
) then
14722 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14728 Next_Actual
(Actual
);
14729 Next_Formal_With_Extras
(Formal
);
14733 Expr
:= Make_Aggregate
(Loc
, Params
);
14738 -- J1'unchecked_access;
14739 -- <actual2>'reference;
14742 P
:= Make_Temporary
(Loc
, 'P');
14745 Make_Object_Declaration
(Loc
,
14746 Defining_Identifier
=> P
,
14747 Object_Definition
=> New_Occurrence_Of
(Blk_Typ
, Loc
),
14748 Expression
=> Expr
));
14751 end Parameter_Block_Pack
;
14753 ----------------------------
14754 -- Parameter_Block_Unpack --
14755 ----------------------------
14757 function Parameter_Block_Unpack
14761 Formals
: List_Id
) return List_Id
14763 Actual
: Entity_Id
;
14765 Formal
: Entity_Id
;
14766 Has_Asnmt
: Boolean := False;
14767 Result
: constant List_Id
:= New_List
;
14770 Actual
:= First
(Actuals
);
14771 Formal
:= Defining_Identifier
(First
(Formals
));
14772 while Present
(Actual
) loop
14773 if Is_By_Copy_Type
(Etype
(Actual
))
14774 and then Ekind
(Formal
) /= E_In_Parameter
14777 -- <actual> := P.<formal>;
14780 Make_Assignment_Statement
(Loc
,
14784 Make_Explicit_Dereference
(Loc
,
14785 Make_Selected_Component
(Loc
,
14787 New_Occurrence_Of
(P
, Loc
),
14789 Make_Identifier
(Loc
, Chars
(Formal
)))));
14791 Set_Assignment_OK
(Name
(Asnmt
));
14792 Append_To
(Result
, Asnmt
);
14797 Next_Actual
(Actual
);
14798 Next_Formal_With_Extras
(Formal
);
14804 return New_List
(Make_Null_Statement
(Loc
));
14806 end Parameter_Block_Unpack
;
14808 ----------------------
14809 -- Set_Discriminals --
14810 ----------------------
14812 procedure Set_Discriminals
(Dec
: Node_Id
) is
14815 D_Minal
: Entity_Id
;
14818 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
14819 Pdef
:= Defining_Identifier
(Dec
);
14821 if Has_Discriminants
(Pdef
) then
14822 D
:= First_Discriminant
(Pdef
);
14823 while Present
(D
) loop
14825 Make_Defining_Identifier
(Sloc
(D
),
14826 Chars
=> New_External_Name
(Chars
(D
), 'D'));
14828 Set_Ekind
(D_Minal
, E_Constant
);
14829 Set_Etype
(D_Minal
, Etype
(D
));
14830 Set_Scope
(D_Minal
, Pdef
);
14831 Set_Discriminal
(D
, D_Minal
);
14832 Set_Discriminal_Link
(D_Minal
, D
);
14834 Next_Discriminant
(D
);
14837 end Set_Discriminals
;
14839 -----------------------
14840 -- Trivial_Accept_OK --
14841 -----------------------
14843 function Trivial_Accept_OK
return Boolean is
14845 case Opt
.Task_Dispatching_Policy
is
14847 -- If we have the default task dispatching policy in effect, we can
14848 -- definitely do the optimization (one way of looking at this is to
14849 -- think of the formal definition of the default policy being allowed
14850 -- to run any task it likes after a rendezvous, so even if notionally
14851 -- a full rescheduling occurs, we can say that our dispatching policy
14852 -- (i.e. the default dispatching policy) reorders the queue to be the
14853 -- same as just before the call.
14858 -- FIFO_Within_Priorities certainly does not permit this
14859 -- optimization since the Rendezvous is a scheduling action that may
14860 -- require some other task to be run.
14865 -- For now, disallow the optimization for all other policies. This
14866 -- may be over-conservative, but it is certainly not incorrect.
14872 end Trivial_Accept_OK
;