1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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 Int
:= 2**16;
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Actual_Index_Expression
87 Tsk
: Entity_Id
) return Node_Id
;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
92 procedure Add_Object_Pointer
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
101 procedure Add_Formal_Renamings
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
113 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
118 function Build_Barrier_Function
121 Pid
: Node_Id
) return Node_Id
;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
125 function Build_Barrier_Function_Specification
127 Def_Id
: Entity_Id
) return Node_Id
;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
131 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_Id
: Entity_Id
;
1110 Master_Scope
: Entity_Id
;
1112 Related_Node
: Node_Id
;
1116 -- Nothing to do if there is no task hierarchy
1118 if Restriction_Active
(No_Task_Hierarchy
) then
1122 -- Find the declaration that created the access type, which is either a
1123 -- type declaration, or an object declaration with an access definition,
1124 -- in which case the type is anonymous.
1126 if Is_Itype
(Typ
) then
1127 Related_Node
:= Associated_Node_For_Itype
(Typ
);
1129 Related_Node
:= Parent
(Typ
);
1132 Master_Scope
:= Find_Master_Scope
(Typ
);
1134 -- Nothing to do if the master scope already contains a _master entity.
1135 -- The only exception to this is the following scenario:
1138 -- Transient_Scope_1
1141 -- Transient_Scope_2
1144 -- In this case the source scope is marked as having the master entity
1145 -- even though the actual declaration appears inside an inner scope. If
1146 -- the second transient scope requires a _master, it cannot use the one
1147 -- already declared because the entity is not visible.
1149 Name_Id
:= Make_Identifier
(Loc
, Name_uMaster
);
1151 if not Has_Master_Entity
(Master_Scope
)
1152 or else No
(Current_Entity_In_Scope
(Name_Id
))
1155 Master_Decl
: Node_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 Insert_Action
(Related_Node
, Ren_Decl
);
1219 Set_Master_Id
(Typ
, Master_Id
);
1220 end Build_Class_Wide_Master
;
1222 ----------------------------
1223 -- Build_Contract_Wrapper --
1224 ----------------------------
1226 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1227 Conc_Typ
: constant Entity_Id
:= Scope
(E
);
1228 Loc
: constant Source_Ptr
:= Sloc
(E
);
1230 procedure Add_Discriminant_Renamings
1231 (Obj_Id
: Entity_Id
;
1233 -- Add renaming declarations for all discriminants of concurrent type
1234 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1235 -- represents the concurrent object.
1237 procedure Add_Matching_Formals
1239 Actuals
: in out List_Id
);
1240 -- Add formal parameters that match those of entry E to list Formals.
1241 -- The routine also adds matching actuals for the new formals to list
1244 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
);
1245 -- Relocate pragma Prag to list To. The routine creates a new list if
1246 -- To does not exist.
1248 --------------------------------
1249 -- Add_Discriminant_Renamings --
1250 --------------------------------
1252 procedure Add_Discriminant_Renamings
1253 (Obj_Id
: Entity_Id
;
1259 -- Inspect the discriminants of the concurrent type and generate a
1260 -- renaming for each one.
1262 if Has_Discriminants
(Conc_Typ
) then
1263 Discr
:= First_Discriminant
(Conc_Typ
);
1264 while Present
(Discr
) loop
1266 Make_Object_Renaming_Declaration
(Loc
,
1267 Defining_Identifier
=>
1268 Make_Defining_Identifier
(Loc
, Chars
(Discr
)),
1270 New_Occurrence_Of
(Etype
(Discr
), Loc
),
1272 Make_Selected_Component
(Loc
,
1273 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1275 Make_Identifier
(Loc
, Chars
(Discr
)))));
1277 Next_Discriminant
(Discr
);
1280 end Add_Discriminant_Renamings
;
1282 --------------------------
1283 -- Add_Matching_Formals --
1284 --------------------------
1286 procedure Add_Matching_Formals
1288 Actuals
: in out List_Id
)
1291 New_Formal
: Entity_Id
;
1294 -- Inspect the formal parameters of the entry and generate a new
1295 -- matching formal with the same name for the wrapper. A reference
1296 -- to the new formal becomes an actual in the entry call.
1298 Formal
:= First_Formal
(E
);
1299 while Present
(Formal
) loop
1300 New_Formal
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1302 Make_Parameter_Specification
(Loc
,
1303 Defining_Identifier
=> New_Formal
,
1304 In_Present
=> In_Present
(Parent
(Formal
)),
1305 Out_Present
=> Out_Present
(Parent
(Formal
)),
1307 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
1309 if No
(Actuals
) then
1310 Actuals
:= New_List
;
1313 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
1314 Next_Formal
(Formal
);
1316 end Add_Matching_Formals
;
1318 ---------------------
1319 -- Transfer_Pragma --
1320 ---------------------
1322 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
) is
1330 New_Prag
:= Relocate_Node
(Prag
);
1332 Set_Analyzed
(New_Prag
, False);
1333 Append
(New_Prag
, To
);
1334 end Transfer_Pragma
;
1338 Items
: constant Node_Id
:= Contract
(E
);
1339 Actuals
: List_Id
:= No_List
;
1342 Decls
: List_Id
:= No_List
;
1344 Has_Pragma
: Boolean := False;
1345 Index_Id
: Entity_Id
;
1348 Wrapper_Id
: Entity_Id
;
1350 -- Start of processing for Build_Contract_Wrapper
1353 -- This routine generates a specialized wrapper for a protected or task
1354 -- entry [family] which implements precondition/postcondition semantics.
1355 -- Preconditions and case guards of contract cases are checked before
1356 -- the protected action or rendezvous takes place. Postconditions and
1357 -- consequences of contract cases are checked after the protected action
1358 -- or rendezvous takes place. The structure of the generated wrapper is
1361 -- procedure Wrapper
1362 -- (Obj_Id : Conc_Typ; -- concurrent object
1363 -- [Index : Index_Typ;] -- index of entry family
1364 -- [Formal_1 : ...; -- parameters of original entry
1367 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1368 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1370 -- <precondition checks>
1371 -- <case guard checks>
1373 -- procedure _Postconditions is
1375 -- <postcondition checks>
1376 -- <consequence checks>
1377 -- end _Postconditions;
1380 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1384 -- Create the wrapper only when the entry has at least one executable
1385 -- contract item such as contract cases, precondition or postcondition.
1387 if Present
(Items
) then
1389 -- Inspect the list of pre/postconditions and transfer all available
1390 -- pragmas to the declarative list of the wrapper.
1392 Prag
:= Pre_Post_Conditions
(Items
);
1393 while Present
(Prag
) loop
1394 if Nam_In
(Pragma_Name
(Prag
), Name_Postcondition
,
1396 and then Is_Checked
(Prag
)
1399 Transfer_Pragma
(Prag
, To
=> Decls
);
1402 Prag
:= Next_Pragma
(Prag
);
1405 -- Inspect the list of test/contract cases and transfer only contract
1406 -- cases pragmas to the declarative part of the wrapper.
1408 Prag
:= Contract_Test_Cases
(Items
);
1409 while Present
(Prag
) loop
1410 if Pragma_Name
(Prag
) = Name_Contract_Cases
1411 and then Is_Checked
(Prag
)
1414 Transfer_Pragma
(Prag
, To
=> Decls
);
1417 Prag
:= Next_Pragma
(Prag
);
1421 -- The entry lacks executable contract items and a wrapper is not needed
1423 if not Has_Pragma
then
1427 -- Create the profile of the wrapper. The first formal parameter is the
1428 -- concurrent object.
1431 Make_Defining_Identifier
(Loc
,
1432 Chars
=> New_External_Name
(Chars
(Conc_Typ
), 'A'));
1434 Formals
:= New_List
(
1435 Make_Parameter_Specification
(Loc
,
1436 Defining_Identifier
=> Obj_Id
,
1437 Out_Present
=> True,
1439 Parameter_Type
=> New_Occurrence_Of
(Conc_Typ
, Loc
)));
1441 -- Construct the call to the original entry. The call will be gradually
1442 -- augmented with an optional entry index and extra parameters.
1445 Make_Selected_Component
(Loc
,
1446 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1447 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1449 -- When creating a wrapper for an entry family, the second formal is the
1452 if Ekind
(E
) = E_Entry_Family
then
1453 Index_Id
:= Make_Defining_Identifier
(Loc
, Name_I
);
1456 Make_Parameter_Specification
(Loc
,
1457 Defining_Identifier
=> Index_Id
,
1459 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1461 -- The call to the original entry becomes an indexed component to
1462 -- accommodate the entry index.
1465 Make_Indexed_Component
(Loc
,
1467 Expressions
=> New_List
(New_Occurrence_Of
(Index_Id
, Loc
)));
1470 -- Add formal parameters to match those of the entry and build actuals
1471 -- for the entry call.
1473 Add_Matching_Formals
(Formals
, Actuals
);
1476 Make_Procedure_Call_Statement
(Loc
,
1478 Parameter_Associations
=> Actuals
);
1480 -- Add renaming declarations for the discriminants of the enclosing type
1481 -- as the various contract items may reference them.
1483 Add_Discriminant_Renamings
(Obj_Id
, Decls
);
1486 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(E
), 'E'));
1487 Set_Contract_Wrapper
(E
, Wrapper_Id
);
1489 -- The wrapper body is analyzed when the enclosing type is frozen
1491 Append_Freeze_Action
(Defining_Entity
(Decl
),
1492 Make_Subprogram_Body
(Loc
,
1494 Make_Procedure_Specification
(Loc
,
1495 Defining_Unit_Name
=> Wrapper_Id
,
1496 Parameter_Specifications
=> Formals
),
1497 Declarations
=> Decls
,
1498 Handled_Statement_Sequence
=>
1499 Make_Handled_Sequence_Of_Statements
(Loc
,
1500 Statements
=> New_List
(Call
))));
1501 end Build_Contract_Wrapper
;
1503 --------------------------------
1504 -- Build_Corresponding_Record --
1505 --------------------------------
1507 function Build_Corresponding_Record
1510 Loc
: Source_Ptr
) return Node_Id
1512 Rec_Ent
: constant Entity_Id
:=
1513 Make_Defining_Identifier
1514 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1517 New_Disc
: Entity_Id
;
1521 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1522 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1523 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1524 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1525 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1526 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1529 -- Propagate type invariants to the corresponding record type
1531 Set_Has_Invariants
(Rec_Ent
, Has_Invariants
(Ctyp
));
1532 Set_Has_Inheritable_Invariants
(Rec_Ent
,
1533 Has_Inheritable_Invariants
(Ctyp
));
1535 -- Use discriminals to create list of discriminants for record, and
1536 -- create new discriminals for use in default expressions, etc. It is
1537 -- worth noting that a task discriminant gives rise to 5 entities;
1539 -- a) The original discriminant.
1540 -- b) The discriminal for use in the task.
1541 -- c) The discriminant of the corresponding record.
1542 -- d) The discriminal for the init proc of the corresponding record.
1543 -- e) The local variable that renames the discriminant in the procedure
1544 -- for the task body.
1546 -- In fact the discriminals b) are used in the renaming declarations
1547 -- for e). See details in einfo (Handling of Discriminants).
1549 if Present
(Discriminant_Specifications
(N
)) then
1551 Disc
:= First_Discriminant
(Ctyp
);
1553 while Present
(Disc
) loop
1554 New_Disc
:= CR_Discriminant
(Disc
);
1557 Make_Discriminant_Specification
(Loc
,
1558 Defining_Identifier
=> New_Disc
,
1559 Discriminant_Type
=>
1560 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1562 New_Copy
(Discriminant_Default_Value
(Disc
))));
1564 Next_Discriminant
(Disc
);
1571 -- Now we can construct the record type declaration. Note that this
1572 -- record is "limited tagged". It is "limited" to reflect the underlying
1573 -- limitedness of the task or protected object that it represents, and
1574 -- ensuring for example that it is properly passed by reference. It is
1575 -- "tagged" to give support to dispatching calls through interfaces. We
1576 -- propagate here the list of interfaces covered by the concurrent type
1577 -- (Ada 2005: AI-345).
1580 Make_Full_Type_Declaration
(Loc
,
1581 Defining_Identifier
=> Rec_Ent
,
1582 Discriminant_Specifications
=> Dlist
,
1584 Make_Record_Definition
(Loc
,
1586 Make_Component_List
(Loc
, Component_Items
=> Cdecls
),
1588 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1589 Interface_List
=> Interface_List
(N
),
1590 Limited_Present
=> True));
1591 end Build_Corresponding_Record
;
1593 ---------------------------------
1594 -- Build_Dispatching_Tag_Check --
1595 ---------------------------------
1597 function Build_Dispatching_Tag_Check
1599 N
: Node_Id
) return Node_Id
1601 Loc
: constant Source_Ptr
:= Sloc
(N
);
1608 New_Occurrence_Of
(K
, Loc
),
1610 New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
1614 New_Occurrence_Of
(K
, Loc
),
1616 New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
)));
1617 end Build_Dispatching_Tag_Check
;
1619 ----------------------------------
1620 -- Build_Entry_Count_Expression --
1621 ----------------------------------
1623 function Build_Entry_Count_Expression
1624 (Concurrent_Type
: Node_Id
;
1625 Component_List
: List_Id
;
1626 Loc
: Source_Ptr
) return Node_Id
1638 -- Count number of non-family entries
1641 Ent
:= First_Entity
(Concurrent_Type
);
1642 while Present
(Ent
) loop
1643 if Ekind
(Ent
) = E_Entry
then
1650 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1652 -- Loop through entry families building the addition nodes
1654 Ent
:= First_Entity
(Concurrent_Type
);
1655 Comp
:= First
(Component_List
);
1656 while Present
(Ent
) loop
1657 if Ekind
(Ent
) = E_Entry_Family
then
1658 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1662 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1663 Hi
:= Type_High_Bound
(Typ
);
1664 Lo
:= Type_Low_Bound
(Typ
);
1665 Large
:= Is_Potentially_Large_Family
1666 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1669 Left_Opnd
=> Ecount
,
1671 Family_Size
(Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1678 end Build_Entry_Count_Expression
;
1680 -----------------------
1681 -- Build_Entry_Names --
1682 -----------------------
1684 procedure Build_Entry_Names
1686 Obj_Typ
: Entity_Id
;
1689 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
1690 Data
: Entity_Id
:= Empty
;
1691 Index
: Entity_Id
:= Empty
;
1692 Typ
: Entity_Id
:= Obj_Typ
;
1694 procedure Build_Entry_Name
(Comp_Id
: Entity_Id
);
1695 -- Given an entry [family], create a static string which denotes the
1696 -- name of Comp_Id and assign it to the underlying data structure which
1697 -- contains the entry names of a concurrent object.
1699 function Object_Reference
return Node_Id
;
1700 -- Return a reference to field _object or _task_id depending on the
1701 -- concurrent object being processed.
1703 ----------------------
1704 -- Build_Entry_Name --
1705 ----------------------
1707 procedure Build_Entry_Name
(Comp_Id
: Entity_Id
) is
1708 function Build_Range
(Def
: Node_Id
) return Node_Id
;
1709 -- Given a discrete subtype definition of an entry family, generate a
1710 -- range node which covers the range of Def's type.
1712 procedure Create_Index_And_Data
;
1713 -- Generate the declarations of variables Index and Data. Subsequent
1714 -- calls do nothing.
1716 function Increment_Index
return Node_Id
;
1717 -- Increment the index used in the assignment of string names to the
1720 function Name_Declaration
(Def_Id
: Entity_Id
) return Node_Id
;
1721 -- Given the name of a temporary variable, create the following
1722 -- declaration for it:
1724 -- Def_Id : aliased constant String := <String_Name_From_Buffer>;
1726 function Set_Entry_Name
(Def_Id
: Entity_Id
) return Node_Id
;
1727 -- Given the name of a temporary variable, place it in the array of
1728 -- string names. Generate:
1730 -- Data (Index) := Def_Id'Unchecked_Access;
1736 function Build_Range
(Def
: Node_Id
) return Node_Id
is
1737 High
: Node_Id
:= Type_High_Bound
(Etype
(Def
));
1738 Low
: Node_Id
:= Type_Low_Bound
(Etype
(Def
));
1741 -- If a bound references a discriminant, generate an identifier
1742 -- with the same name. Resolution will map it to the formals of
1745 if Is_Entity_Name
(Low
)
1746 and then Ekind
(Entity
(Low
)) = E_Discriminant
1749 Make_Selected_Component
(Loc
,
1750 Prefix
=> New_Copy_Tree
(Obj_Ref
),
1751 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Low
)));
1753 Low
:= New_Copy_Tree
(Low
);
1756 if Is_Entity_Name
(High
)
1757 and then Ekind
(Entity
(High
)) = E_Discriminant
1760 Make_Selected_Component
(Loc
,
1761 Prefix
=> New_Copy_Tree
(Obj_Ref
),
1762 Selector_Name
=> Make_Identifier
(Loc
, Chars
(High
)));
1764 High
:= New_Copy_Tree
(High
);
1770 High_Bound
=> High
);
1773 ---------------------------
1774 -- Create_Index_And_Data --
1775 ---------------------------
1777 procedure Create_Index_And_Data
is
1779 if No
(Index
) and then No
(Data
) then
1786 if Is_Protected_Type
(Typ
) then
1787 Count
:= RO_PE_Number_Of_Entries
;
1788 Data_Typ
:= RE_Protected_Entry_Names_Array
;
1790 Count
:= RO_ST_Number_Of_Entries
;
1791 Data_Typ
:= RE_Task_Entry_Names_Array
;
1794 -- Step 1: Generate the declaration of the index variable:
1796 -- Index : Entry_Index := 1;
1798 Index
:= Make_Temporary
(Loc
, 'I');
1801 Make_Object_Declaration
(Loc
,
1802 Defining_Identifier
=> Index
,
1803 Object_Definition
=>
1804 New_Occurrence_Of
(RTE
(RE_Entry_Index
), Loc
),
1805 Expression
=> Make_Integer_Literal
(Loc
, 1)));
1807 -- Step 2: Generate the declaration of an array to house all
1810 -- Size : constant Entry_Index := <Count> (Obj_Ref);
1811 -- Data : aliased <Data_Typ> := (1 .. Size => null);
1813 Size
:= Make_Temporary
(Loc
, 'S');
1816 Make_Object_Declaration
(Loc
,
1817 Defining_Identifier
=> Size
,
1818 Constant_Present
=> True,
1819 Object_Definition
=>
1820 New_Occurrence_Of
(RTE
(RE_Entry_Index
), Loc
),
1822 Make_Function_Call
(Loc
,
1824 New_Occurrence_Of
(RTE
(Count
), Loc
),
1825 Parameter_Associations
=>
1826 New_List
(Object_Reference
))));
1828 Data
:= Make_Temporary
(Loc
, 'A');
1831 Make_Object_Declaration
(Loc
,
1832 Defining_Identifier
=> Data
,
1833 Aliased_Present
=> True,
1834 Object_Definition
=>
1835 New_Occurrence_Of
(RTE
(Data_Typ
), Loc
),
1837 Make_Aggregate
(Loc
,
1838 Component_Associations
=> New_List
(
1839 Make_Component_Association
(Loc
,
1840 Choices
=> New_List
(
1843 Make_Integer_Literal
(Loc
, 1),
1845 New_Occurrence_Of
(Size
, Loc
))),
1846 Expression
=> Make_Null
(Loc
))))));
1849 end Create_Index_And_Data
;
1851 ---------------------
1852 -- Increment_Index --
1853 ---------------------
1855 function Increment_Index
return Node_Id
is
1858 Make_Assignment_Statement
(Loc
,
1859 Name
=> New_Occurrence_Of
(Index
, Loc
),
1862 Left_Opnd
=> New_Occurrence_Of
(Index
, Loc
),
1863 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
1864 end Increment_Index
;
1866 ----------------------
1867 -- Name_Declaration --
1868 ----------------------
1870 function Name_Declaration
(Def_Id
: Entity_Id
) return Node_Id
is
1873 Make_Object_Declaration
(Loc
,
1874 Defining_Identifier
=> Def_Id
,
1875 Aliased_Present
=> True,
1876 Constant_Present
=> True,
1877 Object_Definition
=>
1878 New_Occurrence_Of
(Standard_String
, Loc
),
1880 Make_String_Literal
(Loc
, String_From_Name_Buffer
));
1881 end Name_Declaration
;
1883 --------------------
1884 -- Set_Entry_Name --
1885 --------------------
1887 function Set_Entry_Name
(Def_Id
: Entity_Id
) return Node_Id
is
1890 Make_Assignment_Statement
(Loc
,
1892 Make_Indexed_Component
(Loc
,
1893 Prefix
=> New_Occurrence_Of
(Data
, Loc
),
1894 Expressions
=> New_List
(New_Occurrence_Of
(Index
, Loc
))),
1897 Make_Attribute_Reference
(Loc
,
1898 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
),
1899 Attribute_Name
=> Name_Unchecked_Access
));
1904 Temp_Id
: Entity_Id
;
1907 -- Start of processing for Build_Entry_Name
1910 if Ekind
(Comp_Id
) = E_Entry_Family
then
1911 Subt_Def
:= Discrete_Subtype_Definition
(Parent
(Comp_Id
));
1913 Create_Index_And_Data
;
1915 -- Step 1: Create the string name of the entry family.
1917 -- Temp : aliased constant String := "name ()";
1919 Temp_Id
:= Make_Temporary
(Loc
, 'S');
1920 Get_Name_String
(Chars
(Comp_Id
));
1921 Add_Char_To_Name_Buffer
(' ');
1922 Add_Char_To_Name_Buffer
('(');
1923 Add_Char_To_Name_Buffer
(')');
1925 Append_To
(Stmts
, Name_Declaration
(Temp_Id
));
1928 -- for Member in Family_Low .. Family_High loop
1929 -- Set_Entry_Name (...);
1930 -- Index := Index + 1;
1934 Make_Loop_Statement
(Loc
,
1936 Make_Iteration_Scheme
(Loc
,
1937 Loop_Parameter_Specification
=>
1938 Make_Loop_Parameter_Specification
(Loc
,
1939 Defining_Identifier
=>
1940 Make_Temporary
(Loc
, 'L'),
1941 Discrete_Subtype_Definition
=>
1942 Build_Range
(Subt_Def
))),
1944 Statements
=> New_List
(
1945 Set_Entry_Name
(Temp_Id
),
1947 End_Label
=> Empty
));
1952 Create_Index_And_Data
;
1954 -- Step 1: Create the string name of the entry. Generate:
1955 -- Temp : aliased constant String := "name";
1957 Temp_Id
:= Make_Temporary
(Loc
, 'S');
1958 Get_Name_String
(Chars
(Comp_Id
));
1960 Append_To
(Stmts
, Name_Declaration
(Temp_Id
));
1962 -- Step 2: Associate the string name with the underlying data
1965 Append_To
(Stmts
, Set_Entry_Name
(Temp_Id
));
1966 Append_To
(Stmts
, Increment_Index
);
1968 end Build_Entry_Name
;
1970 ----------------------
1971 -- Object_Reference --
1972 ----------------------
1974 function Object_Reference
return Node_Id
is
1975 Conc_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Typ
);
1980 if Is_Protected_Type
(Typ
) then
1981 Field
:= Name_uObject
;
1983 Field
:= Name_uTask_Id
;
1987 Make_Selected_Component
(Loc
,
1989 Unchecked_Convert_To
(Conc_Typ
, New_Copy_Tree
(Obj_Ref
)),
1990 Selector_Name
=> Make_Identifier
(Loc
, Field
));
1992 if Is_Protected_Type
(Typ
) then
1994 Make_Attribute_Reference
(Loc
,
1996 Attribute_Name
=> Name_Unchecked_Access
);
2000 end Object_Reference
;
2007 -- Start of processing for Build_Entry_Names
2010 -- Retrieve the original concurrent type
2012 if Is_Concurrent_Record_Type
(Typ
) then
2013 Typ
:= Corresponding_Concurrent_Type
(Typ
);
2016 pragma Assert
(Is_Concurrent_Type
(Typ
));
2018 -- Nothing to do if the type has no entries
2020 if not Has_Entries
(Typ
) then
2024 -- Avoid generating entry names for a protected type with only one entry
2026 if Is_Protected_Type
(Typ
)
2027 and then Find_Protection_Type
(Base_Type
(Typ
)) /=
2028 RTE
(RE_Protection_Entries
)
2033 -- Step 1: Populate the array with statically generated strings denoting
2034 -- entries and entry family names.
2036 Comp
:= First_Entity
(Typ
);
2037 while Present
(Comp
) loop
2038 if Comes_From_Source
(Comp
)
2039 and then Ekind_In
(Comp
, E_Entry
, E_Entry_Family
)
2041 Build_Entry_Name
(Comp
);
2047 -- Step 2: Associate the array with the related concurrent object:
2049 -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access);
2051 if Present
(Data
) then
2052 if Is_Protected_Type
(Typ
) then
2053 Proc
:= RO_PE_Set_Entry_Names
;
2055 Proc
:= RO_ST_Set_Entry_Names
;
2059 Make_Procedure_Call_Statement
(Loc
,
2060 Name
=> New_Occurrence_Of
(RTE
(Proc
), Loc
),
2061 Parameter_Associations
=> New_List
(
2063 Make_Attribute_Reference
(Loc
,
2064 Prefix
=> New_Occurrence_Of
(Data
, Loc
),
2065 Attribute_Name
=> Name_Unchecked_Access
))));
2067 end Build_Entry_Names
;
2069 ---------------------------
2070 -- Build_Parameter_Block --
2071 ---------------------------
2073 function Build_Parameter_Block
2077 Decls
: List_Id
) return Entity_Id
2083 Has_Comp
: Boolean := False;
2087 Actual
:= First
(Actuals
);
2089 Formal
:= Defining_Identifier
(First
(Formals
));
2091 while Present
(Actual
) loop
2092 if not Is_Controlling_Actual
(Actual
) then
2095 -- type Ann is access all <actual-type>
2097 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
2098 Set_Is_Param_Block_Component_Type
(Comp_Nam
);
2101 Make_Full_Type_Declaration
(Loc
,
2102 Defining_Identifier
=> Comp_Nam
,
2104 Make_Access_To_Object_Definition
(Loc
,
2105 All_Present
=> True,
2106 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
2107 Subtype_Indication
=>
2108 New_Occurrence_Of
(Etype
(Actual
), Loc
))));
2114 Make_Component_Declaration
(Loc
,
2115 Defining_Identifier
=>
2116 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
2117 Component_Definition
=>
2118 Make_Component_Definition
(Loc
,
2121 Subtype_Indication
=>
2122 New_Occurrence_Of
(Comp_Nam
, Loc
))));
2127 Next_Actual
(Actual
);
2128 Next_Formal_With_Extras
(Formal
);
2131 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
2136 -- type Pnn is record
2141 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
2142 -- the original parameter names and Ann1 .. AnnN are the access to
2146 Make_Full_Type_Declaration
(Loc
,
2147 Defining_Identifier
=>
2150 Make_Record_Definition
(Loc
,
2152 Make_Component_List
(Loc
, Comps
))));
2155 -- type Pnn is null record;
2158 Make_Full_Type_Declaration
(Loc
,
2159 Defining_Identifier
=>
2162 Make_Record_Definition
(Loc
,
2163 Null_Present
=> True,
2164 Component_List
=> Empty
)));
2168 end Build_Parameter_Block
;
2170 --------------------------------------
2171 -- Build_Renamed_Formal_Declaration --
2172 --------------------------------------
2174 function Build_Renamed_Formal_Declaration
2178 Renamed_Formal
: Node_Id
) return Node_Id
2180 Loc
: constant Source_Ptr
:= Sloc
(New_F
);
2184 -- If the formal is a tagged incomplete type, it is already passed
2185 -- by reference, so it is sufficient to rename the pointer component
2186 -- that corresponds to the actual. Otherwise we need to dereference
2187 -- the pointer component to obtain the actual.
2189 if Is_Incomplete_Type
(Etype
(Formal
))
2190 and then Is_Tagged_Type
(Etype
(Formal
))
2193 Make_Object_Renaming_Declaration
(Loc
,
2194 Defining_Identifier
=> New_F
,
2195 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Comp
), Loc
),
2196 Name
=> Renamed_Formal
);
2200 Make_Object_Renaming_Declaration
(Loc
,
2201 Defining_Identifier
=> New_F
,
2202 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Formal
), Loc
),
2204 Make_Explicit_Dereference
(Loc
, Renamed_Formal
));
2208 end Build_Renamed_Formal_Declaration
;
2210 --------------------------
2211 -- Build_Wrapper_Bodies --
2212 --------------------------
2214 procedure Build_Wrapper_Bodies
2219 Rec_Typ
: Entity_Id
;
2221 function Build_Wrapper_Body
2223 Subp_Id
: Entity_Id
;
2224 Obj_Typ
: Entity_Id
;
2225 Formals
: List_Id
) return Node_Id
;
2226 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
2227 -- associated with a protected or task type. Subp_Id is the subprogram
2228 -- name which will be wrapped. Obj_Typ is the type of the new formal
2229 -- parameter which handles dispatching and object notation. Formals are
2230 -- the original formals of Subp_Id which will be explicitly replicated.
2232 ------------------------
2233 -- Build_Wrapper_Body --
2234 ------------------------
2236 function Build_Wrapper_Body
2238 Subp_Id
: Entity_Id
;
2239 Obj_Typ
: Entity_Id
;
2240 Formals
: List_Id
) return Node_Id
2242 Body_Spec
: Node_Id
;
2245 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
2247 -- The subprogram is not overriding or is not a primitive declared
2248 -- between two views.
2250 if No
(Body_Spec
) then
2255 Actuals
: List_Id
:= No_List
;
2257 First_Form
: Node_Id
;
2262 -- Map formals to actuals. Use the list built for the wrapper
2263 -- spec, skipping the object notation parameter.
2265 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
2267 Formal
:= First_Form
;
2270 if Present
(Formal
) then
2271 Actuals
:= New_List
;
2272 while Present
(Formal
) loop
2274 Make_Identifier
(Loc
,
2275 Chars
=> Chars
(Defining_Identifier
(Formal
))));
2280 -- Special processing for primitives declared between a private
2281 -- type and its completion: the wrapper needs a properly typed
2282 -- parameter if the wrapped operation has a controlling first
2283 -- parameter. Note that this might not be the case for a function
2284 -- with a controlling result.
2286 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
2287 if No
(Actuals
) then
2288 Actuals
:= New_List
;
2291 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
2292 Prepend_To
(Actuals
,
2293 Unchecked_Convert_To
2294 (Corresponding_Concurrent_Type
(Obj_Typ
),
2295 Make_Identifier
(Loc
, Name_uO
)));
2298 Prepend_To
(Actuals
,
2299 Make_Identifier
(Loc
,
2300 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
2303 Nam
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2305 -- An access-to-variable object parameter requires an explicit
2306 -- dereference in the unchecked conversion. This case occurs
2307 -- when a protected entry wrapper must override an interface
2308 -- level procedure with interface access as first parameter.
2310 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
2312 if Nkind
(Parameter_Type
(First_Form
)) =
2316 Make_Explicit_Dereference
(Loc
,
2317 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
2319 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
2323 Make_Selected_Component
(Loc
,
2325 Unchecked_Convert_To
2326 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
2327 Selector_Name
=> New_Occurrence_Of
(Subp_Id
, Loc
));
2330 -- Create the subprogram body. For a function, the call to the
2331 -- actual subprogram has to be converted to the corresponding
2332 -- record if it is a controlling result.
2334 if Ekind
(Subp_Id
) = E_Function
then
2340 Make_Function_Call
(Loc
,
2342 Parameter_Associations
=> Actuals
);
2344 if Has_Controlling_Result
(Subp_Id
) then
2346 Unchecked_Convert_To
2347 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
2351 Make_Subprogram_Body
(Loc
,
2352 Specification
=> Body_Spec
,
2353 Declarations
=> Empty_List
,
2354 Handled_Statement_Sequence
=>
2355 Make_Handled_Sequence_Of_Statements
(Loc
,
2356 Statements
=> New_List
(
2357 Make_Simple_Return_Statement
(Loc
, Res
))));
2362 Make_Subprogram_Body
(Loc
,
2363 Specification
=> Body_Spec
,
2364 Declarations
=> Empty_List
,
2365 Handled_Statement_Sequence
=>
2366 Make_Handled_Sequence_Of_Statements
(Loc
,
2367 Statements
=> New_List
(
2368 Make_Procedure_Call_Statement
(Loc
,
2370 Parameter_Associations
=> Actuals
))));
2373 end Build_Wrapper_Body
;
2375 -- Start of processing for Build_Wrapper_Bodies
2378 if Is_Concurrent_Type
(Typ
) then
2379 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2384 -- Generate wrapper bodies for a concurrent type which implements an
2387 if Present
(Interfaces
(Rec_Typ
)) then
2389 Insert_Nod
: Node_Id
;
2391 Prim_Elmt
: Elmt_Id
;
2392 Prim_Decl
: Node_Id
;
2394 Wrap_Body
: Node_Id
;
2395 Wrap_Id
: Entity_Id
;
2400 -- Examine all primitive operations of the corresponding record
2401 -- type, looking for wrapper specs. Generate bodies in order to
2404 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
2405 while Present
(Prim_Elmt
) loop
2406 Prim
:= Node
(Prim_Elmt
);
2408 if (Ekind
(Prim
) = E_Function
2409 or else Ekind
(Prim
) = E_Procedure
)
2410 and then Is_Primitive_Wrapper
(Prim
)
2412 Subp
:= Wrapped_Entity
(Prim
);
2413 Prim_Decl
:= Parent
(Parent
(Prim
));
2416 Build_Wrapper_Body
(Loc
,
2419 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
2420 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
2422 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
2423 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
2425 Insert_After
(Insert_Nod
, Wrap_Body
);
2426 Insert_Nod
:= Wrap_Body
;
2428 Analyze
(Wrap_Body
);
2431 Next_Elmt
(Prim_Elmt
);
2435 end Build_Wrapper_Bodies
;
2437 ------------------------
2438 -- Build_Wrapper_Spec --
2439 ------------------------
2441 function Build_Wrapper_Spec
2442 (Subp_Id
: Entity_Id
;
2443 Obj_Typ
: Entity_Id
;
2444 Formals
: List_Id
) return Node_Id
2446 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2447 First_Param
: Node_Id
;
2449 Iface_Elmt
: Elmt_Id
;
2450 Iface_Op
: Entity_Id
;
2451 Iface_Op_Elmt
: Elmt_Id
;
2453 function Overriding_Possible
2454 (Iface_Op
: Entity_Id
;
2455 Wrapper
: Entity_Id
) return Boolean;
2456 -- Determine whether a primitive operation can be overridden by Wrapper.
2457 -- Iface_Op is the candidate primitive operation of an interface type,
2458 -- Wrapper is the generated entry wrapper.
2460 function Replicate_Formals
2462 Formals
: List_Id
) return List_Id
;
2463 -- An explicit parameter replication is required due to the Is_Entry_
2464 -- Formal flag being set for all the formals of an entry. The explicit
2465 -- replication removes the flag that would otherwise cause a different
2466 -- path of analysis.
2468 -------------------------
2469 -- Overriding_Possible --
2470 -------------------------
2472 function Overriding_Possible
2473 (Iface_Op
: Entity_Id
;
2474 Wrapper
: Entity_Id
) return Boolean
2476 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2477 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2479 function Type_Conformant_Parameters
2480 (Iface_Op_Params
: List_Id
;
2481 Wrapper_Params
: List_Id
) return Boolean;
2482 -- Determine whether the parameters of the generated entry wrapper
2483 -- and those of a primitive operation are type conformant. During
2484 -- this check, the first parameter of the primitive operation is
2485 -- skipped if it is a controlling argument: protected functions
2486 -- may have a controlling result.
2488 --------------------------------
2489 -- Type_Conformant_Parameters --
2490 --------------------------------
2492 function Type_Conformant_Parameters
2493 (Iface_Op_Params
: List_Id
;
2494 Wrapper_Params
: List_Id
) return Boolean
2496 Iface_Op_Param
: Node_Id
;
2497 Iface_Op_Typ
: Entity_Id
;
2498 Wrapper_Param
: Node_Id
;
2499 Wrapper_Typ
: Entity_Id
;
2502 -- Skip the first (controlling) parameter of primitive operation
2504 Iface_Op_Param
:= First
(Iface_Op_Params
);
2506 if Present
(First_Formal
(Iface_Op
))
2507 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2509 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2512 Wrapper_Param
:= First
(Wrapper_Params
);
2513 while Present
(Iface_Op_Param
)
2514 and then Present
(Wrapper_Param
)
2516 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2517 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2519 -- The two parameters must be mode conformant
2521 if not Conforming_Types
2522 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2527 Next
(Iface_Op_Param
);
2528 Next
(Wrapper_Param
);
2531 -- One of the lists is longer than the other
2533 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2538 end Type_Conformant_Parameters
;
2540 -- Start of processing for Overriding_Possible
2543 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2547 -- If an inherited subprogram is implemented by a protected procedure
2548 -- or an entry, then the first parameter of the inherited subprogram
2549 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2551 if Ekind
(Iface_Op
) = E_Procedure
2552 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2555 Obj_Param
: constant Node_Id
:=
2556 First
(Parameter_Specifications
(Iface_Op_Spec
));
2558 if not Out_Present
(Obj_Param
)
2559 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2568 Type_Conformant_Parameters
(
2569 Parameter_Specifications
(Iface_Op_Spec
),
2570 Parameter_Specifications
(Wrapper_Spec
));
2571 end Overriding_Possible
;
2573 -----------------------
2574 -- Replicate_Formals --
2575 -----------------------
2577 function Replicate_Formals
2579 Formals
: List_Id
) return List_Id
2581 New_Formals
: constant List_Id
:= New_List
;
2583 Param_Type
: Node_Id
;
2586 Formal
:= First
(Formals
);
2588 -- Skip the object parameter when dealing with primitives declared
2589 -- between two views.
2591 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2592 and then not Has_Controlling_Result
(Subp_Id
)
2594 Formal
:= Next
(Formal
);
2597 while Present
(Formal
) loop
2599 -- Create an explicit copy of the entry parameter
2601 -- When creating the wrapper subprogram for a primitive operation
2602 -- of a protected interface we must construct an equivalent
2603 -- signature to that of the overriding operation. For regular
2604 -- parameters we can just use the type of the formal, but for
2605 -- access to subprogram parameters we need to reanalyze the
2606 -- parameter type to create local entities for the signature of
2607 -- the subprogram type. Using the entities of the overriding
2608 -- subprogram will result in out-of-scope errors in the back-end.
2610 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2611 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2614 New_Occurrence_Of
(Etype
(Parameter_Type
(Formal
)), Loc
);
2617 Append_To
(New_Formals
,
2618 Make_Parameter_Specification
(Loc
,
2619 Defining_Identifier
=>
2620 Make_Defining_Identifier
(Loc
,
2622 (Defining_Identifier
(Formal
))),
2623 In_Present
=> In_Present
(Formal
),
2624 Out_Present
=> Out_Present
(Formal
),
2625 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
2626 Parameter_Type
=> Param_Type
));
2632 end Replicate_Formals
;
2634 -- Start of processing for Build_Wrapper_Spec
2637 -- No point in building wrappers for untagged concurrent types
2639 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2641 -- An entry or a protected procedure can override a routine where the
2642 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2643 -- type. Since the wrapper must have the exact same signature as that of
2644 -- the overridden subprogram, we try to find the overriding candidate
2645 -- and use its controlling formal.
2647 First_Param
:= Empty
;
2649 -- Check every implemented interface
2651 if Present
(Interfaces
(Obj_Typ
)) then
2652 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2653 Search
: while Present
(Iface_Elmt
) loop
2654 Iface
:= Node
(Iface_Elmt
);
2656 -- Check every interface primitive
2658 if Present
(Primitive_Operations
(Iface
)) then
2659 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2660 while Present
(Iface_Op_Elmt
) loop
2661 Iface_Op
:= Node
(Iface_Op_Elmt
);
2663 -- Ignore predefined primitives
2665 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2666 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2668 -- The current primitive operation can be overridden by
2669 -- the generated entry wrapper.
2671 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2673 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2679 Next_Elmt
(Iface_Op_Elmt
);
2683 Next_Elmt
(Iface_Elmt
);
2687 -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by
2688 -- this subprogram and this is not a primitive declared between two
2689 -- views then force the generation of a wrapper. As an optimization,
2690 -- previous versions of the frontend avoid generating the wrapper;
2691 -- however, the wrapper facilitates locating and reporting an error
2692 -- when a duplicate declaration is found later. See example in
2696 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2699 (Corresponding_Concurrent_Type
(Obj_Typ
))
2702 Make_Parameter_Specification
(Loc
,
2703 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
2705 Out_Present
=> False,
2706 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2708 -- For entries and procedures of protected types the mode of
2709 -- the controlling argument must be in-out.
2713 Make_Parameter_Specification
(Loc
,
2714 Defining_Identifier
=>
2715 Make_Defining_Identifier
(Loc
,
2718 Out_Present
=> (Ekind
(Subp_Id
) /= E_Function
),
2719 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2724 Wrapper_Id
: constant Entity_Id
:=
2725 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2726 New_Formals
: List_Id
;
2727 Obj_Param
: Node_Id
;
2728 Obj_Param_Typ
: Entity_Id
;
2731 -- Minimum decoration is needed to catch the entity in
2732 -- Sem_Ch6.Override_Dispatching_Operation.
2734 if Ekind
(Subp_Id
) = E_Function
then
2735 Set_Ekind
(Wrapper_Id
, E_Function
);
2737 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2740 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2741 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2742 Set_Is_Private_Primitive
(Wrapper_Id
,
2743 Is_Private_Primitive_Subprogram
(Subp_Id
));
2745 -- Process the formals
2747 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2749 -- A function with a controlling result and no first controlling
2750 -- formal needs no additional parameter.
2752 if Has_Controlling_Result
(Subp_Id
)
2754 (No
(First_Formal
(Subp_Id
))
2755 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2759 -- Routine Subp_Id has been found to override an interface primitive.
2760 -- If the interface operation has an access parameter, create a copy
2761 -- of it, with the same null exclusion indicator if present.
2763 elsif Present
(First_Param
) then
2764 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2766 Make_Access_Definition
(Loc
,
2768 New_Occurrence_Of
(Obj_Typ
, Loc
),
2769 Null_Exclusion_Present
=>
2770 Null_Exclusion_Present
(Parameter_Type
(First_Param
)),
2772 Constant_Present
(Parameter_Type
(First_Param
)));
2774 Obj_Param_Typ
:= New_Occurrence_Of
(Obj_Typ
, Loc
);
2778 Make_Parameter_Specification
(Loc
,
2779 Defining_Identifier
=>
2780 Make_Defining_Identifier
(Loc
,
2782 In_Present
=> In_Present
(First_Param
),
2783 Out_Present
=> Out_Present
(First_Param
),
2784 Parameter_Type
=> Obj_Param_Typ
);
2786 Prepend_To
(New_Formals
, Obj_Param
);
2788 -- If we are dealing with a primitive declared between two views,
2789 -- implemented by a synchronized operation, we need to create
2790 -- a default parameter. The mode of the parameter must match that
2791 -- of the primitive operation.
2794 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2796 Make_Parameter_Specification
(Loc
,
2797 Defining_Identifier
=>
2798 Make_Defining_Identifier
(Loc
, Name_uO
),
2799 In_Present
=> In_Present
(Parent
(First_Entity
(Subp_Id
))),
2800 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2801 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2802 Prepend_To
(New_Formals
, Obj_Param
);
2805 -- Build the final spec. If it is a function with a controlling
2806 -- result, it is a primitive operation of the corresponding
2807 -- record type, so mark the spec accordingly.
2809 if Ekind
(Subp_Id
) = E_Function
then
2814 if Has_Controlling_Result
(Subp_Id
) then
2817 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2819 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2823 Make_Function_Specification
(Loc
,
2824 Defining_Unit_Name
=> Wrapper_Id
,
2825 Parameter_Specifications
=> New_Formals
,
2826 Result_Definition
=> Res_Def
);
2830 Make_Procedure_Specification
(Loc
,
2831 Defining_Unit_Name
=> Wrapper_Id
,
2832 Parameter_Specifications
=> New_Formals
);
2835 end Build_Wrapper_Spec
;
2837 -------------------------
2838 -- Build_Wrapper_Specs --
2839 -------------------------
2841 procedure Build_Wrapper_Specs
2847 Rec_Typ
: Entity_Id
;
2848 procedure Scan_Declarations
(L
: List_Id
);
2849 -- Common processing for visible and private declarations
2850 -- of a protected type.
2852 procedure Scan_Declarations
(L
: List_Id
) is
2854 Wrap_Decl
: Node_Id
;
2855 Wrap_Spec
: Node_Id
;
2863 while Present
(Decl
) loop
2866 if Nkind
(Decl
) = N_Entry_Declaration
2867 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2871 (Subp_Id
=> Defining_Identifier
(Decl
),
2873 Formals
=> Parameter_Specifications
(Decl
));
2875 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2878 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2881 Parameter_Specifications
(Specification
(Decl
)));
2884 if Present
(Wrap_Spec
) then
2886 Make_Subprogram_Declaration
(Loc
,
2887 Specification
=> Wrap_Spec
);
2889 Insert_After
(N
, Wrap_Decl
);
2892 Analyze
(Wrap_Decl
);
2897 end Scan_Declarations
;
2899 -- start of processing for Build_Wrapper_Specs
2902 if Is_Protected_Type
(Typ
) then
2903 Def
:= Protected_Definition
(Parent
(Typ
));
2904 else pragma Assert
(Is_Task_Type
(Typ
));
2905 Def
:= Task_Definition
(Parent
(Typ
));
2908 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2910 -- Generate wrapper specs for a concurrent type which implements an
2911 -- interface. Operations in both the visible and private parts may
2912 -- implement progenitor operations.
2914 if Present
(Interfaces
(Rec_Typ
)) and then Present
(Def
) then
2915 Scan_Declarations
(Visible_Declarations
(Def
));
2916 Scan_Declarations
(Private_Declarations
(Def
));
2918 end Build_Wrapper_Specs
;
2920 ---------------------------
2921 -- Build_Find_Body_Index --
2922 ---------------------------
2924 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2925 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2928 Has_F
: Boolean := False;
2930 If_St
: Node_Id
:= Empty
;
2933 Decls
: List_Id
:= New_List
;
2936 Siz
: Node_Id
:= Empty
;
2938 procedure Add_If_Clause
(Expr
: Node_Id
);
2939 -- Add test for range of current entry
2941 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2942 -- If a bound of an entry is given by a discriminant, retrieve the
2943 -- actual value of the discriminant from the enclosing object.
2949 procedure Add_If_Clause
(Expr
: Node_Id
) is
2951 Stats
: constant List_Id
:=
2953 Make_Simple_Return_Statement
(Loc
,
2954 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2957 -- Index for current entry body
2961 -- Compute total length of entry queues so far
2969 Right_Opnd
=> Expr
);
2974 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2977 -- Map entry queue indexes in the range of the current family
2978 -- into the current index, that designates the entry body.
2982 Make_Implicit_If_Statement
(Typ
,
2984 Then_Statements
=> Stats
,
2985 Elsif_Parts
=> New_List
);
2989 Append_To
(Elsif_Parts
(If_St
),
2990 Make_Elsif_Part
(Loc
,
2992 Then_Statements
=> Stats
));
2996 ------------------------------
2997 -- Convert_Discriminant_Ref --
2998 ------------------------------
3000 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
3004 if Is_Entity_Name
(Bound
)
3005 and then Ekind
(Entity
(Bound
)) = E_Discriminant
3008 Make_Selected_Component
(Loc
,
3010 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
3011 Make_Explicit_Dereference
(Loc
,
3012 Make_Identifier
(Loc
, Name_uObject
))),
3013 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
3014 Set_Etype
(B
, Etype
(Entity
(Bound
)));
3016 B
:= New_Copy_Tree
(Bound
);
3020 end Convert_Discriminant_Ref
;
3022 -- Start of processing for Build_Find_Body_Index
3025 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
3027 Ent
:= First_Entity
(Typ
);
3028 while Present
(Ent
) loop
3029 if Ekind
(Ent
) = E_Entry_Family
then
3039 -- If the protected type has no entry families, there is a one-one
3040 -- correspondence between entry queue and entry body.
3043 Make_Simple_Return_Statement
(Loc
,
3044 Expression
=> Make_Identifier
(Loc
, Name_uE
));
3047 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
3050 -- if E <= l1 then return 1;
3051 -- elsif E <= l1 + l2 then return 2;
3056 Ent
:= First_Entity
(Typ
);
3058 Add_Object_Pointer
(Loc
, Typ
, Decls
);
3060 while Present
(Ent
) loop
3061 if Ekind
(Ent
) = E_Entry
then
3062 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
3064 elsif Ekind
(Ent
) = E_Entry_Family
then
3065 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
3066 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
3067 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
3068 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
3077 Make_Simple_Return_Statement
(Loc
,
3078 Expression
=> Make_Integer_Literal
(Loc
, 1));
3080 elsif Nkind
(Ret
) = N_If_Statement
then
3082 -- Ranges are in increasing order, so last one doesn't need guard
3085 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
3088 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
3094 Make_Subprogram_Body
(Loc
,
3095 Specification
=> Spec
,
3096 Declarations
=> Decls
,
3097 Handled_Statement_Sequence
=>
3098 Make_Handled_Sequence_Of_Statements
(Loc
,
3099 Statements
=> New_List
(Ret
)));
3100 end Build_Find_Body_Index
;
3102 --------------------------------
3103 -- Build_Find_Body_Index_Spec --
3104 --------------------------------
3106 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
3107 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3108 Id
: constant Entity_Id
:=
3109 Make_Defining_Identifier
(Loc
,
3110 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
3111 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
3112 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
3116 Make_Function_Specification
(Loc
,
3117 Defining_Unit_Name
=> Id
,
3118 Parameter_Specifications
=> New_List
(
3119 Make_Parameter_Specification
(Loc
,
3120 Defining_Identifier
=> Parm1
,
3122 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3124 Make_Parameter_Specification
(Loc
,
3125 Defining_Identifier
=> Parm2
,
3127 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
3129 Result_Definition
=> New_Occurrence_Of
(
3130 RTE
(RE_Protected_Entry_Index
), Loc
));
3131 end Build_Find_Body_Index_Spec
;
3133 -----------------------------------------------
3134 -- Build_Lock_Free_Protected_Subprogram_Body --
3135 -----------------------------------------------
3137 function Build_Lock_Free_Protected_Subprogram_Body
3140 Unprot_Spec
: Node_Id
) return Node_Id
3142 Actuals
: constant List_Id
:= New_List
;
3143 Loc
: constant Source_Ptr
:= Sloc
(N
);
3144 Spec
: constant Node_Id
:= Specification
(N
);
3145 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
3147 Prot_Spec
: Node_Id
;
3151 -- Create the protected version of the body
3154 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
3156 -- Build the actual parameters which appear in the call to the
3157 -- unprotected version of the body.
3159 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
3160 while Present
(Formal
) loop
3162 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
3167 -- Function case, generate:
3168 -- return <Unprot_Func_Call>;
3170 if Nkind
(Spec
) = N_Function_Specification
then
3172 Make_Simple_Return_Statement
(Loc
,
3174 Make_Function_Call
(Loc
,
3176 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
3177 Parameter_Associations
=> Actuals
));
3179 -- Procedure case, call the unprotected version
3183 Make_Procedure_Call_Statement
(Loc
,
3185 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
3186 Parameter_Associations
=> Actuals
);
3190 Make_Subprogram_Body
(Loc
,
3191 Declarations
=> Empty_List
,
3192 Specification
=> Prot_Spec
,
3193 Handled_Statement_Sequence
=>
3194 Make_Handled_Sequence_Of_Statements
(Loc
,
3195 Statements
=> New_List
(Stmt
)));
3196 end Build_Lock_Free_Protected_Subprogram_Body
;
3198 -------------------------------------------------
3199 -- Build_Lock_Free_Unprotected_Subprogram_Body --
3200 -------------------------------------------------
3202 -- Procedures which meet the lock-free implementation requirements and
3203 -- reference a unique scalar component Comp are expanded in the following
3206 -- procedure P (...) is
3207 -- Expected_Comp : constant Comp_Type :=
3209 -- (System.Atomic_Primitives.Lock_Free_Read_N
3210 -- (_Object.Comp'Address));
3214 -- <original declarations before the object renaming declaration
3217 -- Desired_Comp : Comp_Type := Expected_Comp;
3218 -- Comp : Comp_Type renames Desired_Comp;
3220 -- <original delarations after the object renaming declaration
3224 -- <original statements>
3225 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3226 -- (_Object.Comp'Address,
3227 -- Interfaces.Unsigned_N (Expected_Comp),
3228 -- Interfaces.Unsigned_N (Desired_Comp));
3233 -- Each return and raise statement of P is transformed into an atomic
3236 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3237 -- (_Object.Comp'Address,
3238 -- Interfaces.Unsigned_N (Expected_Comp),
3239 -- Interfaces.Unsigned_N (Desired_Comp));
3241 -- <original statement>
3246 -- Functions which meet the lock-free implementation requirements and
3247 -- reference a unique scalar component Comp are expanded in the following
3250 -- function F (...) return ... is
3251 -- <original declarations before the object renaming declaration
3254 -- Expected_Comp : constant Comp_Type :=
3256 -- (System.Atomic_Primitives.Lock_Free_Read_N
3257 -- (_Object.Comp'Address));
3258 -- Comp : Comp_Type renames Expected_Comp;
3260 -- <original delarations after the object renaming declaration of
3264 -- <original statements>
3267 function Build_Lock_Free_Unprotected_Subprogram_Body
3269 Prot_Typ
: Node_Id
) return Node_Id
3271 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
3272 -- Subprograms which meet the lock-free implementation criteria are
3273 -- allowed to reference only one unique component. Return the prival
3274 -- of the said component.
3276 --------------------------
3277 -- Referenced_Component --
3278 --------------------------
3280 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
3283 Source_Comp
: Entity_Id
:= Empty
;
3286 -- Find the unique source component which N references in its
3289 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
3291 Element
: Lock_Free_Subprogram
renames
3292 Lock_Free_Subprogram_Table
.Table
(Index
);
3294 if Element
.Sub_Body
= N
then
3295 Source_Comp
:= Element
.Comp_Id
;
3301 if No
(Source_Comp
) then
3305 -- Find the prival which corresponds to the source component within
3306 -- the declarations of N.
3308 Decl
:= First
(Declarations
(N
));
3309 while Present
(Decl
) loop
3311 -- Privals appear as object renamings
3313 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
3314 Comp
:= Defining_Identifier
(Decl
);
3316 if Present
(Prival_Link
(Comp
))
3317 and then Prival_Link
(Comp
) = Source_Comp
3327 end Referenced_Component
;
3331 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
3332 Loc
: constant Source_Ptr
:= Sloc
(N
);
3333 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
3334 Decls
: List_Id
:= Declarations
(N
);
3336 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
3339 -- Add renamings for the protection object, discriminals, privals, and
3340 -- the entry index constant for use by debugger.
3342 Debug_Private_Data_Declarations
(Decls
);
3344 -- Perform the lock-free expansion when the subprogram references a
3345 -- protected component.
3347 if Present
(Comp
) then
3348 Protected_Component_Ref
: declare
3349 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3350 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
3351 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
3353 Is_Procedure
: constant Boolean :=
3354 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
3355 -- Indicates if N is a protected procedure body
3357 Block_Decls
: List_Id
;
3358 Try_Write
: Entity_Id
;
3359 Desired_Comp
: Entity_Id
;
3362 Label_Id
: Entity_Id
:= Empty
;
3364 Expected_Comp
: Entity_Id
;
3367 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
3369 Unsigned
: Entity_Id
;
3371 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
3372 -- Transform a single node if it is a return statement, a raise
3373 -- statement or a reference to Comp.
3375 procedure Process_Stmts
(Stmts
: List_Id
);
3376 -- Given a statement sequence Stmts, wrap any return or raise
3377 -- statements in the following manner:
3379 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3380 -- (_Object.Comp'Address,
3381 -- Interfaces.Unsigned_N (Expected_Comp),
3382 -- Interfaces.Unsigned_N (Desired_Comp))
3393 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3395 procedure Wrap_Statement
(Stmt
: Node_Id
);
3396 -- Wrap an arbitrary statement inside an if statement where the
3397 -- condition does an atomic check on the state of the object.
3399 --------------------
3400 -- Wrap_Statement --
3401 --------------------
3403 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3405 -- The first time through, create the declaration of a label
3406 -- which is used to skip the remainder of source statements
3407 -- if the state of the object has changed.
3409 if No
(Label_Id
) then
3411 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3412 Set_Entity
(Label_Id
,
3413 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3417 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3418 -- (_Object.Comp'Address,
3419 -- Interfaces.Unsigned_N (Expected_Comp),
3420 -- Interfaces.Unsigned_N (Desired_Comp))
3428 Make_Implicit_If_Statement
(N
,
3430 Make_Function_Call
(Loc
,
3432 New_Occurrence_Of
(Try_Write
, Loc
),
3433 Parameter_Associations
=> New_List
(
3434 Make_Attribute_Reference
(Loc
,
3435 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3436 Attribute_Name
=> Name_Address
),
3438 Unchecked_Convert_To
(Unsigned
,
3439 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3441 Unchecked_Convert_To
(Unsigned
,
3442 New_Occurrence_Of
(Desired_Comp
, Loc
)))),
3444 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3446 Else_Statements
=> New_List
(
3447 Make_Goto_Statement
(Loc
,
3449 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3452 -- Start of processing for Process_Node
3455 -- Wrap each return and raise statement that appear inside a
3456 -- procedure. Skip the last return statement which is added by
3457 -- default since it is transformed into an exit statement.
3460 and then ((Nkind
(N
) = N_Simple_Return_Statement
3461 and then N
/= Last
(Stmts
))
3462 or else Nkind
(N
) = N_Extended_Return_Statement
3463 or else (Nkind_In
(N
, N_Raise_Constraint_Error
,
3464 N_Raise_Program_Error
,
3466 N_Raise_Storage_Error
)
3467 and then Comes_From_Source
(N
)))
3475 Set_Analyzed
(N
, False);
3480 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3486 procedure Process_Stmts
(Stmts
: List_Id
) is
3489 Stmt
:= First
(Stmts
);
3490 while Present
(Stmt
) loop
3491 Process_Nodes
(Stmt
);
3496 -- Start of processing for Protected_Component_Ref
3499 -- Get the type size
3501 if Known_Static_Esize
(Comp_Type
) then
3502 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3504 -- If the Esize (Object_Size) is unknown at compile time, look at
3505 -- the RM_Size (Value_Size) since it may have been set by an
3506 -- explicit representation clause.
3508 elsif Known_Static_RM_Size
(Comp_Type
) then
3509 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3511 -- Should not happen since this has already been checked in
3512 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3515 raise Program_Error
;
3518 -- Retrieve all relevant atomic routines and types
3522 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3523 Read
:= RTE
(RE_Lock_Free_Read_8
);
3524 Unsigned
:= RTE
(RE_Uint8
);
3527 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3528 Read
:= RTE
(RE_Lock_Free_Read_16
);
3529 Unsigned
:= RTE
(RE_Uint16
);
3532 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3533 Read
:= RTE
(RE_Lock_Free_Read_32
);
3534 Unsigned
:= RTE
(RE_Uint32
);
3537 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3538 Read
:= RTE
(RE_Lock_Free_Read_64
);
3539 Unsigned
:= RTE
(RE_Uint64
);
3542 raise Program_Error
;
3546 -- Expected_Comp : constant Comp_Type :=
3548 -- (System.Atomic_Primitives.Lock_Free_Read_N
3549 -- (_Object.Comp'Address));
3552 Make_Defining_Identifier
(Loc
,
3553 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3556 Make_Object_Declaration
(Loc
,
3557 Defining_Identifier
=> Expected_Comp
,
3558 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3559 Constant_Present
=> True,
3561 Unchecked_Convert_To
(Comp_Type
,
3562 Make_Function_Call
(Loc
,
3563 Name
=> New_Occurrence_Of
(Read
, Loc
),
3564 Parameter_Associations
=> New_List
(
3565 Make_Attribute_Reference
(Loc
,
3566 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3567 Attribute_Name
=> Name_Address
)))));
3569 -- Protected procedures
3571 if Is_Procedure
then
3572 -- Move the original declarations inside the generated block
3574 Block_Decls
:= Decls
;
3576 -- Reset the declarations list of the protected procedure to
3577 -- contain only Decl.
3579 Decls
:= New_List
(Decl
);
3582 -- Desired_Comp : Comp_Type := Expected_Comp;
3585 Make_Defining_Identifier
(Loc
,
3586 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3588 -- Insert the declarations of Expected_Comp and Desired_Comp in
3589 -- the block declarations right before the renaming of the
3590 -- protected component.
3592 Insert_Before
(Comp_Decl
,
3593 Make_Object_Declaration
(Loc
,
3594 Defining_Identifier
=> Desired_Comp
,
3595 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3597 New_Occurrence_Of
(Expected_Comp
, Loc
)));
3599 -- Protected function
3602 Desired_Comp
:= Expected_Comp
;
3604 -- Insert the declaration of Expected_Comp in the function
3605 -- declarations right before the renaming of the protected
3608 Insert_Before
(Comp_Decl
, Decl
);
3611 -- Rewrite the protected component renaming declaration to be a
3612 -- renaming of Desired_Comp.
3615 -- Comp : Comp_Type renames Desired_Comp;
3618 Make_Object_Renaming_Declaration
(Loc
,
3619 Defining_Identifier
=>
3620 Defining_Identifier
(Comp_Decl
),
3622 New_Occurrence_Of
(Comp_Type
, Loc
),
3624 New_Occurrence_Of
(Desired_Comp
, Loc
)));
3626 -- Wrap any return or raise statements in Stmts in same the manner
3627 -- described in Process_Stmts.
3629 Process_Stmts
(Stmts
);
3632 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3633 -- (_Object.Comp'Address,
3634 -- Interfaces.Unsigned_N (Expected_Comp),
3635 -- Interfaces.Unsigned_N (Desired_Comp))
3637 if Is_Procedure
then
3639 Make_Exit_Statement
(Loc
,
3641 Make_Function_Call
(Loc
,
3643 New_Occurrence_Of
(Try_Write
, Loc
),
3644 Parameter_Associations
=> New_List
(
3645 Make_Attribute_Reference
(Loc
,
3646 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3647 Attribute_Name
=> Name_Address
),
3649 Unchecked_Convert_To
(Unsigned
,
3650 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3652 Unchecked_Convert_To
(Unsigned
,
3653 New_Occurrence_Of
(Desired_Comp
, Loc
)))));
3655 -- Small optimization: transform the default return statement
3656 -- of a procedure into the atomic exit statement.
3658 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3659 Rewrite
(Last
(Stmts
), Stmt
);
3661 Append_To
(Stmts
, Stmt
);
3665 -- Create the declaration of the label used to skip the rest of
3666 -- the source statements when the object state changes.
3668 if Present
(Label_Id
) then
3669 Label
:= Make_Label
(Loc
, Label_Id
);
3671 Make_Implicit_Label_Declaration
(Loc
,
3672 Defining_Identifier
=> Entity
(Label_Id
),
3673 Label_Construct
=> Label
));
3674 Append_To
(Stmts
, Label
);
3686 if Is_Procedure
then
3689 Make_Loop_Statement
(Loc
,
3690 Statements
=> New_List
(
3691 Make_Block_Statement
(Loc
,
3692 Declarations
=> Block_Decls
,
3693 Handled_Statement_Sequence
=>
3694 Make_Handled_Sequence_Of_Statements
(Loc
,
3695 Statements
=> Stmts
))),
3696 End_Label
=> Empty
));
3700 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3701 end Protected_Component_Ref
;
3704 -- Make an unprotected version of the subprogram for use within the same
3705 -- object, with new name and extra parameter representing the object.
3708 Make_Subprogram_Body
(Loc
,
3710 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3711 Declarations
=> Decls
,
3712 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3713 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3715 -------------------------
3716 -- Build_Master_Entity --
3717 -------------------------
3719 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3720 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3722 Context_Id
: Entity_Id
;
3728 if Is_Itype
(Obj_Or_Typ
) then
3729 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3731 Par
:= Parent
(Obj_Or_Typ
);
3734 -- When creating a master for a record component which is either a task
3735 -- or access-to-task, the enclosing record is the master scope and the
3736 -- proper insertion point is the component list.
3738 if Is_Record_Type
(Current_Scope
) then
3740 Context_Id
:= Current_Scope
;
3741 Decls
:= List_Containing
(Context
);
3743 -- Default case for object declarations and access types. Note that the
3744 -- context is updated to the nearest enclosing body, block, package, or
3745 -- return statement.
3748 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3751 -- Do not create a master if one already exists or there is no task
3754 if Has_Master_Entity
(Context_Id
)
3755 or else Restriction_Active
(No_Task_Hierarchy
)
3760 -- Create a master, generate:
3761 -- _Master : constant Master_Id := Current_Master.all;
3764 Make_Object_Declaration
(Loc
,
3765 Defining_Identifier
=>
3766 Make_Defining_Identifier
(Loc
, Name_uMaster
),
3767 Constant_Present
=> True,
3768 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3770 Make_Explicit_Dereference
(Loc
,
3771 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
3773 -- The master is inserted at the start of the declarative list of the
3776 Prepend_To
(Decls
, Decl
);
3778 -- In certain cases where transient scopes are involved, the immediate
3779 -- scope is not always the proper master scope. Ensure that the master
3780 -- declaration and entity appear in the same context.
3782 if Context_Id
/= Current_Scope
then
3783 Push_Scope
(Context_Id
);
3790 -- Mark the enclosing scope and its associated construct as being task
3793 Set_Has_Master_Entity
(Context_Id
);
3795 while Present
(Context
)
3796 and then Nkind
(Context
) /= N_Compilation_Unit
3798 if Nkind_In
(Context
, N_Block_Statement
,
3802 Set_Is_Task_Master
(Context
);
3805 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3806 Context
:= Corresponding_Stub
(Parent
(Context
));
3809 Context
:= Parent
(Context
);
3811 end Build_Master_Entity
;
3813 ---------------------------
3814 -- Build_Master_Renaming --
3815 ---------------------------
3817 procedure Build_Master_Renaming
3818 (Ptr_Typ
: Entity_Id
;
3819 Ins_Nod
: Node_Id
:= Empty
)
3821 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3823 Master_Decl
: Node_Id
;
3824 Master_Id
: Entity_Id
;
3827 -- Nothing to do if there is no task hierarchy
3829 if Restriction_Active
(No_Task_Hierarchy
) then
3833 -- Determine the proper context to insert the master renaming
3835 if Present
(Ins_Nod
) then
3837 elsif Is_Itype
(Ptr_Typ
) then
3838 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3840 Context
:= Parent
(Ptr_Typ
);
3844 -- <Ptr_Typ>M : Master_Id renames _Master;
3847 Make_Defining_Identifier
(Loc
,
3848 New_External_Name
(Chars
(Ptr_Typ
), 'M'));
3851 Make_Object_Renaming_Declaration
(Loc
,
3852 Defining_Identifier
=> Master_Id
,
3853 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3854 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3856 Insert_Action
(Context
, Master_Decl
);
3858 -- The renamed master now services the access type
3860 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3861 end Build_Master_Renaming
;
3863 -----------------------------------------
3864 -- Build_Private_Protected_Declaration --
3865 -----------------------------------------
3867 function Build_Private_Protected_Declaration
3868 (N
: Node_Id
) return Entity_Id
3870 Loc
: constant Source_Ptr
:= Sloc
(N
);
3871 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3876 Spec_Id
: Entity_Id
;
3879 Formal
:= First_Formal
(Body_Id
);
3881 -- The protected operation always has at least one formal, namely the
3882 -- object itself, but it is only placed in the parameter list if
3883 -- expansion is enabled.
3885 if Present
(Formal
) or else Expander_Active
then
3886 Plist
:= Copy_Parameter_List
(Body_Id
);
3891 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
3893 Make_Procedure_Specification
(Loc
,
3894 Defining_Unit_Name
=>
3895 Make_Defining_Identifier
(Sloc
(Body_Id
),
3896 Chars
=> Chars
(Body_Id
)),
3897 Parameter_Specifications
=>
3901 Make_Function_Specification
(Loc
,
3902 Defining_Unit_Name
=>
3903 Make_Defining_Identifier
(Sloc
(Body_Id
),
3904 Chars
=> Chars
(Body_Id
)),
3905 Parameter_Specifications
=> Plist
,
3906 Result_Definition
=>
3907 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
3910 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> New_Spec
);
3911 Insert_Before
(N
, Decl
);
3912 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
3914 -- Indicate that the entity comes from source, to ensure that cross-
3915 -- reference information is properly generated. The body itself is
3916 -- rewritten during expansion, and the body entity will not appear in
3917 -- calls to the operation.
3919 Set_Comes_From_Source
(Spec_Id
, True);
3921 Set_Has_Completion
(Spec_Id
);
3922 Set_Convention
(Spec_Id
, Convention_Protected
);
3924 end Build_Private_Protected_Declaration
;
3926 ---------------------------
3927 -- Build_Protected_Entry --
3928 ---------------------------
3930 function Build_Protected_Entry
3933 Pid
: Node_Id
) return Node_Id
3935 Bod_Decls
: constant List_Id
:= New_List
;
3936 Decls
: constant List_Id
:= Declarations
(N
);
3937 End_Lab
: constant Node_Id
:=
3938 End_Label
(Handled_Statement_Sequence
(N
));
3939 End_Loc
: constant Source_Ptr
:=
3940 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3941 -- Used for the generated call to Complete_Entry_Body
3943 Loc
: constant Source_Ptr
:= Sloc
(N
);
3947 Bod_Stmts
: List_Id
;
3951 EH_Loc
: Source_Ptr
;
3952 -- Used for the exception handler, inserted at end of the body
3955 -- Set the source location on the exception handler only when debugging
3956 -- the expanded code (see Make_Implicit_Exception_Handler).
3958 if Debug_Generated_Code
then
3961 -- Otherwise the inserted code should not be visible to the debugger
3964 EH_Loc
:= No_Location
;
3968 Make_Defining_Identifier
(Loc
,
3969 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3970 Bod_Spec
:= Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Empty
);
3972 -- Add the following declarations:
3974 -- type poVP is access poV;
3975 -- _object : poVP := poVP (_O);
3977 -- where _O is the formal parameter associated with the concurrent
3978 -- object. These declarations are needed for Complete_Entry_Body.
3980 Add_Object_Pointer
(Loc
, Pid
, Bod_Decls
);
3982 -- Add renamings for all formals, the Protection object, discriminals,
3983 -- privals and the entry index constant for use by debugger.
3985 Add_Formal_Renamings
(Bod_Spec
, Bod_Decls
, Ent
, Loc
);
3986 Debug_Private_Data_Declarations
(Decls
);
3988 -- Put the declarations and the statements from the entry
3992 Make_Block_Statement
(Loc
,
3993 Declarations
=> Decls
,
3994 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
)));
3996 case Corresponding_Runtime_Package
(Pid
) is
3997 when System_Tasking_Protected_Objects_Entries
=>
3998 Append_To
(Bod_Stmts
,
3999 Make_Procedure_Call_Statement
(End_Loc
,
4001 New_Occurrence_Of
(RTE
(RE_Complete_Entry_Body
), Loc
),
4002 Parameter_Associations
=> New_List
(
4003 Make_Attribute_Reference
(End_Loc
,
4005 Make_Selected_Component
(End_Loc
,
4007 Make_Identifier
(End_Loc
, Name_uObject
),
4009 Make_Identifier
(End_Loc
, Name_uObject
)),
4010 Attribute_Name
=> Name_Unchecked_Access
))));
4012 when System_Tasking_Protected_Objects_Single_Entry
=>
4014 -- Historically, a call to Complete_Single_Entry_Body was
4015 -- inserted, but it was a null procedure.
4020 raise Program_Error
;
4023 -- When exceptions can not be propagated, we never need to call
4024 -- Exception_Complete_Entry_Body.
4026 if No_Exception_Handlers_Set
then
4028 Make_Subprogram_Body
(Loc
,
4029 Specification
=> Bod_Spec
,
4030 Declarations
=> Bod_Decls
,
4031 Handled_Statement_Sequence
=>
4032 Make_Handled_Sequence_Of_Statements
(Loc
,
4033 Statements
=> Bod_Stmts
,
4034 End_Label
=> End_Lab
));
4037 Ohandle
:= Make_Others_Choice
(Loc
);
4038 Set_All_Others
(Ohandle
);
4040 case Corresponding_Runtime_Package
(Pid
) is
4041 when System_Tasking_Protected_Objects_Entries
=>
4044 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
4046 when System_Tasking_Protected_Objects_Single_Entry
=>
4049 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
4052 raise Program_Error
;
4055 -- Establish link between subprogram body entity and source entry
4057 Set_Corresponding_Protected_Entry
(Bod_Id
, Ent
);
4059 -- Create body of entry procedure. The renaming declarations are
4060 -- placed ahead of the block that contains the actual entry body.
4063 Make_Subprogram_Body
(Loc
,
4064 Specification
=> Bod_Spec
,
4065 Declarations
=> Bod_Decls
,
4066 Handled_Statement_Sequence
=>
4067 Make_Handled_Sequence_Of_Statements
(Loc
,
4068 Statements
=> Bod_Stmts
,
4069 End_Label
=> End_Lab
,
4070 Exception_Handlers
=> New_List
(
4071 Make_Implicit_Exception_Handler
(EH_Loc
,
4072 Exception_Choices
=> New_List
(Ohandle
),
4074 Statements
=> New_List
(
4075 Make_Procedure_Call_Statement
(EH_Loc
,
4077 Parameter_Associations
=> New_List
(
4078 Make_Attribute_Reference
(EH_Loc
,
4080 Make_Selected_Component
(EH_Loc
,
4082 Make_Identifier
(EH_Loc
, Name_uObject
),
4084 Make_Identifier
(EH_Loc
, Name_uObject
)),
4085 Attribute_Name
=> Name_Unchecked_Access
),
4087 Make_Function_Call
(EH_Loc
,
4090 (RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
4092 end Build_Protected_Entry
;
4094 -----------------------------------------
4095 -- Build_Protected_Entry_Specification --
4096 -----------------------------------------
4098 function Build_Protected_Entry_Specification
4101 Ent_Id
: Entity_Id
) return Node_Id
4103 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4106 Set_Debug_Info_Needed
(Def_Id
);
4108 if Present
(Ent_Id
) then
4109 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
4113 Make_Procedure_Specification
(Loc
,
4114 Defining_Unit_Name
=> Def_Id
,
4115 Parameter_Specifications
=> New_List
(
4116 Make_Parameter_Specification
(Loc
,
4117 Defining_Identifier
=>
4118 Make_Defining_Identifier
(Loc
, Name_uO
),
4120 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
4122 Make_Parameter_Specification
(Loc
,
4123 Defining_Identifier
=> P
,
4125 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
4127 Make_Parameter_Specification
(Loc
,
4128 Defining_Identifier
=>
4129 Make_Defining_Identifier
(Loc
, Name_uE
),
4131 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))));
4132 end Build_Protected_Entry_Specification
;
4134 --------------------------
4135 -- Build_Protected_Spec --
4136 --------------------------
4138 function Build_Protected_Spec
4140 Obj_Type
: Entity_Id
;
4142 Unprotected
: Boolean := False) return List_Id
4144 Loc
: constant Source_Ptr
:= Sloc
(N
);
4147 New_Plist
: List_Id
;
4148 New_Param
: Node_Id
;
4151 New_Plist
:= New_List
;
4153 Formal
:= First_Formal
(Ident
);
4154 while Present
(Formal
) loop
4156 Make_Parameter_Specification
(Loc
,
4157 Defining_Identifier
=>
4158 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
4159 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
4160 In_Present
=> In_Present
(Parent
(Formal
)),
4161 Out_Present
=> Out_Present
(Parent
(Formal
)),
4162 Parameter_Type
=> New_Occurrence_Of
(Etype
(Formal
), Loc
));
4165 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
4168 Append
(New_Param
, New_Plist
);
4169 Next_Formal
(Formal
);
4172 -- If the subprogram is a procedure and the context is not an access
4173 -- to protected subprogram, the parameter is in-out. Otherwise it is
4177 Make_Parameter_Specification
(Loc
,
4178 Defining_Identifier
=>
4179 Make_Defining_Identifier
(Loc
, Name_uObject
),
4182 (Etype
(Ident
) = Standard_Void_Type
4183 and then not Is_RTE
(Obj_Type
, RE_Address
)),
4185 New_Occurrence_Of
(Obj_Type
, Loc
));
4186 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
4187 Prepend_To
(New_Plist
, Decl
);
4190 end Build_Protected_Spec
;
4192 ---------------------------------------
4193 -- Build_Protected_Sub_Specification --
4194 ---------------------------------------
4196 function Build_Protected_Sub_Specification
4198 Prot_Typ
: Entity_Id
;
4199 Mode
: Subprogram_Protection_Mode
) return Node_Id
4201 Loc
: constant Source_Ptr
:= Sloc
(N
);
4205 New_Plist
: List_Id
;
4208 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
4209 (Dispatching_Mode
=> ' ',
4210 Protected_Mode
=> 'P',
4211 Unprotected_Mode
=> 'N');
4214 if Ekind
(Defining_Unit_Name
(Specification
(N
))) =
4217 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
4222 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
4225 Build_Protected_Spec
4226 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
4227 Mode
= Unprotected_Mode
);
4229 Make_Defining_Identifier
(Loc
,
4230 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
4232 -- The unprotected operation carries the user code, and debugging
4233 -- information must be generated for it, even though this spec does
4234 -- not come from source. It is also convenient to allow gdb to step
4235 -- into the protected operation, even though it only contains lock/
4238 Set_Debug_Info_Needed
(New_Id
);
4240 -- If a pragma Eliminate applies to the source entity, the internal
4241 -- subprograms will be eliminated as well.
4243 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
4245 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
4247 Make_Procedure_Specification
(Loc
,
4248 Defining_Unit_Name
=> New_Id
,
4249 Parameter_Specifications
=> New_Plist
);
4251 -- Create a new specification for the anonymous subprogram type
4255 Make_Function_Specification
(Loc
,
4256 Defining_Unit_Name
=> New_Id
,
4257 Parameter_Specifications
=> New_Plist
,
4258 Result_Definition
=>
4259 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
4261 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
4265 end Build_Protected_Sub_Specification
;
4267 -------------------------------------
4268 -- Build_Protected_Subprogram_Body --
4269 -------------------------------------
4271 function Build_Protected_Subprogram_Body
4274 N_Op_Spec
: Node_Id
) return Node_Id
4276 Loc
: constant Source_Ptr
:= Sloc
(N
);
4278 P_Op_Spec
: Node_Id
;
4281 Unprot_Call
: Node_Id
;
4283 Lock_Name
: Node_Id
;
4284 Lock_Stmt
: Node_Id
;
4286 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
4287 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
4289 Object_Parm
: Node_Id
;
4294 Op_Spec
:= Specification
(N
);
4295 Exc_Safe
:= Is_Exception_Safe
(N
);
4298 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
4300 -- Build a list of the formal parameters of the protected version of
4301 -- the subprogram to use as the actual parameters of the unprotected
4304 Uactuals
:= New_List
;
4305 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
4306 while Present
(Pformal
) loop
4307 Append_To
(Uactuals
,
4308 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
4312 -- Make a call to the unprotected version of the subprogram built above
4313 -- for use by the protected version built below.
4315 if Nkind
(Op_Spec
) = N_Function_Specification
then
4317 R
:= Make_Temporary
(Loc
, 'R');
4320 Make_Object_Declaration
(Loc
,
4321 Defining_Identifier
=> R
,
4322 Constant_Present
=> True,
4323 Object_Definition
=>
4324 New_Copy
(Result_Definition
(N_Op_Spec
)),
4326 Make_Function_Call
(Loc
,
4328 Make_Identifier
(Loc
,
4329 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4330 Parameter_Associations
=> Uactuals
));
4333 Make_Simple_Return_Statement
(Loc
,
4334 Expression
=> New_Occurrence_Of
(R
, Loc
));
4338 Make_Simple_Return_Statement
(Loc
,
4340 Make_Function_Call
(Loc
,
4342 Make_Identifier
(Loc
,
4343 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4344 Parameter_Associations
=> Uactuals
));
4347 Lock_Kind
:= RE_Lock_Read_Only
;
4351 Make_Procedure_Call_Statement
(Loc
,
4353 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4354 Parameter_Associations
=> Uactuals
);
4356 Lock_Kind
:= RE_Lock
;
4359 -- Wrap call in block that will be covered by an at_end handler
4361 if not Exc_Safe
then
4363 Make_Block_Statement
(Loc
,
4364 Handled_Statement_Sequence
=>
4365 Make_Handled_Sequence_Of_Statements
(Loc
,
4366 Statements
=> New_List
(Unprot_Call
)));
4369 -- Make the protected subprogram body. This locks the protected
4370 -- object and calls the unprotected version of the subprogram.
4372 case Corresponding_Runtime_Package
(Pid
) is
4373 when System_Tasking_Protected_Objects_Entries
=>
4374 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entries
), Loc
);
4376 when System_Tasking_Protected_Objects_Single_Entry
=>
4377 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entry
), Loc
);
4379 when System_Tasking_Protected_Objects
=>
4380 Lock_Name
:= New_Occurrence_Of
(RTE
(Lock_Kind
), Loc
);
4383 raise Program_Error
;
4387 Make_Attribute_Reference
(Loc
,
4389 Make_Selected_Component
(Loc
,
4390 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4391 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4392 Attribute_Name
=> Name_Unchecked_Access
);
4395 Make_Procedure_Call_Statement
(Loc
,
4397 Parameter_Associations
=> New_List
(Object_Parm
));
4399 if Abort_Allowed
then
4401 Build_Runtime_Call
(Loc
, RE_Abort_Defer
),
4405 Stmts
:= New_List
(Lock_Stmt
);
4408 if not Exc_Safe
then
4409 Append
(Unprot_Call
, Stmts
);
4411 if Nkind
(Op_Spec
) = N_Function_Specification
then
4413 Stmts
:= Empty_List
;
4415 Append
(Unprot_Call
, Stmts
);
4418 -- Historical note: Previously, call to the cleanup was inserted
4419 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4420 -- which is also shared by the 'not Exc_Safe' path.
4422 Build_Protected_Subprogram_Call_Cleanup
(Op_Spec
, Pid
, Loc
, Stmts
);
4424 if Nkind
(Op_Spec
) = N_Function_Specification
then
4425 Append_To
(Stmts
, Return_Stmt
);
4426 Append_To
(Pre_Stmts
,
4427 Make_Block_Statement
(Loc
,
4428 Declarations
=> New_List
(Unprot_Call
),
4429 Handled_Statement_Sequence
=>
4430 Make_Handled_Sequence_Of_Statements
(Loc
,
4431 Statements
=> Stmts
)));
4437 Make_Subprogram_Body
(Loc
,
4438 Declarations
=> Empty_List
,
4439 Specification
=> P_Op_Spec
,
4440 Handled_Statement_Sequence
=>
4441 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4443 -- Mark this subprogram as a protected subprogram body so that the
4444 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4445 -- path as otherwise the cleanup has already been inserted.
4447 if not Exc_Safe
then
4448 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4452 end Build_Protected_Subprogram_Body
;
4454 -------------------------------------
4455 -- Build_Protected_Subprogram_Call --
4456 -------------------------------------
4458 procedure Build_Protected_Subprogram_Call
4462 External
: Boolean := True)
4464 Loc
: constant Source_Ptr
:= Sloc
(N
);
4465 Sub
: constant Entity_Id
:= Entity
(Name
);
4471 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4474 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4477 if Present
(Parameter_Associations
(N
)) then
4478 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4483 -- If the type is an untagged derived type, convert to the root type,
4484 -- which is the one on which the operations are defined.
4486 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4487 and then not Is_Tagged_Type
(Etype
(Rec
))
4488 and then Is_Derived_Type
(Etype
(Rec
))
4490 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4491 Set_Subtype_Mark
(Rec
,
4492 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4495 Prepend
(Rec
, Params
);
4497 if Ekind
(Sub
) = E_Procedure
then
4499 Make_Procedure_Call_Statement
(Loc
,
4501 Parameter_Associations
=> Params
));
4504 pragma Assert
(Ekind
(Sub
) = E_Function
);
4506 Make_Function_Call
(Loc
,
4508 Parameter_Associations
=> Params
));
4510 -- Preserve type of call for subsequent processing (required for
4511 -- call to Wrap_Transient_Expression in the case of a shared passive
4514 Set_Etype
(N
, Etype
(New_Sub
));
4518 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
4519 and then Is_Entity_Name
(Expression
(Rec
))
4520 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
4522 Add_Shared_Var_Lock_Procs
(N
);
4524 end Build_Protected_Subprogram_Call
;
4526 ---------------------------------------------
4527 -- Build_Protected_Subprogram_Call_Cleanup --
4528 ---------------------------------------------
4530 procedure Build_Protected_Subprogram_Call_Cleanup
4539 -- If the associated protected object has entries, a protected
4540 -- procedure has to service entry queues. In this case generate:
4542 -- Service_Entries (_object._object'Access);
4544 if Nkind
(Op_Spec
) = N_Procedure_Specification
4545 and then Has_Entries
(Conc_Typ
)
4547 case Corresponding_Runtime_Package
(Conc_Typ
) is
4548 when System_Tasking_Protected_Objects_Entries
=>
4549 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entries
), Loc
);
4551 when System_Tasking_Protected_Objects_Single_Entry
=>
4552 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entry
), Loc
);
4555 raise Program_Error
;
4559 Make_Procedure_Call_Statement
(Loc
,
4561 Parameter_Associations
=> New_List
(
4562 Make_Attribute_Reference
(Loc
,
4564 Make_Selected_Component
(Loc
,
4565 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4566 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4567 Attribute_Name
=> Name_Unchecked_Access
))));
4571 -- Unlock (_object._object'Access);
4573 case Corresponding_Runtime_Package
(Conc_Typ
) is
4574 when System_Tasking_Protected_Objects_Entries
=>
4575 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entries
), Loc
);
4577 when System_Tasking_Protected_Objects_Single_Entry
=>
4578 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entry
), Loc
);
4580 when System_Tasking_Protected_Objects
=>
4581 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock
), Loc
);
4584 raise Program_Error
;
4588 Make_Procedure_Call_Statement
(Loc
,
4590 Parameter_Associations
=> New_List
(
4591 Make_Attribute_Reference
(Loc
,
4593 Make_Selected_Component
(Loc
,
4594 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4595 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4596 Attribute_Name
=> Name_Unchecked_Access
))));
4602 if Abort_Allowed
then
4603 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
4605 end Build_Protected_Subprogram_Call_Cleanup
;
4607 -------------------------
4608 -- Build_Selected_Name --
4609 -------------------------
4611 function Build_Selected_Name
4612 (Prefix
: Entity_Id
;
4613 Selector
: Entity_Id
;
4614 Append_Char
: Character := ' ') return Name_Id
4616 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4617 Select_Len
: Natural;
4620 Get_Name_String
(Chars
(Selector
));
4621 Select_Len
:= Name_Len
;
4622 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4623 Get_Name_String
(Chars
(Prefix
));
4625 -- If scope is anonymous type, discard suffix to recover name of
4626 -- single protected object. Otherwise use protected type name.
4628 if Name_Buffer
(Name_Len
) = 'T' then
4629 Name_Len
:= Name_Len
- 1;
4632 Add_Str_To_Name_Buffer
("__");
4633 for J
in 1 .. Select_Len
loop
4634 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4637 -- Now add the Append_Char if specified. The encoding to follow
4638 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4639 -- then the entity is associated to a protected type subprogram.
4640 -- Otherwise, it is a protected type entry. For each case, the
4641 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4643 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4645 if Append_Char
/= ' ' then
4646 if Append_Char
= 'P' or Append_Char
= 'N' then
4647 Add_Char_To_Name_Buffer
(Append_Char
);
4650 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4651 return New_External_Name
(Name_Find
, ' ', -1);
4656 end Build_Selected_Name
;
4658 -----------------------------
4659 -- Build_Simple_Entry_Call --
4660 -----------------------------
4662 -- A task entry call is converted to a call to Call_Simple
4665 -- P : parms := (parm, parm, parm);
4667 -- Call_Simple (acceptor-task, entry-index, P'Address);
4673 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4674 -- the parameters, and the constructed aggregate value contains either the
4675 -- parameters or, in the case of non-elementary types, references to these
4676 -- parameters. Then the address of this aggregate is passed to the runtime
4677 -- routine, along with the task id value and the task entry index value.
4678 -- Pnn is only required if parameters are present.
4680 -- The assignments after the call are present only in the case of in-out
4681 -- or out parameters for elementary types, and are used to assign back the
4682 -- resulting values of such parameters.
4684 -- Note: the reason that we insert a block here is that in the context
4685 -- of selects, conditional entry calls etc. the entry call statement
4686 -- appears on its own, not as an element of a list.
4688 -- A protected entry call is converted to a Protected_Entry_Call:
4691 -- P : E1_Params := (param, param, param);
4693 -- Bnn : Communications_Block;
4696 -- P : E1_Params := (param, param, param);
4697 -- Bnn : Communications_Block;
4700 -- Protected_Entry_Call (
4701 -- Object => po._object'Access,
4702 -- E => <entry index>;
4703 -- Uninterpreted_Data => P'Address;
4704 -- Mode => Simple_Call;
4711 procedure Build_Simple_Entry_Call
4720 -- If call has been inlined, nothing left to do
4722 if Nkind
(N
) = N_Block_Statement
then
4726 -- Convert entry call to Call_Simple call
4729 Loc
: constant Source_Ptr
:= Sloc
(N
);
4730 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4731 Stats
: constant List_Id
:= New_List
;
4734 Comm_Name
: Entity_Id
;
4738 Ent_Acc
: Entity_Id
;
4740 Iface_Tag
: Entity_Id
;
4741 Iface_Typ
: Entity_Id
;
4754 -- Simple entry and entry family cases merge here
4756 Ent
:= Entity
(Ename
);
4757 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4758 Conctyp
:= Etype
(Concval
);
4760 -- If prefix is an access type, dereference to obtain the task type
4762 if Is_Access_Type
(Conctyp
) then
4763 Conctyp
:= Designated_Type
(Conctyp
);
4766 -- Special case for protected subprogram calls
4768 if Is_Protected_Type
(Conctyp
)
4769 and then Is_Subprogram
(Entity
(Ename
))
4771 if not Is_Eliminated
(Entity
(Ename
)) then
4772 Build_Protected_Subprogram_Call
4773 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4780 -- First parameter is the Task_Id value from the task value or the
4781 -- Object from the protected object value, obtained by selecting
4782 -- the _Task_Id or _Object from the result of doing an unchecked
4783 -- conversion to convert the value to the corresponding record type.
4785 if Nkind
(Concval
) = N_Function_Call
4786 and then Is_Task_Type
(Conctyp
)
4787 and then Ada_Version
>= Ada_2005
4790 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4791 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4796 Make_Object_Declaration
(Loc
,
4797 Defining_Identifier
=> Obj
,
4798 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4799 Expression
=> ExpR
);
4800 Set_Etype
(Obj
, Conctyp
);
4801 Decls
:= New_List
(Decl
);
4802 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4809 Parm1
:= Concurrent_Ref
(Concval
);
4811 -- Second parameter is the entry index, computed by the routine
4812 -- provided for this purpose. The value of this expression is
4813 -- assigned to an intermediate variable to assure that any entry
4814 -- family index expressions are evaluated before the entry
4817 if not Is_Protected_Type
(Conctyp
)
4819 Corresponding_Runtime_Package
(Conctyp
) =
4820 System_Tasking_Protected_Objects_Entries
4822 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4825 Make_Object_Declaration
(Loc
,
4826 Defining_Identifier
=> X
,
4827 Object_Definition
=>
4828 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
4829 Expression
=> Actual_Index_Expression
(
4830 Loc
, Entity
(Ename
), Index
, Concval
));
4832 Append_To
(Decls
, Xdecl
);
4833 Parm2
:= New_Occurrence_Of
(X
, Loc
);
4840 -- The third parameter is the packaged parameters. If there are
4841 -- none, then it is just the null address, since nothing is passed.
4844 Parm3
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
4847 -- Case of parameters present, where third argument is the address
4848 -- of a packaged record containing the required parameter values.
4851 -- First build a list of parameter values, which are references to
4852 -- objects of the parameter types.
4856 Actual
:= First_Actual
(N
);
4857 Formal
:= First_Formal
(Ent
);
4858 while Present
(Actual
) loop
4860 -- If it is a by-copy type, copy it to a new variable. The
4861 -- packaged record has a field that points to this variable.
4863 if Is_By_Copy_Type
(Etype
(Actual
)) then
4865 Make_Object_Declaration
(Loc
,
4866 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4867 Aliased_Present
=> True,
4868 Object_Definition
=>
4869 New_Occurrence_Of
(Etype
(Formal
), Loc
));
4871 -- Mark the object as not needing initialization since the
4872 -- initialization is performed separately, avoiding errors
4873 -- on cases such as formals of null-excluding access types.
4875 Set_No_Initialization
(N_Node
);
4877 -- We must make a separate assignment statement for the
4878 -- case of limited types. We cannot assign it unless the
4879 -- Assignment_OK flag is set first. An out formal of an
4880 -- access type or whose type has a Default_Value must also
4881 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4882 -- but no constraint, predicate, or null-exclusion check is
4883 -- applied before the call.
4885 if Ekind
(Formal
) /= E_Out_Parameter
4886 or else Is_Access_Type
(Etype
(Formal
))
4888 (Is_Scalar_Type
(Etype
(Formal
))
4890 Present
(Default_Aspect_Value
(Etype
(Formal
))))
4893 New_Occurrence_Of
(Defining_Identifier
(N_Node
), Loc
);
4894 Set_Assignment_OK
(N_Var
);
4896 Make_Assignment_Statement
(Loc
,
4898 Expression
=> Relocate_Node
(Actual
)));
4900 -- Mark the object as internal, so we don't later reset
4901 -- No_Initialization flag in Default_Initialize_Object,
4902 -- which would lead to needless default initialization.
4903 -- We don't set this outside the if statement, because
4904 -- out scalar parameters without Default_Value do require
4905 -- default initialization if Initialize_Scalars applies.
4907 Set_Is_Internal
(Defining_Identifier
(N_Node
));
4909 -- If actual is an out parameter of a null-excluding
4910 -- access type, there is access check on entry, so set
4911 -- Suppress_Assignment_Checks on the generated statement
4912 -- that assigns the actual to the parameter block
4914 Set_Suppress_Assignment_Checks
(Last
(Stats
));
4917 Append
(N_Node
, Decls
);
4920 Make_Attribute_Reference
(Loc
,
4921 Attribute_Name
=> Name_Unchecked_Access
,
4924 (Defining_Identifier
(N_Node
), Loc
)));
4927 -- Interface class-wide formal
4929 if Ada_Version
>= Ada_2005
4930 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4931 and then Is_Interface
(Etype
(Formal
))
4933 Iface_Typ
:= Etype
(Etype
(Formal
));
4936 -- formal_iface_type! (actual.iface_tag)'reference
4939 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4940 pragma Assert
(Present
(Iface_Tag
));
4943 Make_Reference
(Loc
,
4944 Unchecked_Convert_To
(Iface_Typ
,
4945 Make_Selected_Component
(Loc
,
4947 Relocate_Node
(Actual
),
4949 New_Occurrence_Of
(Iface_Tag
, Loc
)))));
4955 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4959 Next_Actual
(Actual
);
4960 Next_Formal_With_Extras
(Formal
);
4963 -- Now build the declaration of parameters initialized with the
4964 -- aggregate containing this constructed parameter list.
4966 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4969 Make_Object_Declaration
(Loc
,
4970 Defining_Identifier
=> P
,
4971 Object_Definition
=>
4972 New_Occurrence_Of
(Designated_Type
(Ent_Acc
), Loc
),
4974 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4977 Make_Attribute_Reference
(Loc
,
4978 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4979 Attribute_Name
=> Name_Address
);
4981 Append
(Pdecl
, Decls
);
4984 -- Now we can create the call, case of protected type
4986 if Is_Protected_Type
(Conctyp
) then
4987 case Corresponding_Runtime_Package
(Conctyp
) is
4988 when System_Tasking_Protected_Objects_Entries
=>
4990 -- Change the type of the index declaration
4992 Set_Object_Definition
(Xdecl
,
4993 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
));
4995 -- Some additional declarations for protected entry calls
5001 -- Bnn : Communications_Block;
5003 Comm_Name
:= Make_Temporary
(Loc
, 'B');
5006 Make_Object_Declaration
(Loc
,
5007 Defining_Identifier
=> Comm_Name
,
5008 Object_Definition
=>
5010 (RTE
(RE_Communication_Block
), Loc
)));
5012 -- Some additional statements for protected entry calls
5014 -- Protected_Entry_Call (
5015 -- Object => po._object'Access,
5016 -- E => <entry index>;
5017 -- Uninterpreted_Data => P'Address;
5018 -- Mode => Simple_Call;
5022 Make_Procedure_Call_Statement
(Loc
,
5024 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
5026 Parameter_Associations
=> New_List
(
5027 Make_Attribute_Reference
(Loc
,
5028 Attribute_Name
=> Name_Unchecked_Access
,
5032 New_Occurrence_Of
(RTE
(RE_Simple_Call
), Loc
),
5033 New_Occurrence_Of
(Comm_Name
, Loc
)));
5035 when System_Tasking_Protected_Objects_Single_Entry
=>
5036 -- Protected_Single_Entry_Call (
5037 -- Object => po._object'Access,
5038 -- Uninterpreted_Data => P'Address);
5041 Make_Procedure_Call_Statement
(Loc
,
5044 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
5046 Parameter_Associations
=> New_List
(
5047 Make_Attribute_Reference
(Loc
,
5048 Attribute_Name
=> Name_Unchecked_Access
,
5053 raise Program_Error
;
5056 -- Case of task type
5060 Make_Procedure_Call_Statement
(Loc
,
5062 New_Occurrence_Of
(RTE
(RE_Call_Simple
), Loc
),
5063 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
5067 Append_To
(Stats
, Call
);
5069 -- If there are out or in/out parameters by copy add assignment
5070 -- statements for the result values.
5072 if Present
(Parms
) then
5073 Actual
:= First_Actual
(N
);
5074 Formal
:= First_Formal
(Ent
);
5076 Set_Assignment_OK
(Actual
);
5077 while Present
(Actual
) loop
5078 if Is_By_Copy_Type
(Etype
(Actual
))
5079 and then Ekind
(Formal
) /= E_In_Parameter
5082 Make_Assignment_Statement
(Loc
,
5083 Name
=> New_Copy
(Actual
),
5085 Make_Explicit_Dereference
(Loc
,
5086 Make_Selected_Component
(Loc
,
5087 Prefix
=> New_Occurrence_Of
(P
, Loc
),
5089 Make_Identifier
(Loc
, Chars
(Formal
)))));
5091 -- In all cases (including limited private types) we want
5092 -- the assignment to be valid.
5094 Set_Assignment_OK
(Name
(N_Node
));
5096 -- If the call is the triggering alternative in an
5097 -- asynchronous select, or the entry_call alternative of a
5098 -- conditional entry call, the assignments for in-out
5099 -- parameters are incorporated into the statement list that
5100 -- follows, so that there are executed only if the entry
5103 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
5104 and then N
= Triggering_Statement
(Parent
(N
)))
5106 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
5107 and then N
= Entry_Call_Statement
(Parent
(N
)))
5109 if No
(Statements
(Parent
(N
))) then
5110 Set_Statements
(Parent
(N
), New_List
);
5113 Prepend
(N_Node
, Statements
(Parent
(N
)));
5116 Insert_After
(Call
, N_Node
);
5120 Next_Actual
(Actual
);
5121 Next_Formal_With_Extras
(Formal
);
5125 -- Finally, create block and analyze it
5128 Make_Block_Statement
(Loc
,
5129 Declarations
=> Decls
,
5130 Handled_Statement_Sequence
=>
5131 Make_Handled_Sequence_Of_Statements
(Loc
,
5132 Statements
=> Stats
)));
5136 end Build_Simple_Entry_Call
;
5138 --------------------------------
5139 -- Build_Task_Activation_Call --
5140 --------------------------------
5142 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
5143 Loc
: constant Source_Ptr
:= Sloc
(N
);
5150 -- For sequential elaboration policy, all the tasks will be activated at
5151 -- the end of the elaboration.
5153 if Partition_Elaboration_Policy
= 'S' then
5157 -- Get the activation chain entity. Except in the case of a package
5158 -- body, this is in the node that was passed. For a package body, we
5159 -- have to find the corresponding package declaration node.
5161 if Nkind
(N
) = N_Package_Body
then
5162 P
:= Corresponding_Spec
(N
);
5165 exit when Nkind
(P
) = N_Package_Declaration
;
5168 Chain
:= Activation_Chain_Entity
(P
);
5171 Chain
:= Activation_Chain_Entity
(N
);
5174 if Present
(Chain
) then
5175 if Restricted_Profile
then
5176 Name
:= New_Occurrence_Of
5177 (RTE
(RE_Activate_Restricted_Tasks
), Loc
);
5179 Name
:= New_Occurrence_Of
5180 (RTE
(RE_Activate_Tasks
), Loc
);
5184 Make_Procedure_Call_Statement
(Loc
,
5186 Parameter_Associations
=>
5187 New_List
(Make_Attribute_Reference
(Loc
,
5188 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5189 Attribute_Name
=> Name_Unchecked_Access
)));
5191 if Nkind
(N
) = N_Package_Declaration
then
5192 if Present
(Corresponding_Body
(N
)) then
5195 elsif Present
(Private_Declarations
(Specification
(N
))) then
5196 Append
(Call
, Private_Declarations
(Specification
(N
)));
5199 Append
(Call
, Visible_Declarations
(Specification
(N
)));
5203 if Present
(Handled_Statement_Sequence
(N
)) then
5205 -- The call goes at the start of the statement sequence after
5206 -- the start of exception range label if one is present.
5212 Stm
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
5214 -- A special case, skip exception range label if one is
5215 -- present (from front end zcx processing).
5217 if Nkind
(Stm
) = N_Label
and then Exception_Junk
(Stm
) then
5221 -- Another special case, if the first statement is a block
5222 -- from optimization of a local raise to a goto, then the
5223 -- call goes inside this block.
5225 if Nkind
(Stm
) = N_Block_Statement
5226 and then Exception_Junk
(Stm
)
5229 First
(Statements
(Handled_Statement_Sequence
(Stm
)));
5232 -- Insertion point is after any exception label pushes,
5233 -- since we want it covered by any local handlers.
5235 while Nkind
(Stm
) in N_Push_xxx_Label
loop
5239 -- Now we have the proper insertion point
5241 Insert_Before
(Stm
, Call
);
5245 Set_Handled_Statement_Sequence
(N
,
5246 Make_Handled_Sequence_Of_Statements
(Loc
,
5247 Statements
=> New_List
(Call
)));
5252 Check_Task_Activation
(N
);
5254 end Build_Task_Activation_Call
;
5256 -------------------------------
5257 -- Build_Task_Allocate_Block --
5258 -------------------------------
5260 procedure Build_Task_Allocate_Block
5265 T
: constant Entity_Id
:= Entity
(Expression
(N
));
5266 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
5267 Loc
: constant Source_Ptr
:= Sloc
(N
);
5268 Chain
: constant Entity_Id
:=
5269 Make_Defining_Identifier
(Loc
, Name_uChain
);
5270 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5275 Make_Block_Statement
(Loc
,
5276 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5277 Declarations
=> New_List
(
5279 -- _Chain : Activation_Chain;
5281 Make_Object_Declaration
(Loc
,
5282 Defining_Identifier
=> Chain
,
5283 Aliased_Present
=> True,
5284 Object_Definition
=>
5285 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5287 Handled_Statement_Sequence
=>
5288 Make_Handled_Sequence_Of_Statements
(Loc
,
5290 Statements
=> New_List
(
5294 Make_Procedure_Call_Statement
(Loc
,
5295 Name
=> New_Occurrence_Of
(Init
, Loc
),
5296 Parameter_Associations
=> Args
),
5298 -- Activate_Tasks (_Chain);
5300 Make_Procedure_Call_Statement
(Loc
,
5301 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5302 Parameter_Associations
=> New_List
(
5303 Make_Attribute_Reference
(Loc
,
5304 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5305 Attribute_Name
=> Name_Unchecked_Access
))))),
5307 Has_Created_Identifier
=> True,
5308 Is_Task_Allocation_Block
=> True);
5311 Make_Implicit_Label_Declaration
(Loc
,
5312 Defining_Identifier
=> Blkent
,
5313 Label_Construct
=> Block
));
5315 Append_To
(Actions
, Block
);
5317 Set_Activation_Chain_Entity
(Block
, Chain
);
5318 end Build_Task_Allocate_Block
;
5320 -----------------------------------------------
5321 -- Build_Task_Allocate_Block_With_Init_Stmts --
5322 -----------------------------------------------
5324 procedure Build_Task_Allocate_Block_With_Init_Stmts
5327 Init_Stmts
: List_Id
)
5329 Loc
: constant Source_Ptr
:= Sloc
(N
);
5330 Chain
: constant Entity_Id
:=
5331 Make_Defining_Identifier
(Loc
, Name_uChain
);
5332 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5336 Append_To
(Init_Stmts
,
5337 Make_Procedure_Call_Statement
(Loc
,
5338 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5339 Parameter_Associations
=> New_List
(
5340 Make_Attribute_Reference
(Loc
,
5341 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5342 Attribute_Name
=> Name_Unchecked_Access
))));
5345 Make_Block_Statement
(Loc
,
5346 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5347 Declarations
=> New_List
(
5349 -- _Chain : Activation_Chain;
5351 Make_Object_Declaration
(Loc
,
5352 Defining_Identifier
=> Chain
,
5353 Aliased_Present
=> True,
5354 Object_Definition
=>
5355 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5357 Handled_Statement_Sequence
=>
5358 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5360 Has_Created_Identifier
=> True,
5361 Is_Task_Allocation_Block
=> True);
5364 Make_Implicit_Label_Declaration
(Loc
,
5365 Defining_Identifier
=> Blkent
,
5366 Label_Construct
=> Block
));
5368 Append_To
(Actions
, Block
);
5370 Set_Activation_Chain_Entity
(Block
, Chain
);
5371 end Build_Task_Allocate_Block_With_Init_Stmts
;
5373 -----------------------------------
5374 -- Build_Task_Proc_Specification --
5375 -----------------------------------
5377 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5378 Loc
: constant Source_Ptr
:= Sloc
(T
);
5379 Spec_Id
: Entity_Id
;
5382 -- Case of explicit task type, suffix TB
5384 if Comes_From_Source
(T
) then
5386 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), "TB"));
5388 -- Case of anonymous task type, suffix B
5392 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), 'B'));
5395 Set_Is_Internal
(Spec_Id
);
5397 -- Associate the procedure with the task, if this is the declaration
5398 -- (and not the body) of the procedure.
5400 if No
(Task_Body_Procedure
(T
)) then
5401 Set_Task_Body_Procedure
(T
, Spec_Id
);
5405 Make_Procedure_Specification
(Loc
,
5406 Defining_Unit_Name
=> Spec_Id
,
5407 Parameter_Specifications
=> New_List
(
5408 Make_Parameter_Specification
(Loc
,
5409 Defining_Identifier
=>
5410 Make_Defining_Identifier
(Loc
, Name_uTask
),
5412 Make_Access_Definition
(Loc
,
5414 New_Occurrence_Of
(Corresponding_Record_Type
(T
), Loc
)))));
5415 end Build_Task_Proc_Specification
;
5417 ---------------------------------------
5418 -- Build_Unprotected_Subprogram_Body --
5419 ---------------------------------------
5421 function Build_Unprotected_Subprogram_Body
5423 Pid
: Node_Id
) return Node_Id
5425 Decls
: constant List_Id
:= Declarations
(N
);
5428 -- Add renamings for the Protection object, discriminals, privals, and
5429 -- the entry index constant for use by debugger.
5431 Debug_Private_Data_Declarations
(Decls
);
5433 -- Make an unprotected version of the subprogram for use within the same
5434 -- object, with a new name and an additional parameter representing the
5438 Make_Subprogram_Body
(Sloc
(N
),
5440 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5441 Declarations
=> Decls
,
5442 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5443 end Build_Unprotected_Subprogram_Body
;
5445 ----------------------------
5446 -- Collect_Entry_Families --
5447 ----------------------------
5449 procedure Collect_Entry_Families
5452 Current_Node
: in out Node_Id
;
5453 Conctyp
: Entity_Id
)
5456 Efam_Decl
: Node_Id
;
5457 Efam_Type
: Entity_Id
;
5460 Efam
:= First_Entity
(Conctyp
);
5461 while Present
(Efam
) loop
5462 if Ekind
(Efam
) = E_Entry_Family
then
5463 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5468 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
5470 Bas_Decl
: Node_Id
:= Empty
;
5475 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
5477 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
5478 Bas
:= Make_Temporary
(Loc
, 'B');
5481 Make_Subtype_Declaration
(Loc
,
5482 Defining_Identifier
=> Bas
,
5483 Subtype_Indication
=>
5484 Make_Subtype_Indication
(Loc
,
5486 New_Occurrence_Of
(Standard_Integer
, Loc
),
5488 Make_Range_Constraint
(Loc
,
5489 Range_Expression
=> Make_Range
(Loc
,
5490 Make_Integer_Literal
5491 (Loc
, -Entry_Family_Bound
),
5492 Make_Integer_Literal
5493 (Loc
, Entry_Family_Bound
- 1)))));
5495 Insert_After
(Current_Node
, Bas_Decl
);
5496 Current_Node
:= Bas_Decl
;
5501 Make_Full_Type_Declaration
(Loc
,
5502 Defining_Identifier
=> Efam_Type
,
5504 Make_Unconstrained_Array_Definition
(Loc
,
5506 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
5508 Component_Definition
=>
5509 Make_Component_Definition
(Loc
,
5510 Aliased_Present
=> False,
5511 Subtype_Indication
=>
5512 New_Occurrence_Of
(Standard_Character
, Loc
))));
5515 Insert_After
(Current_Node
, Efam_Decl
);
5516 Current_Node
:= Efam_Decl
;
5517 Analyze
(Efam_Decl
);
5520 Make_Component_Declaration
(Loc
,
5521 Defining_Identifier
=>
5522 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5524 Component_Definition
=>
5525 Make_Component_Definition
(Loc
,
5526 Aliased_Present
=> False,
5527 Subtype_Indication
=>
5528 Make_Subtype_Indication
(Loc
,
5530 New_Occurrence_Of
(Efam_Type
, Loc
),
5533 Make_Index_Or_Discriminant_Constraint
(Loc
,
5534 Constraints
=> New_List
(
5536 (Etype
(Discrete_Subtype_Definition
5537 (Parent
(Efam
))), Loc
)))))));
5543 end Collect_Entry_Families
;
5545 -----------------------
5546 -- Concurrent_Object --
5547 -----------------------
5549 function Concurrent_Object
5550 (Spec_Id
: Entity_Id
;
5551 Conc_Typ
: Entity_Id
) return Entity_Id
5554 -- Parameter _O or _object
5556 if Is_Protected_Type
(Conc_Typ
) then
5557 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5562 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5563 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5565 end Concurrent_Object
;
5567 ----------------------
5568 -- Copy_Result_Type --
5569 ----------------------
5571 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5572 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5577 -- If the result type is an access_to_subprogram, we must create new
5578 -- entities for its spec.
5580 if Nkind
(New_Res
) = N_Access_Definition
5581 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5583 -- Provide new entities for the formals
5585 Par_Spec
:= First
(Parameter_Specifications
5586 (Access_To_Subprogram_Definition
(New_Res
)));
5587 while Present
(Par_Spec
) loop
5588 Formal
:= Defining_Identifier
(Par_Spec
);
5589 Set_Defining_Identifier
(Par_Spec
,
5590 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5596 end Copy_Result_Type
;
5598 --------------------
5599 -- Concurrent_Ref --
5600 --------------------
5602 -- The expression returned for a reference to a concurrent object has the
5605 -- taskV!(name)._Task_Id
5609 -- objectV!(name)._Object
5611 -- for a protected object. For the case of an access to a concurrent
5612 -- object, there is an extra explicit dereference:
5614 -- taskV!(name.all)._Task_Id
5615 -- objectV!(name.all)._Object
5617 -- here taskV and objectV are the types for the associated records, which
5618 -- contain the required _Task_Id and _Object fields for tasks and protected
5619 -- objects, respectively.
5621 -- For the case of a task type name, the expression is
5625 -- i.e. a call to the Self function which returns precisely this Task_Id
5627 -- For the case of a protected type name, the expression is
5631 -- which is a renaming of the _object field of the current object
5632 -- record, passed into protected operations as a parameter.
5634 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5635 Loc
: constant Source_Ptr
:= Sloc
(N
);
5636 Ntyp
: constant Entity_Id
:= Etype
(N
);
5640 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5641 -- Check whether the reference is to the immediately enclosing task
5642 -- type, or to an outer one (rare but legal).
5644 ---------------------
5645 -- Is_Current_Task --
5646 ---------------------
5648 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5652 Scop
:= Current_Scope
;
5653 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
5657 elsif Is_Task_Type
(Scop
) then
5660 -- If this is a procedure nested within the task type, we must
5661 -- assume that it can be called from an inner task, and therefore
5662 -- cannot treat it as a local reference.
5664 elsif Is_Overloadable
(Scop
) and then In_Open_Scopes
(T
) then
5668 Scop
:= Scope
(Scop
);
5672 -- We know that we are within the task body, so should have found it
5675 raise Program_Error
;
5676 end Is_Current_Task
;
5678 -- Start of processing for Concurrent_Ref
5681 if Is_Access_Type
(Ntyp
) then
5682 Dtyp
:= Designated_Type
(Ntyp
);
5684 if Is_Protected_Type
(Dtyp
) then
5685 Sel
:= Name_uObject
;
5687 Sel
:= Name_uTask_Id
;
5691 Make_Selected_Component
(Loc
,
5693 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5694 Make_Explicit_Dereference
(Loc
, N
)),
5695 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5697 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5698 if Is_Task_Type
(Entity
(N
)) then
5700 if Is_Current_Task
(Entity
(N
)) then
5702 Make_Function_Call
(Loc
,
5703 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
));
5708 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5709 T_Body
: constant Node_Id
:=
5710 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5714 Make_Object_Declaration
(Loc
,
5715 Defining_Identifier
=> T_Self
,
5716 Object_Definition
=>
5717 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5719 Make_Function_Call
(Loc
,
5720 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
)));
5721 Prepend
(Decl
, Declarations
(T_Body
));
5723 Set_Scope
(T_Self
, Entity
(N
));
5724 return New_Occurrence_Of
(T_Self
, Loc
);
5729 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5732 New_Occurrence_Of
(Find_Protection_Object
(Current_Scope
), Loc
);
5736 if Is_Protected_Type
(Ntyp
) then
5737 Sel
:= Name_uObject
;
5738 elsif Is_Task_Type
(Ntyp
) then
5739 Sel
:= Name_uTask_Id
;
5741 raise Program_Error
;
5745 Make_Selected_Component
(Loc
,
5747 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5749 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5753 ------------------------
5754 -- Convert_Concurrent --
5755 ------------------------
5757 function Convert_Concurrent
5759 Typ
: Entity_Id
) return Node_Id
5762 if not Is_Concurrent_Type
(Typ
) then
5766 Unchecked_Convert_To
5767 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5769 end Convert_Concurrent
;
5771 -------------------------------------
5772 -- Debug_Private_Data_Declarations --
5773 -------------------------------------
5775 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5776 Debug_Nod
: Node_Id
;
5780 Decl
:= First
(Decls
);
5781 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5783 -- Declaration for concurrent entity _object and its access type,
5784 -- along with the entry index subtype:
5785 -- type prot_typVP is access prot_typV;
5786 -- _object : prot_typVP := prot_typV (_O);
5787 -- subtype Jnn is <Type of Index> range Low .. High;
5789 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
5790 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5792 -- Declaration for the Protection object, discriminals, privals, and
5793 -- entry index constant:
5794 -- conc_typR : protection_typ renames _object._object;
5795 -- discr_nameD : discr_typ renames _object.discr_name;
5796 -- discr_nameD : discr_typ renames _task.discr_name;
5797 -- prival_name : comp_typ renames _object.comp_name;
5798 -- J : constant Jnn :=
5799 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5801 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5802 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5803 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5805 if Present
(Debug_Nod
) then
5806 Insert_After
(Decl
, Debug_Nod
);
5812 end Debug_Private_Data_Declarations
;
5814 ------------------------------
5815 -- Ensure_Statement_Present --
5816 ------------------------------
5818 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5822 if Opt
.Suppress_Control_Flow_Optimizations
5823 and then Is_Empty_List
(Statements
(Alt
))
5825 Stmt
:= Make_Null_Statement
(Loc
);
5827 -- Mark NULL statement as coming from source so that it is not
5828 -- eliminated by GIGI.
5830 -- Another covert channel. If this is a requirement, it must be
5831 -- documented in sinfo/einfo ???
5833 Set_Comes_From_Source
(Stmt
, True);
5835 Set_Statements
(Alt
, New_List
(Stmt
));
5837 end Ensure_Statement_Present
;
5839 ----------------------------
5840 -- Entry_Index_Expression --
5841 ----------------------------
5843 function Entry_Index_Expression
5847 Ttyp
: Entity_Id
) return Node_Id
5857 -- The queues of entries and entry families appear in textual order in
5858 -- the associated record. The entry index is computed as the sum of the
5859 -- number of queues for all entries that precede the designated one, to
5860 -- which is added the index expression, if this expression denotes a
5861 -- member of a family.
5863 -- The following is a place holder for the count of simple entries
5865 Num
:= Make_Integer_Literal
(Sloc
, 1);
5867 -- We construct an expression which is a series of addition operations.
5868 -- The first operand is the number of single entries that precede this
5869 -- one, the second operand is the index value relative to the start of
5870 -- the referenced family, and the remaining operands are the lengths of
5871 -- the entry families that precede this entry, i.e. the constructed
5874 -- number_simple_entries +
5875 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5876 -- family'length + ...
5878 -- where index-value is the given index value, and s is the index
5879 -- subtype (we have to use pos because the subtype might be an
5880 -- enumeration type preventing direct subtraction). Note that the task
5881 -- entry array is one-indexed.
5883 -- The upper bound of the entry family may be a discriminant, so we
5884 -- retrieve the lower bound explicitly to compute offset, rather than
5885 -- using the index subtype which may mention a discriminant.
5887 if Present
(Index
) then
5888 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
5896 Make_Attribute_Reference
(Sloc
,
5897 Attribute_Name
=> Name_Pos
,
5898 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
5899 Expressions
=> New_List
(Relocate_Node
(Index
))),
5907 -- Now add lengths of preceding entries and entry families
5909 Prev
:= First_Entity
(Ttyp
);
5910 while Chars
(Prev
) /= Chars
(Ent
)
5911 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5912 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5914 if Ekind
(Prev
) = E_Entry
then
5915 Set_Intval
(Num
, Intval
(Num
) + 1);
5917 elsif Ekind
(Prev
) = E_Entry_Family
then
5918 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
5919 Lo
:= Type_Low_Bound
(S
);
5920 Hi
:= Type_High_Bound
(S
);
5925 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5927 -- Other components are anonymous types to be ignored
5937 end Entry_Index_Expression
;
5939 ---------------------------
5940 -- Establish_Task_Master --
5941 ---------------------------
5943 procedure Establish_Task_Master
(N
: Node_Id
) is
5947 if Restriction_Active
(No_Task_Hierarchy
) = False then
5948 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5950 -- The block may have no declarations (and nevertheless be a task
5951 -- master) if it contains a call that may return an object that
5954 if No
(Declarations
(N
)) then
5955 Set_Declarations
(N
, New_List
(Call
));
5957 Prepend_To
(Declarations
(N
), Call
);
5962 end Establish_Task_Master
;
5964 --------------------------------
5965 -- Expand_Accept_Declarations --
5966 --------------------------------
5968 -- Part of the expansion of an accept statement involves the creation of
5969 -- a declaration that can be referenced from the statement sequence of
5974 -- This declaration is inserted immediately before the accept statement
5975 -- and it is important that it be inserted before the statements of the
5976 -- statement sequence are analyzed. Thus it would be too late to create
5977 -- this declaration in the Expand_N_Accept_Statement routine, which is
5978 -- why there is a separate procedure to be called directly from Sem_Ch9.
5980 -- Ann is used to hold the address of the record containing the parameters
5981 -- (see Expand_N_Entry_Call for more details on how this record is built).
5982 -- References to the parameters do an unchecked conversion of this address
5983 -- to a pointer to the required record type, and then access the field that
5984 -- holds the value of the required parameter. The entity for the address
5985 -- variable is held as the top stack element (i.e. the last element) of the
5986 -- Accept_Address stack in the corresponding entry entity, and this element
5987 -- must be set in place before the statements are processed.
5989 -- The above description applies to the case of a stand alone accept
5990 -- statement, i.e. one not appearing as part of a select alternative.
5992 -- For the case of an accept that appears as part of a select alternative
5993 -- of a selective accept, we must still create the declaration right away,
5994 -- since Ann is needed immediately, but there is an important difference:
5996 -- The declaration is inserted before the selective accept, not before
5997 -- the accept statement (which is not part of a list anyway, and so would
5998 -- not accommodate inserted declarations)
6000 -- We only need one address variable for the entire selective accept. So
6001 -- the Ann declaration is created only for the first accept alternative,
6002 -- and subsequent accept alternatives reference the same Ann variable.
6004 -- We can distinguish the two cases by seeing whether the accept statement
6005 -- is part of a list. If not, then it must be in an accept alternative.
6007 -- To expand the requeue statement, a label is provided at the end of the
6008 -- accept statement or alternative of which it is a part, so that the
6009 -- statement can be skipped after the requeue is complete. This label is
6010 -- created here rather than during the expansion of the accept statement,
6011 -- because it will be needed by any requeue statements within the accept,
6012 -- which are expanded before the accept.
6014 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
6015 Loc
: constant Source_Ptr
:= Sloc
(N
);
6016 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6017 Ann
: Entity_Id
:= Empty
;
6024 if Expander_Active
then
6026 -- If we have no handled statement sequence, we may need to build
6027 -- a dummy sequence consisting of a null statement. This can be
6028 -- skipped if the trivial accept optimization is permitted.
6030 if not Trivial_Accept_OK
6031 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6033 Set_Handled_Statement_Sequence
(N
,
6034 Make_Handled_Sequence_Of_Statements
(Loc
,
6035 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
6038 -- Create and declare two labels to be placed at the end of the
6039 -- accept statement. The first label is used to allow requeues to
6040 -- skip the remainder of entry processing. The second label is used
6041 -- to skip the remainder of entry processing if the rendezvous
6042 -- completes in the middle of the accept body.
6044 if Present
(Handled_Statement_Sequence
(N
)) then
6049 Ent
:= Make_Temporary
(Loc
, 'L');
6050 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
6052 Make_Implicit_Label_Declaration
(Loc
,
6053 Defining_Identifier
=> Ent
,
6054 Label_Construct
=> Lab
);
6055 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
6057 Ent
:= Make_Temporary
(Loc
, 'L');
6058 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
6060 Make_Implicit_Label_Declaration
(Loc
,
6061 Defining_Identifier
=> Ent
,
6062 Label_Construct
=> Lab
);
6063 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
6071 -- Case of stand alone accept statement
6073 if Is_List_Member
(N
) then
6075 if Present
(Handled_Statement_Sequence
(N
)) then
6076 Ann
:= Make_Temporary
(Loc
, 'A');
6079 Make_Object_Declaration
(Loc
,
6080 Defining_Identifier
=> Ann
,
6081 Object_Definition
=>
6082 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
6084 Insert_Before_And_Analyze
(N
, Adecl
);
6085 Insert_Before_And_Analyze
(N
, Ldecl
);
6086 Insert_Before_And_Analyze
(N
, Ldecl2
);
6089 -- Case of accept statement which is in an accept alternative
6093 Acc_Alt
: constant Node_Id
:= Parent
(N
);
6094 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
6098 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
6099 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
6101 -- ??? Consider a single label for select statements
6103 if Present
(Handled_Statement_Sequence
(N
)) then
6105 Statements
(Handled_Statement_Sequence
(N
)));
6109 Statements
(Handled_Statement_Sequence
(N
)));
6113 -- Find first accept alternative of the selective accept. A
6114 -- valid selective accept must have at least one accept in it.
6116 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
6118 while Nkind
(Alt
) /= N_Accept_Alternative
loop
6122 -- If this is the first accept statement, then we have to
6123 -- create the Ann variable, as for the stand alone case, except
6124 -- that it is inserted before the selective accept. Similarly,
6125 -- a label for requeue expansion must be declared.
6127 if N
= Accept_Statement
(Alt
) then
6128 Ann
:= Make_Temporary
(Loc
, 'A');
6130 Make_Object_Declaration
(Loc
,
6131 Defining_Identifier
=> Ann
,
6132 Object_Definition
=>
6133 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
6135 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
6137 -- If this is not the first accept statement, then find the Ann
6138 -- variable allocated by the first accept and use it.
6142 Node
(Last_Elmt
(Accept_Address
6143 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
6148 -- Merge here with Ann either created or referenced, and Adecl
6149 -- pointing to the corresponding declaration. Remaining processing
6150 -- is the same for the two cases.
6152 if Present
(Ann
) then
6153 Append_Elmt
(Ann
, Accept_Address
(Ent
));
6154 Set_Debug_Info_Needed
(Ann
);
6157 -- Create renaming declarations for the entry formals. Each reference
6158 -- to a formal becomes a dereference of a component of the parameter
6159 -- block, whose address is held in Ann. These declarations are
6160 -- eventually inserted into the accept block, and analyzed there so
6161 -- that they have the proper scope for gdb and do not conflict with
6162 -- other declarations.
6164 if Present
(Parameter_Specifications
(N
))
6165 and then Present
(Handled_Statement_Sequence
(N
))
6172 Renamed_Formal
: Node_Id
;
6176 Formal
:= First_Formal
(Ent
);
6178 while Present
(Formal
) loop
6179 Comp
:= Entry_Component
(Formal
);
6180 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
6182 Set_Etype
(New_F
, Etype
(Formal
));
6183 Set_Scope
(New_F
, Ent
);
6185 -- Now we set debug info needed on New_F even though it does
6186 -- not come from source, so that the debugger will get the
6187 -- right information for these generated names.
6189 Set_Debug_Info_Needed
(New_F
);
6191 if Ekind
(Formal
) = E_In_Parameter
then
6192 Set_Ekind
(New_F
, E_Constant
);
6194 Set_Ekind
(New_F
, E_Variable
);
6195 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
6198 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
6201 Make_Selected_Component
(Loc
,
6203 Unchecked_Convert_To
(
6204 Entry_Parameters_Type
(Ent
),
6205 New_Occurrence_Of
(Ann
, Loc
)),
6207 New_Occurrence_Of
(Comp
, Loc
));
6210 Build_Renamed_Formal_Declaration
6211 (New_F
, Formal
, Comp
, Renamed_Formal
);
6213 if No
(Declarations
(N
)) then
6214 Set_Declarations
(N
, New_List
);
6217 Append
(Decl
, Declarations
(N
));
6218 Set_Renamed_Object
(Formal
, New_F
);
6219 Next_Formal
(Formal
);
6226 end Expand_Accept_Declarations
;
6228 ---------------------------------------------
6229 -- Expand_Access_Protected_Subprogram_Type --
6230 ---------------------------------------------
6232 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
6233 Loc
: constant Source_Ptr
:= Sloc
(N
);
6235 T
: constant Entity_Id
:= Defining_Identifier
(N
);
6236 D_T
: constant Entity_Id
:= Designated_Type
(T
);
6237 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
6238 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
6239 P_List
: constant List_Id
:= Build_Protected_Spec
6240 (N
, RTE
(RE_Address
), D_T
, False);
6246 -- Create access to subprogram with full signature
6248 if Etype
(D_T
) /= Standard_Void_Type
then
6250 Make_Access_Function_Definition
(Loc
,
6251 Parameter_Specifications
=> P_List
,
6252 Result_Definition
=>
6253 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
6257 Make_Access_Procedure_Definition
(Loc
,
6258 Parameter_Specifications
=> P_List
);
6262 Make_Full_Type_Declaration
(Loc
,
6263 Defining_Identifier
=> D_T2
,
6264 Type_Definition
=> Def1
);
6266 Insert_After_And_Analyze
(N
, Decl1
);
6268 -- Associate the access to subprogram with its original access to
6269 -- protected subprogram type. Needed by the backend to know that this
6270 -- type corresponds with an access to protected subprogram type.
6272 Set_Original_Access_Type
(D_T2
, T
);
6274 -- Create Equivalent_Type, a record with two components for an access to
6275 -- object and an access to subprogram.
6278 Make_Component_Declaration
(Loc
,
6279 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
6280 Component_Definition
=>
6281 Make_Component_Definition
(Loc
,
6282 Aliased_Present
=> False,
6283 Subtype_Indication
=>
6284 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
6286 Make_Component_Declaration
(Loc
,
6287 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
6288 Component_Definition
=>
6289 Make_Component_Definition
(Loc
,
6290 Aliased_Present
=> False,
6291 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
6294 Make_Full_Type_Declaration
(Loc
,
6295 Defining_Identifier
=> E_T
,
6297 Make_Record_Definition
(Loc
,
6299 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
6301 Insert_After_And_Analyze
(Decl1
, Decl2
);
6302 Set_Equivalent_Type
(T
, E_T
);
6303 end Expand_Access_Protected_Subprogram_Type
;
6305 --------------------------
6306 -- Expand_Entry_Barrier --
6307 --------------------------
6309 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
6310 Cond
: constant Node_Id
:=
6311 Condition
(Entry_Body_Formal_Part
(N
));
6312 Prot
: constant Entity_Id
:= Scope
(Ent
);
6313 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
6314 Func
: Entity_Id
:= Empty
;
6316 Body_Decl
: Node_Id
;
6318 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
;
6319 -- Check whether entity in Barrier is external to protected type.
6320 -- If so, barrier may not be properly synchronized.
6322 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
;
6323 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6326 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean;
6327 -- Check whether entity name N denotes a component of the protected
6328 -- object. This is used to check the Simple_Barrier restriction.
6330 ----------------------
6331 -- Is_Global_Entity --
6332 ----------------------
6334 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
is
6339 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
6343 if Ekind
(E
) = E_Variable
then
6345 -- If the variable is local to the barrier function generated
6346 -- during expansion, it is ok. If expansion is not performed,
6347 -- then Func is Empty so this test cannot succeed.
6349 if Scope
(E
) = Func
then
6352 -- A protected call from a barrier to another object is ok
6354 elsif Ekind
(Etype
(E
)) = E_Protected_Type
then
6357 -- If the variable is within the package body we consider
6358 -- this safe. This is a common (if dubious) idiom.
6360 elsif S
= Scope
(Prot
)
6361 and then Ekind_In
(S
, E_Package
, E_Generic_Package
)
6362 and then Nkind
(Parent
(E
)) = N_Object_Declaration
6363 and then Nkind
(Parent
(Parent
(E
))) = N_Package_Body
6368 Error_Msg_N
("potentially unsynchronized barrier??", N
);
6369 Error_Msg_N
("\& should be private component of type??", N
);
6375 end Is_Global_Entity
;
6377 procedure Check_Unprotected_Barrier
is
6378 new Traverse_Proc
(Is_Global_Entity
);
6380 ----------------------------
6381 -- Is_Simple_Barrier_Name --
6382 ----------------------------
6384 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean is
6388 -- Check for case of _object.all.field (note that the explicit
6389 -- dereference gets inserted by analyze/expand of _object.field).
6391 if Expander_Active
then
6392 Renamed
:= Renamed_Object
(Entity
(N
));
6396 and then Nkind
(Renamed
) = N_Selected_Component
6397 and then Chars
(Prefix
(Prefix
(Renamed
))) = Name_uObject
;
6399 return Scope
(Entity
(N
)) = Current_Scope
;
6401 end Is_Simple_Barrier_Name
;
6403 ---------------------
6404 -- Is_Pure_Barrier --
6405 ---------------------
6407 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
is
6410 when N_Expanded_Name |
6412 if No
(Entity
(N
)) then
6416 case Ekind
(Entity
(N
)) is
6421 E_Enumeration_Literal
=>
6427 -- A variable in the protected type is expanded as a
6430 if Is_Simple_Barrier_Name
(N
) then
6438 when N_Integer_Literal |
6440 N_Character_Literal
=>
6445 if Ekind
(Entity
(N
)) = E_Operator
then
6449 when N_Short_Circuit
=>
6457 end Is_Pure_Barrier
;
6459 function Check_Pure_Barriers
is new Traverse_Func
(Is_Pure_Barrier
);
6461 -- Start of processing for Expand_Entry_Barrier
6464 if No_Run_Time_Mode
then
6465 Error_Msg_CRT
("entry barrier", N
);
6469 -- The body of the entry barrier must be analyzed in the context of the
6470 -- protected object, but its scope is external to it, just as any other
6471 -- unprotected version of a protected operation. The specification has
6472 -- been produced when the protected type declaration was elaborated. We
6473 -- build the body, insert it in the enclosing scope, but analyze it in
6474 -- the current context. A more uniform approach would be to treat the
6475 -- barrier just as a protected function, and discard the protected
6476 -- version of it because it is never called.
6478 if Expander_Active
then
6479 B_F
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6480 Func
:= Barrier_Function
(Ent
);
6481 Set_Corresponding_Spec
(B_F
, Func
);
6483 Body_Decl
:= Parent
(Corresponding_Body
(Spec_Decl
));
6485 if Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
6486 Body_Decl
:= Corresponding_Stub
(Parent
(Body_Decl
));
6489 Insert_Before_And_Analyze
(Body_Decl
, B_F
);
6491 Set_Discriminals
(Spec_Decl
);
6492 Set_Scope
(Func
, Scope
(Prot
));
6495 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6498 -- Check Pure_Barriers restriction
6500 if Check_Pure_Barriers
(Cond
) = Abandon
then
6501 Check_Restriction
(Pure_Barriers
, Cond
);
6504 -- The Ravenscar profile restricts barriers to simple variables declared
6505 -- within the protected object. We also allow Boolean constants, since
6506 -- these appear in several published examples and are also allowed by
6509 -- Note that after analysis variables in this context will be replaced
6510 -- by the corresponding prival, that is to say a renaming of a selected
6511 -- component of the form _Object.Var. If expansion is disabled, as
6512 -- within a generic, we check that the entity appears in the current
6515 if Is_Entity_Name
(Cond
) then
6517 -- A small optimization of useless renamings. If the scope of the
6518 -- entity of the condition is not the barrier function, then the
6519 -- condition does not reference any of the generated renamings
6520 -- within the function.
6522 if Expander_Active
and then Scope
(Entity
(Cond
)) /= Func
then
6523 Set_Declarations
(B_F
, Empty_List
);
6526 if Entity
(Cond
) = Standard_False
6528 Entity
(Cond
) = Standard_True
6532 elsif Is_Simple_Barrier_Name
(Cond
) then
6537 -- It is not a boolean variable or literal, so check the restriction.
6538 -- Note that it is safe to be calling Check_Restriction from here, even
6539 -- though this is part of the expander, since Expand_Entry_Barrier is
6540 -- called from Sem_Ch9 even in -gnatc mode.
6542 Check_Restriction
(Simple_Barriers
, Cond
);
6544 -- Emit warning if barrier contains global entities and is thus
6545 -- potentially unsynchronized.
6547 Check_Unprotected_Barrier
(Cond
);
6548 end Expand_Entry_Barrier
;
6550 ------------------------------
6551 -- Expand_N_Abort_Statement --
6552 ------------------------------
6554 -- Expand abort T1, T2, .. Tn; into:
6555 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6557 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6558 Loc
: constant Source_Ptr
:= Sloc
(N
);
6559 Tlist
: constant List_Id
:= Names
(N
);
6565 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6568 Tasknm
:= First
(Tlist
);
6570 while Present
(Tasknm
) loop
6573 -- A task interface class-wide type object is being aborted. Retrieve
6574 -- its _task_id by calling a dispatching routine.
6576 if Ada_Version
>= Ada_2005
6577 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6578 and then Is_Interface
(Etype
(Tasknm
))
6579 and then Is_Task_Interface
(Etype
(Tasknm
))
6581 Append_To
(Component_Associations
(Aggr
),
6582 Make_Component_Association
(Loc
,
6583 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6586 -- Task_Id (Tasknm._disp_get_task_id)
6588 Make_Unchecked_Type_Conversion
(Loc
,
6590 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6592 Make_Selected_Component
(Loc
,
6593 Prefix
=> New_Copy_Tree
(Tasknm
),
6595 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6598 Append_To
(Component_Associations
(Aggr
),
6599 Make_Component_Association
(Loc
,
6600 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6601 Expression
=> Concurrent_Ref
(Tasknm
)));
6608 Make_Procedure_Call_Statement
(Loc
,
6609 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Tasks
), Loc
),
6610 Parameter_Associations
=> New_List
(
6611 Make_Qualified_Expression
(Loc
,
6612 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_List
), Loc
),
6613 Expression
=> Aggr
))));
6616 end Expand_N_Abort_Statement
;
6618 -------------------------------
6619 -- Expand_N_Accept_Statement --
6620 -------------------------------
6622 -- This procedure handles expansion of accept statements that stand alone,
6623 -- i.e. they are not part of an accept alternative. The expansion of
6624 -- accept statement in accept alternatives is handled by the routines
6625 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6626 -- following description applies only to stand alone accept statements.
6628 -- If there is no handled statement sequence, or only null statements, then
6629 -- this is called a trivial accept, and the expansion is:
6631 -- Accept_Trivial (entry-index)
6633 -- If there is a handled statement sequence, then the expansion is:
6640 -- Accept_Call (entry-index, Ann);
6641 -- Renaming_Declarations for formals
6642 -- <statement sequence from N_Accept_Statement node>
6643 -- Complete_Rendezvous;
6648 -- <exception handler from N_Accept_Statement node>
6649 -- Complete_Rendezvous;
6651 -- <exception handler from N_Accept_Statement node>
6652 -- Complete_Rendezvous;
6657 -- when all others =>
6658 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6661 -- The first three declarations were already inserted ahead of the accept
6662 -- statement by the Expand_Accept_Declarations procedure, which was called
6663 -- directly from the semantics during analysis of the accept statement,
6664 -- before analyzing its contained statements.
6666 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6667 -- from possible expansion activity (the original source of course does
6668 -- not have any declarations associated with the accept statement, since
6669 -- an accept statement has no declarative part). In particular, if the
6670 -- expander is active, the first such declaration is the declaration of
6671 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6673 -- The two blocks are merged into a single block if the inner block has
6674 -- no exception handlers, but otherwise two blocks are required, since
6675 -- exceptions might be raised in the exception handlers of the inner
6676 -- block, and Exceptional_Complete_Rendezvous must be called.
6678 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6679 Loc
: constant Source_Ptr
:= Sloc
(N
);
6680 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6681 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6682 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6683 Eent
: constant Entity_Id
:= Entity
(Ename
);
6684 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6685 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6686 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6692 -- If the accept statement is not part of a list, then its parent must
6693 -- be an accept alternative, and, as described above, we do not do any
6694 -- expansion for such accept statements at this level.
6696 if not Is_List_Member
(N
) then
6697 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6700 -- Trivial accept case (no statement sequence, or null statements).
6701 -- If the accept statement has declarations, then just insert them
6702 -- before the procedure call.
6704 elsif Trivial_Accept_OK
6705 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6707 -- Remove declarations for renamings, because the parameter block
6708 -- will not be assigned.
6715 D
:= First
(Declarations
(N
));
6716 while Present
(D
) loop
6718 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6726 if Present
(Declarations
(N
)) then
6727 Insert_Actions
(N
, Declarations
(N
));
6731 Make_Procedure_Call_Statement
(Loc
,
6732 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Trivial
), Loc
),
6733 Parameter_Associations
=> New_List
(
6734 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6738 -- Discard Entry_Address that was created for it, so it will not be
6739 -- emitted if this accept statement is in the statement part of a
6740 -- delay alternative.
6742 if Present
(Stats
) then
6743 Remove_Last_Elmt
(Acstack
);
6746 -- Case of statement sequence present
6749 -- Construct the block, using the declarations from the accept
6750 -- statement if any to initialize the declarations of the block.
6752 Blkent
:= Make_Temporary
(Loc
, 'A');
6753 Set_Ekind
(Blkent
, E_Block
);
6754 Set_Etype
(Blkent
, Standard_Void_Type
);
6755 Set_Scope
(Blkent
, Current_Scope
);
6758 Make_Block_Statement
(Loc
,
6759 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
6760 Declarations
=> Declarations
(N
),
6761 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6763 -- For the analysis of the generated declarations, the parent node
6764 -- must be properly set.
6766 Set_Parent
(Block
, Parent
(N
));
6768 -- Prepend call to Accept_Call to main statement sequence If the
6769 -- accept has exception handlers, the statement sequence is wrapped
6770 -- in a block. Insert call and renaming declarations in the
6771 -- declarations of the block, so they are elaborated before the
6775 Make_Procedure_Call_Statement
(Loc
,
6776 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Call
), Loc
),
6777 Parameter_Associations
=> New_List
(
6778 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6779 New_Occurrence_Of
(Ann
, Loc
)));
6781 if Parent
(Stats
) = N
then
6782 Prepend
(Call
, Statements
(Stats
));
6784 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6789 Push_Scope
(Blkent
);
6797 D
:= First
(Declarations
(N
));
6798 while Present
(D
) loop
6801 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6803 -- The renaming declarations for the formals were created
6804 -- during analysis of the accept statement, and attached to
6805 -- the list of declarations. Place them now in the context
6806 -- of the accept block or subprogram.
6809 Typ
:= Entity
(Subtype_Mark
(D
));
6810 Insert_After
(Call
, D
);
6813 -- If the formal is class_wide, it does not have an actual
6814 -- subtype. The analysis of the renaming declaration creates
6815 -- one, but we need to retain the class-wide nature of the
6818 if Is_Class_Wide_Type
(Typ
) then
6819 Set_Etype
(Defining_Identifier
(D
), Typ
);
6830 -- Replace the accept statement by the new block
6835 -- Last step is to unstack the Accept_Address value
6837 Remove_Last_Elmt
(Acstack
);
6839 end Expand_N_Accept_Statement
;
6841 ----------------------------------
6842 -- Expand_N_Asynchronous_Select --
6843 ----------------------------------
6845 -- This procedure assumes that the trigger statement is an entry call or
6846 -- a dispatching procedure call. A delay alternative should already have
6847 -- been expanded into an entry call to the appropriate delay object Wait
6850 -- If the trigger is a task entry call, the select is implemented with
6851 -- a Task_Entry_Call:
6856 -- P : parms := (parm, parm, parm);
6858 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6860 -- procedure _clean is
6863 -- Cancel_Task_Entry_Call (C);
6870 -- (<acceptor-task>, -- Acceptor
6871 -- <entry-index>, -- E
6872 -- P'Address, -- Uninterpreted_Data
6873 -- Asynchronous_Call, -- Mode
6874 -- B); -- Rendezvous_Successful
6881 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6884 -- when Abort_Signal => Abort_Undefer;
6891 -- <triggered-statements>
6895 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6896 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6900 -- P : parms := (parm, parm, parm);
6902 -- Call_Simple (acceptor-task, entry-index, P'Address);
6908 -- so the task at hand is to convert the latter expansion into the former
6910 -- If the trigger is a protected entry call, the select is implemented
6911 -- with Protected_Entry_Call:
6914 -- P : E1_Params := (param, param, param);
6915 -- Bnn : Communications_Block;
6920 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6922 -- procedure _clean is
6925 -- if Enqueued (Bnn) then
6926 -- Cancel_Protected_Entry_Call (Bnn);
6933 -- Protected_Entry_Call
6934 -- (po._object'Access, -- Object
6935 -- <entry index>, -- E
6936 -- P'Address, -- Uninterpreted_Data
6937 -- Asynchronous_Call, -- Mode
6940 -- if Enqueued (Bnn) then
6944 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6947 -- when Abort_Signal => Abort_Undefer;
6950 -- if not Cancelled (Bnn) then
6951 -- <triggered-statements>
6955 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6959 -- P : E1_Params := (param, param, param);
6960 -- Bnn : Communications_Block;
6963 -- Protected_Entry_Call
6964 -- (po._object'Access, -- Object
6965 -- <entry index>, -- E
6966 -- P'Address, -- Uninterpreted_Data
6967 -- Simple_Call, -- Mode
6974 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6978 -- B : Boolean := False;
6979 -- Bnn : Communication_Block;
6980 -- C : Ada.Tags.Prim_Op_Kind;
6981 -- D : System.Storage_Elements.Dummy_Communication_Block;
6982 -- K : Ada.Tags.Tagged_Kind :=
6983 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6984 -- P : Parameters := (Param1 .. ParamN);
6989 -- if K = Ada.Tags.TK_Limited_Tagged
6990 -- or else K = Ada.Tags.TK_Tagged
6992 -- <dispatching-call>;
6993 -- <triggering-statements>;
6997 -- Ada.Tags.Get_Offset_Index
6998 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7000 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7002 -- if C = POK_Protected_Entry then
7004 -- procedure _clean is
7006 -- if Enqueued (Bnn) then
7007 -- Cancel_Protected_Entry_Call (Bnn);
7013 -- _Disp_Asynchronous_Select
7014 -- (<object>, S, P'Address, D, B);
7015 -- Bnn := Communication_Block (D);
7017 -- Param1 := P.Param1;
7019 -- ParamN := P.ParamN;
7021 -- if Enqueued (Bnn) then
7022 -- <abortable-statements>
7025 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7028 -- when Abort_Signal => Abort_Undefer;
7031 -- if not Cancelled (Bnn) then
7032 -- <triggering-statements>
7035 -- elsif C = POK_Task_Entry then
7037 -- procedure _clean is
7039 -- Cancel_Task_Entry_Call (U);
7045 -- _Disp_Asynchronous_Select
7046 -- (<object>, S, P'Address, D, B);
7047 -- Bnn := Communication_Bloc (D);
7049 -- Param1 := P.Param1;
7051 -- ParamN := P.ParamN;
7056 -- <abortable-statements>
7058 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7061 -- when Abort_Signal => Abort_Undefer;
7065 -- <triggering-statements>
7070 -- <dispatching-call>;
7071 -- <triggering-statements>
7076 -- The job is to convert this to the asynchronous form
7078 -- If the trigger is a delay statement, it will have been expanded into
7079 -- a call to one of the GNARL delay procedures. This routine will convert
7080 -- this into a protected entry call on a delay object and then continue
7081 -- processing as for a protected entry call trigger. This requires
7082 -- declaring a Delay_Block object and adding a pointer to this object to
7083 -- the parameter list of the delay procedure to form the parameter list of
7084 -- the entry call. This object is used by the runtime to queue the delay
7087 -- For a description of the use of P and the assignments after the call,
7088 -- see Expand_N_Entry_Call_Statement.
7090 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
7091 Loc
: constant Source_Ptr
:= Sloc
(N
);
7092 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
7093 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
7095 Abort_Block_Ent
: Entity_Id
;
7096 Abortable_Block
: Node_Id
;
7099 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7100 Blk_Typ
: Entity_Id
;
7102 Call_Ent
: Entity_Id
;
7103 Cancel_Param
: Entity_Id
;
7104 Cleanup_Block
: Node_Id
;
7105 Cleanup_Block_Ent
: Entity_Id
;
7106 Cleanup_Stmts
: List_Id
;
7107 Conc_Typ_Stmts
: List_Id
;
7109 Dblock_Ent
: Entity_Id
;
7114 Enqueue_Call
: Node_Id
;
7117 Handler_Stmt
: Node_Id
;
7119 Lim_Typ_Stmts
: List_Id
;
7125 ProtE_Stmts
: List_Id
;
7126 ProtP_Stmts
: List_Id
;
7129 TaskE_Stmts
: List_Id
;
7132 B
: Entity_Id
; -- Call status flag
7133 Bnn
: Entity_Id
; -- Communication block
7134 C
: Entity_Id
; -- Call kind
7135 K
: Entity_Id
; -- Tagged kind
7136 P
: Entity_Id
; -- Parameter block
7137 S
: Entity_Id
; -- Primitive operation slot
7138 T
: Entity_Id
; -- Additional status flag
7140 procedure Rewrite_Abortable_Part
;
7141 -- If the trigger is a dispatching call, the expansion inserts multiple
7142 -- copies of the abortable part. This is both inefficient, and may lead
7143 -- to duplicate definitions that the back-end will reject, when the
7144 -- abortable part includes loops. This procedure rewrites the abortable
7145 -- part into a call to a generated procedure.
7147 ----------------------------
7148 -- Rewrite_Abortable_Part --
7149 ----------------------------
7151 procedure Rewrite_Abortable_Part
is
7152 Proc
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7157 Make_Subprogram_Body
(Loc
,
7159 Make_Procedure_Specification
(Loc
, Defining_Unit_Name
=> Proc
),
7160 Declarations
=> New_List
,
7161 Handled_Statement_Sequence
=>
7162 Make_Handled_Sequence_Of_Statements
(Loc
, Astats
));
7163 Insert_Before
(N
, Decl
);
7166 -- Rewrite abortable part into a call to this procedure.
7170 Make_Procedure_Call_Statement
(Loc
,
7171 Name
=> New_Occurrence_Of
(Proc
, Loc
)));
7172 end Rewrite_Abortable_Part
;
7174 -- Start of processing for Expand_N_Asynchronous_Select
7177 Process_Statements_For_Controlled_Objects
(Trig
);
7178 Process_Statements_For_Controlled_Objects
(Abrt
);
7180 Ecall
:= Triggering_Statement
(Trig
);
7182 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
7184 -- Retrieve Astats and Tstats now because the finalization machinery may
7185 -- wrap them in blocks.
7187 Astats
:= Statements
(Abrt
);
7188 Tstats
:= Statements
(Trig
);
7190 -- The arguments in the call may require dynamic allocation, and the
7191 -- call statement may have been transformed into a block. The block
7192 -- may contain additional declarations for internal entities, and the
7193 -- original call is found by sequential search.
7195 if Nkind
(Ecall
) = N_Block_Statement
then
7196 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
7197 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
7198 N_Entry_Call_Statement
)
7204 -- This is either a dispatching call or a delay statement used as a
7205 -- trigger which was expanded into a procedure call.
7207 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
7208 if Ada_Version
>= Ada_2005
7210 (No
(Original_Node
(Ecall
))
7211 or else not Nkind_In
(Original_Node
(Ecall
),
7212 N_Delay_Relative_Statement
,
7213 N_Delay_Until_Statement
))
7215 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
7217 Rewrite_Abortable_Part
;
7221 -- Call status flag processing, generate:
7222 -- B : Boolean := False;
7224 B
:= Build_B
(Loc
, Decls
);
7226 -- Communication block processing, generate:
7227 -- Bnn : Communication_Block;
7229 Bnn
:= Make_Temporary
(Loc
, 'B');
7231 Make_Object_Declaration
(Loc
,
7232 Defining_Identifier
=> Bnn
,
7233 Object_Definition
=>
7234 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
7236 -- Call kind processing, generate:
7237 -- C : Ada.Tags.Prim_Op_Kind;
7239 C
:= Build_C
(Loc
, Decls
);
7241 -- Tagged kind processing, generate:
7242 -- K : Ada.Tags.Tagged_Kind :=
7243 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7245 -- Dummy communication block, generate:
7246 -- D : Dummy_Communication_Block;
7249 Make_Object_Declaration
(Loc
,
7250 Defining_Identifier
=>
7251 Make_Defining_Identifier
(Loc
, Name_uD
),
7252 Object_Definition
=>
7254 (RTE
(RE_Dummy_Communication_Block
), Loc
)));
7256 K
:= Build_K
(Loc
, Decls
, Obj
);
7258 -- Parameter block processing
7260 Blk_Typ
:= Build_Parameter_Block
7261 (Loc
, Actuals
, Formals
, Decls
);
7262 P
:= Parameter_Block_Pack
7263 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7265 -- Dispatch table slot processing, generate:
7268 S
:= Build_S
(Loc
, Decls
);
7270 -- Additional status flag processing, generate:
7273 T
:= Make_Temporary
(Loc
, 'T');
7275 Make_Object_Declaration
(Loc
,
7276 Defining_Identifier
=> T
,
7277 Object_Definition
=>
7278 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7280 ------------------------------
7281 -- Protected entry handling --
7282 ------------------------------
7285 -- Param1 := P.Param1;
7287 -- ParamN := P.ParamN;
7289 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7292 -- Bnn := Communication_Block (D);
7294 Prepend_To
(Cleanup_Stmts
,
7295 Make_Assignment_Statement
(Loc
,
7296 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
7298 Make_Unchecked_Type_Conversion
(Loc
,
7300 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7301 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7304 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7306 Prepend_To
(Cleanup_Stmts
,
7307 Make_Procedure_Call_Statement
(Loc
,
7311 (Etype
(Etype
(Obj
)), Name_uDisp_Asynchronous_Select
),
7313 Parameter_Associations
=>
7315 New_Copy_Tree
(Obj
), -- <object>
7316 New_Occurrence_Of
(S
, Loc
), -- S
7317 Make_Attribute_Reference
(Loc
, -- P'Address
7318 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7319 Attribute_Name
=> Name_Address
),
7320 Make_Identifier
(Loc
, Name_uD
), -- D
7321 New_Occurrence_Of
(B
, Loc
)))); -- B
7324 -- if Enqueued (Bnn) then
7325 -- <abortable-statements>
7328 Append_To
(Cleanup_Stmts
,
7329 Make_Implicit_If_Statement
(N
,
7331 Make_Function_Call
(Loc
,
7333 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7334 Parameter_Associations
=>
7335 New_List
(New_Occurrence_Of
(Bnn
, Loc
))),
7338 New_Copy_List_Tree
(Astats
)));
7340 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7341 -- will then generate a _clean for the communication block Bnn.
7345 -- procedure _clean is
7347 -- if Enqueued (Bnn) then
7348 -- Cancel_Protected_Entry_Call (Bnn);
7357 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7359 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
7361 -- Wrap the cleanup block in an exception handling block
7367 -- when Abort_Signal => Abort_Undefer;
7370 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7373 Make_Implicit_Label_Declaration
(Loc
,
7374 Defining_Identifier
=> Abort_Block_Ent
),
7377 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7380 -- if not Cancelled (Bnn) then
7381 -- <triggering-statements>
7384 Append_To
(ProtE_Stmts
,
7385 Make_Implicit_If_Statement
(N
,
7389 Make_Function_Call
(Loc
,
7391 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7392 Parameter_Associations
=>
7393 New_List
(New_Occurrence_Of
(Bnn
, Loc
)))),
7396 New_Copy_List_Tree
(Tstats
)));
7398 -------------------------
7399 -- Task entry handling --
7400 -------------------------
7403 -- Param1 := P.Param1;
7405 -- ParamN := P.ParamN;
7407 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7410 -- Bnn := Communication_Block (D);
7412 Append_To
(TaskE_Stmts
,
7413 Make_Assignment_Statement
(Loc
,
7415 New_Occurrence_Of
(Bnn
, Loc
),
7417 Make_Unchecked_Type_Conversion
(Loc
,
7419 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7420 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7423 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7425 Prepend_To
(TaskE_Stmts
,
7426 Make_Procedure_Call_Statement
(Loc
,
7429 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7430 Name_uDisp_Asynchronous_Select
),
7433 Parameter_Associations
=> New_List
(
7434 New_Copy_Tree
(Obj
), -- <object>
7435 New_Occurrence_Of
(S
, Loc
), -- S
7436 Make_Attribute_Reference
(Loc
, -- P'Address
7437 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7438 Attribute_Name
=> Name_Address
),
7439 Make_Identifier
(Loc
, Name_uD
), -- D
7440 New_Occurrence_Of
(B
, Loc
)))); -- B
7445 Prepend_To
(TaskE_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7449 -- <abortable-statements>
7451 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
7454 (Cleanup_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7456 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7457 -- will generate a _clean for the additional status flag.
7461 -- procedure _clean is
7463 -- Cancel_Task_Entry_Call (U);
7471 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7473 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
7475 -- Wrap the cleanup block in an exception handling block
7481 -- when Abort_Signal => Abort_Undefer;
7484 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7486 Append_To
(TaskE_Stmts
,
7487 Make_Implicit_Label_Declaration
(Loc
,
7488 Defining_Identifier
=> Abort_Block_Ent
));
7490 Append_To
(TaskE_Stmts
,
7492 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7496 -- <triggering-statements>
7499 Append_To
(TaskE_Stmts
,
7500 Make_Implicit_If_Statement
(N
,
7502 Make_Op_Not
(Loc
, Right_Opnd
=> New_Occurrence_Of
(T
, Loc
)),
7505 New_Copy_List_Tree
(Tstats
)));
7507 ----------------------------------
7508 -- Protected procedure handling --
7509 ----------------------------------
7512 -- <dispatching-call>;
7513 -- <triggering-statements>
7515 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7516 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7519 -- S := Ada.Tags.Get_Offset_Index
7520 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7523 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7526 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7528 Append_To
(Conc_Typ_Stmts
,
7529 Make_Procedure_Call_Statement
(Loc
,
7532 (Find_Prim_Op
(Etype
(Etype
(Obj
)),
7533 Name_uDisp_Get_Prim_Op_Kind
),
7535 Parameter_Associations
=>
7537 New_Copy_Tree
(Obj
),
7538 New_Occurrence_Of
(S
, Loc
),
7539 New_Occurrence_Of
(C
, Loc
))));
7542 -- if C = POK_Procedure_Entry then
7544 -- elsif C = POK_Task_Entry then
7550 Append_To
(Conc_Typ_Stmts
,
7551 Make_Implicit_If_Statement
(N
,
7555 New_Occurrence_Of
(C
, Loc
),
7557 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7564 Make_Elsif_Part
(Loc
,
7568 New_Occurrence_Of
(C
, Loc
),
7570 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
)),
7579 -- <dispatching-call>;
7580 -- <triggering-statements>
7582 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7583 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7586 -- if K = Ada.Tags.TK_Limited_Tagged
7587 -- or else K = Ada.Tags.TK_Tagged
7595 Make_Implicit_If_Statement
(N
,
7596 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
7597 Then_Statements
=> Lim_Typ_Stmts
,
7598 Else_Statements
=> Conc_Typ_Stmts
));
7601 Make_Block_Statement
(Loc
,
7604 Handled_Statement_Sequence
=>
7605 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7610 -- Delay triggering statement processing
7613 -- Add a Delay_Block object to the parameter list of the delay
7614 -- procedure to form the parameter list of the Wait entry call.
7616 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7618 Pdef
:= Entity
(Name
(Ecall
));
7620 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7622 New_Occurrence_Of
(RTE
(RE_Enqueue_Duration
), Loc
);
7624 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7626 New_Occurrence_Of
(RTE
(RE_Enqueue_Calendar
), Loc
);
7628 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7629 Enqueue_Call
:= New_Occurrence_Of
(RTE
(RE_Enqueue_RT
), Loc
);
7632 Append_To
(Parameter_Associations
(Ecall
),
7633 Make_Attribute_Reference
(Loc
,
7634 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7635 Attribute_Name
=> Name_Unchecked_Access
));
7637 -- Create the inner block to protect the abortable part
7639 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7641 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7644 Make_Block_Statement
(Loc
,
7645 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7646 Handled_Statement_Sequence
=>
7647 Make_Handled_Sequence_Of_Statements
(Loc
,
7648 Statements
=> Astats
),
7649 Has_Created_Identifier
=> True,
7650 Is_Asynchronous_Call_Block
=> True);
7652 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7655 Make_Implicit_If_Statement
(N
,
7657 Make_Function_Call
(Loc
,
7658 Name
=> Enqueue_Call
,
7659 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7661 New_List
(Make_Block_Statement
(Loc
,
7662 Handled_Statement_Sequence
=>
7663 Make_Handled_Sequence_Of_Statements
(Loc
,
7664 Statements
=> New_List
(
7665 Make_Implicit_Label_Declaration
(Loc
,
7666 Defining_Identifier
=> Blk_Ent
,
7667 Label_Construct
=> Abortable_Block
),
7669 Exception_Handlers
=> Hdle
)))));
7671 Stmts
:= New_List
(Ecall
);
7673 -- Construct statement sequence for new block
7676 Make_Implicit_If_Statement
(N
,
7678 Make_Function_Call
(Loc
,
7679 Name
=> New_Occurrence_Of
(
7680 RTE
(RE_Timed_Out
), Loc
),
7681 Parameter_Associations
=> New_List
(
7682 Make_Attribute_Reference
(Loc
,
7683 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7684 Attribute_Name
=> Name_Unchecked_Access
))),
7685 Then_Statements
=> Tstats
));
7687 -- The result is the new block
7689 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7692 Make_Block_Statement
(Loc
,
7693 Declarations
=> New_List
(
7694 Make_Object_Declaration
(Loc
,
7695 Defining_Identifier
=> Dblock_Ent
,
7696 Aliased_Present
=> True,
7697 Object_Definition
=>
7698 New_Occurrence_Of
(RTE
(RE_Delay_Block
), Loc
))),
7700 Handled_Statement_Sequence
=>
7701 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7711 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7712 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7714 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7715 Decls
:= Declarations
(Ecall
);
7717 if Is_Protected_Type
(Etype
(Concval
)) then
7719 -- Get the declarations of the block expanded from the entry call
7721 Decl
:= First
(Decls
);
7722 while Present
(Decl
)
7723 and then (Nkind
(Decl
) /= N_Object_Declaration
7724 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7725 RE_Communication_Block
))
7730 pragma Assert
(Present
(Decl
));
7731 Cancel_Param
:= Defining_Identifier
(Decl
);
7733 -- Change the mode of the Protected_Entry_Call call
7735 -- Protected_Entry_Call (
7736 -- Object => po._object'Access,
7737 -- E => <entry index>;
7738 -- Uninterpreted_Data => P'Address;
7739 -- Mode => Asynchronous_Call;
7742 -- Skip assignments to temporaries created for in-out parameters
7744 -- This makes unwarranted assumptions about the shape of the expanded
7745 -- tree for the call, and should be cleaned up ???
7747 Stmt
:= First
(Stmts
);
7748 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7754 Param
:= First
(Parameter_Associations
(Call
));
7755 while Present
(Param
)
7756 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7761 pragma Assert
(Present
(Param
));
7762 Rewrite
(Param
, New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7765 -- Append an if statement to execute the abortable part
7768 -- if Enqueued (Bnn) then
7771 Make_Implicit_If_Statement
(N
,
7773 Make_Function_Call
(Loc
,
7774 Name
=> New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7775 Parameter_Associations
=> New_List
(
7776 New_Occurrence_Of
(Cancel_Param
, Loc
))),
7777 Then_Statements
=> Astats
));
7780 Make_Block_Statement
(Loc
,
7781 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7782 Handled_Statement_Sequence
=>
7783 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7784 Has_Created_Identifier
=> True,
7785 Is_Asynchronous_Call_Block
=> True);
7787 -- Aborts are not deferred at beginning of exception handlers in
7790 if ZCX_Exceptions
then
7791 Handler_Stmt
:= Make_Null_Statement
(Loc
);
7794 Handler_Stmt
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
7798 Make_Block_Statement
(Loc
,
7799 Handled_Statement_Sequence
=>
7800 Make_Handled_Sequence_Of_Statements
(Loc
,
7801 Statements
=> New_List
(
7802 Make_Implicit_Label_Declaration
(Loc
,
7803 Defining_Identifier
=> Blk_Ent
,
7804 Label_Construct
=> Abortable_Block
),
7809 Exception_Handlers
=> New_List
(
7810 Make_Implicit_Exception_Handler
(Loc
,
7812 -- when Abort_Signal =>
7813 -- Abort_Undefer.all;
7815 Exception_Choices
=>
7816 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
7817 Statements
=> New_List
(Handler_Stmt
))))),
7819 -- if not Cancelled (Bnn) then
7820 -- triggered statements
7823 Make_Implicit_If_Statement
(N
,
7824 Condition
=> Make_Op_Not
(Loc
,
7826 Make_Function_Call
(Loc
,
7827 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7828 Parameter_Associations
=> New_List
(
7829 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7830 Then_Statements
=> Tstats
));
7832 -- Asynchronous task entry call
7839 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7841 -- Insert declaration of B in declarations of existing block
7844 Make_Object_Declaration
(Loc
,
7845 Defining_Identifier
=> B
,
7846 Object_Definition
=>
7847 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7849 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7851 -- Insert declaration of C in declarations of existing block
7854 Make_Object_Declaration
(Loc
,
7855 Defining_Identifier
=> Cancel_Param
,
7856 Object_Definition
=>
7857 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7859 -- Remove and save the call to Call_Simple
7861 Stmt
:= First
(Stmts
);
7863 -- Skip assignments to temporaries created for in-out parameters.
7864 -- This makes unwarranted assumptions about the shape of the expanded
7865 -- tree for the call, and should be cleaned up ???
7867 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7873 -- Create the inner block to protect the abortable part
7875 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7877 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7880 Make_Block_Statement
(Loc
,
7881 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7882 Handled_Statement_Sequence
=>
7883 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7884 Has_Created_Identifier
=> True,
7885 Is_Asynchronous_Call_Block
=> True);
7888 Make_Block_Statement
(Loc
,
7889 Handled_Statement_Sequence
=>
7890 Make_Handled_Sequence_Of_Statements
(Loc
,
7891 Statements
=> New_List
(
7892 Make_Implicit_Label_Declaration
(Loc
,
7893 Defining_Identifier
=> Blk_Ent
,
7894 Label_Construct
=> Abortable_Block
),
7896 Exception_Handlers
=> Hdle
)));
7898 -- Create new call statement
7900 Params
:= Parameter_Associations
(Call
);
7903 New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7904 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
7907 Make_Procedure_Call_Statement
(Loc
,
7908 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
7909 Parameter_Associations
=> Params
));
7911 -- Construct statement sequence for new block
7914 Make_Implicit_If_Statement
(N
,
7916 Make_Op_Not
(Loc
, New_Occurrence_Of
(Cancel_Param
, Loc
)),
7917 Then_Statements
=> Tstats
));
7919 -- Protected the call against abort
7921 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7924 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7926 -- The result is the new block
7929 Make_Block_Statement
(Loc
,
7930 Declarations
=> Decls
,
7931 Handled_Statement_Sequence
=>
7932 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7935 end Expand_N_Asynchronous_Select
;
7937 -------------------------------------
7938 -- Expand_N_Conditional_Entry_Call --
7939 -------------------------------------
7941 -- The conditional task entry call is converted to a call to
7946 -- P : parms := (parm, parm, parm);
7950 -- (<acceptor-task>, -- Acceptor
7951 -- <entry-index>, -- E
7952 -- P'Address, -- Uninterpreted_Data
7953 -- Conditional_Call, -- Mode
7954 -- B); -- Rendezvous_Successful
7959 -- normal-statements
7965 -- For a description of the use of P and the assignments after the call,
7966 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7967 -- conditional entry call has already been expanded (by the Expand_N_Entry
7968 -- _Call_Statement procedure) as follows:
7971 -- P : parms := (parm, parm, parm);
7973 -- ... info for in-out parameters
7974 -- Call_Simple (acceptor-task, entry-index, P'Address);
7980 -- so the task at hand is to convert the latter expansion into the former
7982 -- The conditional protected entry call is converted to a call to
7983 -- Protected_Entry_Call:
7986 -- P : parms := (parm, parm, parm);
7987 -- Bnn : Communications_Block;
7990 -- Protected_Entry_Call
7991 -- (po._object'Access, -- Object
7992 -- <entry index>, -- E
7993 -- P'Address, -- Uninterpreted_Data
7994 -- Conditional_Call, -- Mode
7999 -- if Cancelled (Bnn) then
8002 -- normal-statements
8006 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
8010 -- B : Boolean := False;
8011 -- C : Ada.Tags.Prim_Op_Kind;
8012 -- K : Ada.Tags.Tagged_Kind :=
8013 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8014 -- P : Parameters := (Param1 .. ParamN);
8018 -- if K = Ada.Tags.TK_Limited_Tagged
8019 -- or else K = Ada.Tags.TK_Tagged
8021 -- <dispatching-call>;
8022 -- <triggering-statements>
8026 -- Ada.Tags.Get_Offset_Index
8027 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
8029 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8031 -- if C = POK_Protected_Entry
8032 -- or else C = POK_Task_Entry
8034 -- Param1 := P.Param1;
8036 -- ParamN := P.ParamN;
8040 -- if C = POK_Procedure
8041 -- or else C = POK_Protected_Procedure
8042 -- or else C = POK_Task_Procedure
8044 -- <dispatching-call>;
8047 -- <triggering-statements>
8049 -- <else-statements>
8054 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
8055 Loc
: constant Source_Ptr
:= Sloc
(N
);
8056 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
8057 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
8060 Blk_Typ
: Entity_Id
;
8062 Call_Ent
: Entity_Id
;
8063 Conc_Typ_Stmts
: List_Id
;
8067 Lim_Typ_Stmts
: List_Id
;
8074 Transient_Blk
: Node_Id
;
8077 B
: Entity_Id
; -- Call status flag
8078 C
: Entity_Id
; -- Call kind
8079 K
: Entity_Id
; -- Tagged kind
8080 P
: Entity_Id
; -- Parameter block
8081 S
: Entity_Id
; -- Primitive operation slot
8084 Process_Statements_For_Controlled_Objects
(N
);
8086 if Ada_Version
>= Ada_2005
8087 and then Nkind
(Blk
) = N_Procedure_Call_Statement
8089 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
8094 -- Call status flag processing, generate:
8095 -- B : Boolean := False;
8097 B
:= Build_B
(Loc
, Decls
);
8099 -- Call kind processing, generate:
8100 -- C : Ada.Tags.Prim_Op_Kind;
8102 C
:= Build_C
(Loc
, Decls
);
8104 -- Tagged kind processing, generate:
8105 -- K : Ada.Tags.Tagged_Kind :=
8106 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8108 K
:= Build_K
(Loc
, Decls
, Obj
);
8110 -- Parameter block processing
8112 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
8113 P
:= Parameter_Block_Pack
8114 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
8116 -- Dispatch table slot processing, generate:
8119 S
:= Build_S
(Loc
, Decls
);
8122 -- S := Ada.Tags.Get_Offset_Index
8123 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
8126 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
8129 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8131 Append_To
(Conc_Typ_Stmts
,
8132 Make_Procedure_Call_Statement
(Loc
,
8135 Find_Prim_Op
(Etype
(Etype
(Obj
)),
8136 Name_uDisp_Conditional_Select
),
8138 Parameter_Associations
=>
8140 New_Copy_Tree
(Obj
), -- <object>
8141 New_Occurrence_Of
(S
, Loc
), -- S
8142 Make_Attribute_Reference
(Loc
, -- P'Address
8143 Prefix
=> New_Occurrence_Of
(P
, Loc
),
8144 Attribute_Name
=> Name_Address
),
8145 New_Occurrence_Of
(C
, Loc
), -- C
8146 New_Occurrence_Of
(B
, Loc
)))); -- B
8149 -- if C = POK_Protected_Entry
8150 -- or else C = POK_Task_Entry
8152 -- Param1 := P.Param1;
8154 -- ParamN := P.ParamN;
8157 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
8159 -- Generate the if statement only when the packed parameters need
8160 -- explicit assignments to their corresponding actuals.
8162 if Present
(Unpack
) then
8163 Append_To
(Conc_Typ_Stmts
,
8164 Make_Implicit_If_Statement
(N
,
8170 New_Occurrence_Of
(C
, Loc
),
8172 New_Occurrence_Of
(RTE
(
8173 RE_POK_Protected_Entry
), Loc
)),
8178 New_Occurrence_Of
(C
, Loc
),
8180 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
8182 Then_Statements
=> Unpack
));
8187 -- if C = POK_Procedure
8188 -- or else C = POK_Protected_Procedure
8189 -- or else C = POK_Task_Procedure
8191 -- <dispatching-call>
8193 -- <normal-statements>
8195 -- <else-statements>
8198 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
8200 Prepend_To
(N_Stats
,
8201 Make_Implicit_If_Statement
(N
,
8207 New_Occurrence_Of
(C
, Loc
),
8209 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
8216 New_Occurrence_Of
(C
, Loc
),
8218 New_Occurrence_Of
(RTE
(
8219 RE_POK_Protected_Procedure
), Loc
)),
8224 New_Occurrence_Of
(C
, Loc
),
8226 New_Occurrence_Of
(RTE
(
8227 RE_POK_Task_Procedure
), Loc
)))),
8232 Append_To
(Conc_Typ_Stmts
,
8233 Make_Implicit_If_Statement
(N
,
8234 Condition
=> New_Occurrence_Of
(B
, Loc
),
8235 Then_Statements
=> N_Stats
,
8236 Else_Statements
=> Else_Statements
(N
)));
8239 -- <dispatching-call>;
8240 -- <triggering-statements>
8242 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
8243 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
8246 -- if K = Ada.Tags.TK_Limited_Tagged
8247 -- or else K = Ada.Tags.TK_Tagged
8255 Make_Implicit_If_Statement
(N
,
8256 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
8257 Then_Statements
=> Lim_Typ_Stmts
,
8258 Else_Statements
=> Conc_Typ_Stmts
));
8261 Make_Block_Statement
(Loc
,
8264 Handled_Statement_Sequence
=>
8265 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8267 -- As described above, the entry alternative is transformed into a
8268 -- block that contains the gnulli call, and possibly assignment
8269 -- statements for in-out parameters. The gnulli call may itself be
8270 -- rewritten into a transient block if some unconstrained parameters
8271 -- require it. We need to retrieve the call to complete its parameter
8276 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
8278 if Present
(Transient_Blk
)
8279 and then Nkind
(Transient_Blk
) = N_Block_Statement
8281 Blk
:= Transient_Blk
;
8284 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
8285 Stmt
:= First
(Stmts
);
8286 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
8291 Params
:= Parameter_Associations
(Call
);
8293 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
8295 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8297 Param
:= First
(Params
);
8298 while Present
(Param
)
8299 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
8304 pragma Assert
(Present
(Param
));
8306 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8310 -- Find the Communication_Block parameter for the call to the
8311 -- Cancelled function.
8313 Decl
:= First
(Declarations
(Blk
));
8314 while Present
(Decl
)
8315 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
8316 RE_Communication_Block
)
8321 -- Add an if statement to execute the else part if the call
8322 -- does not succeed (as indicated by the Cancelled predicate).
8325 Make_Implicit_If_Statement
(N
,
8326 Condition
=> Make_Function_Call
(Loc
,
8327 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
8328 Parameter_Associations
=> New_List
(
8329 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))),
8330 Then_Statements
=> Else_Statements
(N
),
8331 Else_Statements
=> Statements
(Alt
)));
8334 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8336 -- Insert declaration of B in declarations of existing block
8338 if No
(Declarations
(Blk
)) then
8339 Set_Declarations
(Blk
, New_List
);
8342 Prepend_To
(Declarations
(Blk
),
8343 Make_Object_Declaration
(Loc
,
8344 Defining_Identifier
=> B
,
8345 Object_Definition
=>
8346 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8348 -- Create new call statement
8351 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8352 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
8355 Make_Procedure_Call_Statement
(Loc
,
8356 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
8357 Parameter_Associations
=> Params
));
8359 -- Construct statement sequence for new block
8362 Make_Implicit_If_Statement
(N
,
8363 Condition
=> New_Occurrence_Of
(B
, Loc
),
8364 Then_Statements
=> Statements
(Alt
),
8365 Else_Statements
=> Else_Statements
(N
)));
8368 -- The result is the new block
8371 Make_Block_Statement
(Loc
,
8372 Declarations
=> Declarations
(Blk
),
8373 Handled_Statement_Sequence
=>
8374 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8378 end Expand_N_Conditional_Entry_Call
;
8380 ---------------------------------------
8381 -- Expand_N_Delay_Relative_Statement --
8382 ---------------------------------------
8384 -- Delay statement is implemented as a procedure call to Delay_For
8385 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8386 -- simple delays imposed by the use of Protected Objects.
8388 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
8389 Loc
: constant Source_Ptr
:= Sloc
(N
);
8392 Make_Procedure_Call_Statement
(Loc
,
8393 Name
=> New_Occurrence_Of
(RTE
(RO_CA_Delay_For
), Loc
),
8394 Parameter_Associations
=> New_List
(Expression
(N
))));
8396 end Expand_N_Delay_Relative_Statement
;
8398 ------------------------------------
8399 -- Expand_N_Delay_Until_Statement --
8400 ------------------------------------
8402 -- Delay Until statement is implemented as a procedure call to
8403 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8405 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
8406 Loc
: constant Source_Ptr
:= Sloc
(N
);
8410 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
8411 Typ
:= RTE
(RO_CA_Delay_Until
);
8413 Typ
:= RTE
(RO_RT_Delay_Until
);
8417 Make_Procedure_Call_Statement
(Loc
,
8418 Name
=> New_Occurrence_Of
(Typ
, Loc
),
8419 Parameter_Associations
=> New_List
(Expression
(N
))));
8422 end Expand_N_Delay_Until_Statement
;
8424 -------------------------
8425 -- Expand_N_Entry_Body --
8426 -------------------------
8428 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
8430 -- Associate discriminals with the next protected operation body to be
8433 if Present
(Next_Protected_Operation
(N
)) then
8434 Set_Discriminals
(Parent
(Current_Scope
));
8436 end Expand_N_Entry_Body
;
8438 -----------------------------------
8439 -- Expand_N_Entry_Call_Statement --
8440 -----------------------------------
8442 -- An entry call is expanded into GNARLI calls to implement a simple entry
8443 -- call (see Build_Simple_Entry_Call).
8445 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
8451 if No_Run_Time_Mode
then
8452 Error_Msg_CRT
("entry call", N
);
8456 -- If this entry call is part of an asynchronous select, don't expand it
8457 -- here; it will be expanded with the select statement. Don't expand
8458 -- timed entry calls either, as they are translated into asynchronous
8461 -- ??? This whole approach is questionable; it may be better to go back
8462 -- to allowing the expansion to take place and then attempting to fix it
8463 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8464 -- whether the expanded call is on a task or protected entry.
8466 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
8467 or else N
/= Triggering_Statement
(Parent
(N
)))
8468 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8469 or else N
/= Entry_Call_Statement
(Parent
(N
))
8470 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8472 Extract_Entry
(N
, Concval
, Ename
, Index
);
8473 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8475 end Expand_N_Entry_Call_Statement
;
8477 --------------------------------
8478 -- Expand_N_Entry_Declaration --
8479 --------------------------------
8481 -- If there are parameters, then first, each of the formals is marked by
8482 -- setting Is_Entry_Formal. Next a record type is built which is used to
8483 -- hold the parameter values. The name of this record type is entryP where
8484 -- entry is the name of the entry, with an additional corresponding access
8485 -- type called entryPA. The record type has matching components for each
8486 -- formal (the component names are the same as the formal names). For
8487 -- elementary types, the component type matches the formal type. For
8488 -- composite types, an access type is declared (with the name formalA)
8489 -- which designates the formal type, and the type of the component is this
8490 -- access type. Finally the Entry_Component of each formal is set to
8491 -- reference the corresponding record component.
8493 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8494 Loc
: constant Source_Ptr
:= Sloc
(N
);
8495 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8496 Components
: List_Id
;
8499 Last_Decl
: Node_Id
;
8500 Component
: Entity_Id
;
8503 Rec_Ent
: Entity_Id
;
8504 Acc_Ent
: Entity_Id
;
8507 Formal
:= First_Formal
(Entry_Ent
);
8510 -- Most processing is done only if parameters are present
8512 if Present
(Formal
) then
8513 Components
:= New_List
;
8515 -- Loop through formals
8517 while Present
(Formal
) loop
8518 Set_Is_Entry_Formal
(Formal
);
8520 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8521 Set_Entry_Component
(Formal
, Component
);
8522 Set_Entry_Formal
(Component
, Formal
);
8523 Ftype
:= Etype
(Formal
);
8525 -- Declare new access type and then append
8527 Ctype
:= Make_Temporary
(Loc
, 'A');
8528 Set_Is_Param_Block_Component_Type
(Ctype
);
8531 Make_Full_Type_Declaration
(Loc
,
8532 Defining_Identifier
=> Ctype
,
8534 Make_Access_To_Object_Definition
(Loc
,
8535 All_Present
=> True,
8536 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8537 Subtype_Indication
=> New_Occurrence_Of
(Ftype
, Loc
)));
8539 Insert_After
(Last_Decl
, Decl
);
8542 Append_To
(Components
,
8543 Make_Component_Declaration
(Loc
,
8544 Defining_Identifier
=> Component
,
8545 Component_Definition
=>
8546 Make_Component_Definition
(Loc
,
8547 Aliased_Present
=> False,
8548 Subtype_Indication
=> New_Occurrence_Of
(Ctype
, Loc
))));
8550 Next_Formal_With_Extras
(Formal
);
8553 -- Create the Entry_Parameter_Record declaration
8555 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8558 Make_Full_Type_Declaration
(Loc
,
8559 Defining_Identifier
=> Rec_Ent
,
8561 Make_Record_Definition
(Loc
,
8563 Make_Component_List
(Loc
,
8564 Component_Items
=> Components
)));
8566 Insert_After
(Last_Decl
, Decl
);
8569 -- Construct and link in the corresponding access type
8571 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8573 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8576 Make_Full_Type_Declaration
(Loc
,
8577 Defining_Identifier
=> Acc_Ent
,
8579 Make_Access_To_Object_Definition
(Loc
,
8580 All_Present
=> True,
8581 Subtype_Indication
=> New_Occurrence_Of
(Rec_Ent
, Loc
)));
8583 Insert_After
(Last_Decl
, Decl
);
8585 end Expand_N_Entry_Declaration
;
8587 -----------------------------
8588 -- Expand_N_Protected_Body --
8589 -----------------------------
8591 -- Protected bodies are expanded to the completion of the subprograms
8592 -- created for the corresponding protected type. These are a protected and
8593 -- unprotected version of each protected subprogram in the object, a
8594 -- function to calculate each entry barrier, and a procedure to execute the
8595 -- sequence of statements of each protected entry body. For example, for
8596 -- protected type ptype:
8599 -- (O : System.Address;
8600 -- E : Protected_Entry_Index)
8603 -- <discriminant renamings>
8604 -- <private object renamings>
8606 -- return <barrier expression>;
8609 -- procedure pprocN (_object : in out poV;...) is
8610 -- <discriminant renamings>
8611 -- <private object renamings>
8613 -- <sequence of statements>
8616 -- procedure pprocP (_object : in out poV;...) is
8617 -- procedure _clean is
8620 -- ptypeS (_object, Pn);
8621 -- Unlock (_object._object'Access);
8622 -- Abort_Undefer.all;
8627 -- Lock (_object._object'Access);
8628 -- pprocN (_object;...);
8633 -- function pfuncN (_object : poV;...) return Return_Type is
8634 -- <discriminant renamings>
8635 -- <private object renamings>
8637 -- <sequence of statements>
8640 -- function pfuncP (_object : poV) return Return_Type is
8641 -- procedure _clean is
8643 -- Unlock (_object._object'Access);
8644 -- Abort_Undefer.all;
8649 -- Lock (_object._object'Access);
8650 -- return pfuncN (_object);
8657 -- (O : System.Address;
8658 -- P : System.Address;
8659 -- E : Protected_Entry_Index)
8661 -- <discriminant renamings>
8662 -- <private object renamings>
8663 -- type poVP is access poV;
8664 -- _Object : ptVP := ptVP!(O);
8668 -- <statement sequence>
8669 -- Complete_Entry_Body (_Object._Object);
8671 -- when all others =>
8672 -- Exceptional_Complete_Entry_Body (
8673 -- _Object._Object, Get_GNAT_Exception);
8677 -- The type poV is the record created for the protected type to hold
8678 -- the state of the protected object.
8680 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8681 Loc
: constant Source_Ptr
:= Sloc
(N
);
8682 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8684 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8685 -- This flag indicates whether the lock free implementation is active
8687 Current_Node
: Node_Id
;
8688 Disp_Op_Body
: Node_Id
;
8689 New_Op_Body
: Node_Id
;
8693 function Build_Dispatching_Subprogram_Body
8696 Prot_Bod
: Node_Id
) return Node_Id
;
8697 -- Build a dispatching version of the protected subprogram body. The
8698 -- newly generated subprogram contains a call to the original protected
8699 -- body. The following code is generated:
8701 -- function <protected-function-name> (Param1 .. ParamN) return
8704 -- return <protected-function-name>P (Param1 .. ParamN);
8705 -- end <protected-function-name>;
8709 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8711 -- <protected-procedure-name>P (Param1 .. ParamN);
8712 -- end <protected-procedure-name>
8714 ---------------------------------------
8715 -- Build_Dispatching_Subprogram_Body --
8716 ---------------------------------------
8718 function Build_Dispatching_Subprogram_Body
8721 Prot_Bod
: Node_Id
) return Node_Id
8723 Loc
: constant Source_Ptr
:= Sloc
(N
);
8730 -- Generate a specification without a letter suffix in order to
8731 -- override an interface function or procedure.
8733 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8735 -- The formal parameters become the actuals of the protected function
8736 -- or procedure call.
8738 Actuals
:= New_List
;
8739 Formal
:= First
(Parameter_Specifications
(Spec
));
8740 while Present
(Formal
) loop
8742 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8746 if Nkind
(Spec
) = N_Procedure_Specification
then
8749 Make_Procedure_Call_Statement
(Loc
,
8751 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8752 Parameter_Associations
=> Actuals
));
8755 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8759 Make_Simple_Return_Statement
(Loc
,
8761 Make_Function_Call
(Loc
,
8763 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8764 Parameter_Associations
=> Actuals
)));
8768 Make_Subprogram_Body
(Loc
,
8769 Declarations
=> Empty_List
,
8770 Specification
=> Spec
,
8771 Handled_Statement_Sequence
=>
8772 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8773 end Build_Dispatching_Subprogram_Body
;
8775 -- Start of processing for Expand_N_Protected_Body
8778 if No_Run_Time_Mode
then
8779 Error_Msg_CRT
("protected body", N
);
8783 -- This is the proper body corresponding to a stub. The declarations
8784 -- must be inserted at the point of the stub, which in turn is in the
8785 -- declarative part of the parent unit.
8787 if Nkind
(Parent
(N
)) = N_Subunit
then
8788 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8793 Op_Body
:= First
(Declarations
(N
));
8795 -- The protected body is replaced with the bodies of its
8796 -- protected operations, and the declarations for internal objects
8797 -- that may have been created for entry family bounds.
8799 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8802 while Present
(Op_Body
) loop
8803 case Nkind
(Op_Body
) is
8804 when N_Subprogram_Declaration
=>
8807 when N_Subprogram_Body
=>
8809 -- Do not create bodies for eliminated operations
8811 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8812 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8814 if Lock_Free_Active
then
8816 Build_Lock_Free_Unprotected_Subprogram_Body
8820 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8823 Insert_After
(Current_Node
, New_Op_Body
);
8824 Current_Node
:= New_Op_Body
;
8825 Analyze
(New_Op_Body
);
8827 -- Build the corresponding protected operation. It may
8828 -- appear that this is needed only if this is a visible
8829 -- operation of the type, or if it is an interrupt handler,
8830 -- and this was the strategy used previously in GNAT.
8832 -- However, the operation may be exported through a 'Access
8833 -- to an external caller. This is the common idiom in code
8834 -- that uses the Ada 2005 Timing_Events package. As a result
8835 -- we need to produce the protected body for both visible
8836 -- and private operations, as well as operations that only
8837 -- have a body in the source, and for which we create a
8838 -- declaration in the protected body itself.
8840 if Present
(Corresponding_Spec
(Op_Body
)) then
8841 if Lock_Free_Active
then
8843 Build_Lock_Free_Protected_Subprogram_Body
8844 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8847 Build_Protected_Subprogram_Body
8848 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8851 Insert_After
(Current_Node
, New_Op_Body
);
8852 Analyze
(New_Op_Body
);
8854 Current_Node
:= New_Op_Body
;
8856 -- Generate an overriding primitive operation body for
8857 -- this subprogram if the protected type implements an
8860 if Ada_Version
>= Ada_2005
8862 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
8865 Build_Dispatching_Subprogram_Body
8866 (Op_Body
, Pid
, New_Op_Body
);
8868 Insert_After
(Current_Node
, Disp_Op_Body
);
8869 Analyze
(Disp_Op_Body
);
8871 Current_Node
:= Disp_Op_Body
;
8876 when N_Entry_Body
=>
8877 Op_Id
:= Defining_Identifier
(Op_Body
);
8878 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8880 Insert_After
(Current_Node
, New_Op_Body
);
8881 Current_Node
:= New_Op_Body
;
8882 Analyze
(New_Op_Body
);
8884 when N_Implicit_Label_Declaration
=>
8887 when N_Itype_Reference
=>
8888 Insert_After
(Current_Node
, New_Copy
(Op_Body
));
8890 when N_Freeze_Entity
=>
8891 New_Op_Body
:= New_Copy
(Op_Body
);
8893 if Present
(Entity
(Op_Body
))
8894 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8896 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8899 Insert_After
(Current_Node
, New_Op_Body
);
8900 Current_Node
:= New_Op_Body
;
8901 Analyze
(New_Op_Body
);
8904 New_Op_Body
:= New_Copy
(Op_Body
);
8905 Insert_After
(Current_Node
, New_Op_Body
);
8906 Current_Node
:= New_Op_Body
;
8907 Analyze
(New_Op_Body
);
8909 when N_Object_Declaration
=>
8910 pragma Assert
(not Comes_From_Source
(Op_Body
));
8911 New_Op_Body
:= New_Copy
(Op_Body
);
8912 Insert_After
(Current_Node
, New_Op_Body
);
8913 Current_Node
:= New_Op_Body
;
8914 Analyze
(New_Op_Body
);
8917 raise Program_Error
;
8924 -- Finally, create the body of the function that maps an entry index
8925 -- into the corresponding body index, except when there is no entry, or
8926 -- in a Ravenscar-like profile.
8928 if Corresponding_Runtime_Package
(Pid
) =
8929 System_Tasking_Protected_Objects_Entries
8931 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8932 Insert_After
(Current_Node
, New_Op_Body
);
8933 Current_Node
:= New_Op_Body
;
8934 Analyze
(New_Op_Body
);
8937 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8938 -- protected body. At this point all wrapper specs have been created,
8939 -- frozen and included in the dispatch table for the protected type.
8941 if Ada_Version
>= Ada_2005
then
8942 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8944 end Expand_N_Protected_Body
;
8946 -----------------------------------------
8947 -- Expand_N_Protected_Type_Declaration --
8948 -----------------------------------------
8950 -- First we create a corresponding record type declaration used to
8951 -- represent values of this protected type.
8952 -- The general form of this type declaration is
8954 -- type poV (discriminants) is record
8955 -- _Object : aliased <kind>Protection
8956 -- [(<entry count> [, <handler count>])];
8957 -- [entry_family : array (bounds) of Void;]
8958 -- <private data fields>
8961 -- The discriminants are present only if the corresponding protected type
8962 -- has discriminants, and they exactly mirror the protected type
8963 -- discriminants. The private data fields similarly mirror the private
8964 -- declarations of the protected type.
8966 -- The Object field is always present. It contains RTS specific data used
8967 -- to control the protected object. It is declared as Aliased so that it
8968 -- can be passed as a pointer to the RTS. This allows the protected record
8969 -- to be referenced within RTS data structures. An appropriate Protection
8970 -- type and discriminant are generated.
8972 -- The Service field is present for protected objects with entries. It
8973 -- contains sufficient information to allow the entry service procedure for
8974 -- this object to be called when the object is not known till runtime.
8976 -- One entry_family component is present for each entry family in the
8977 -- task definition (see Expand_N_Task_Type_Declaration).
8979 -- When a protected object is declared, an instance of the protected type
8980 -- value record is created. The elaboration of this declaration creates the
8981 -- correct bounds for the entry families, and also evaluates the priority
8982 -- expression if needed. The initialization routine for the protected type
8983 -- itself then calls Initialize_Protection with appropriate parameters to
8984 -- initialize the value of the Task_Id field. Install_Handlers may be also
8985 -- called if a pragma Attach_Handler applies.
8987 -- Note: this record is passed to the subprograms created by the expansion
8988 -- of protected subprograms and entries. It is an in parameter to protected
8989 -- functions and an in out parameter to procedures and entry bodies. The
8990 -- Entity_Id for this created record type is placed in the
8991 -- Corresponding_Record_Type field of the associated protected type entity.
8993 -- Next we create a procedure specifications for protected subprograms and
8994 -- entry bodies. For each protected subprograms two subprograms are
8995 -- created, an unprotected and a protected version. The unprotected version
8996 -- is called from within other operations of the same protected object.
8998 -- We also build the call to register the procedure if a pragma
8999 -- Interrupt_Handler applies.
9001 -- A single subprogram is created to service all entry bodies; it has an
9002 -- additional boolean out parameter indicating that the previous entry call
9003 -- made by the current task was serviced immediately, i.e. not by proxy.
9004 -- The O parameter contains a pointer to a record object of the type
9005 -- described above. An untyped interface is used here to allow this
9006 -- procedure to be called in places where the type of the object to be
9007 -- serviced is not known. This must be done, for example, when a call that
9008 -- may have been requeued is cancelled; the corresponding object must be
9009 -- serviced, but which object that is not known till runtime.
9012 -- (O : System.Address; P : out Boolean);
9013 -- procedure pprocN (_object : in out poV);
9014 -- procedure pproc (_object : in out poV);
9015 -- function pfuncN (_object : poV);
9016 -- function pfunc (_object : poV);
9019 -- Note that this must come after the record type declaration, since
9020 -- the specs refer to this type.
9022 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
9023 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
9024 Loc
: constant Source_Ptr
:= Sloc
(N
);
9025 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
9027 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
9028 -- This flag indicates whether the lock free implementation is active
9030 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
9031 -- This contains two lists; one for visible and one for private decls
9034 Body_Id
: Entity_Id
;
9037 Current_Node
: Node_Id
:= N
;
9039 Entries_Aggr
: Node_Id
;
9041 Object_Comp
: Node_Id
;
9045 procedure Check_Inlining
(Subp
: Entity_Id
);
9046 -- If the original operation has a pragma Inline, propagate the flag
9047 -- to the internal body, for possible inlining later on. The source
9048 -- operation is invisible to the back-end and is never actually called.
9050 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean;
9051 -- If a component size is not static then a warning will be emitted
9052 -- in Ravenscar or other restricted contexts. When a component is non-
9053 -- static because of a discriminant constraint we can specialize the
9054 -- warning by mentioning discriminants explicitly.
9056 procedure Expand_Entry_Declaration
(Decl
: Node_Id
);
9057 -- Create the entry barrier and the procedure body for entry declaration
9058 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
9060 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
9061 -- When compiling under the Ravenscar profile, private components must
9062 -- have a static size, or else a protected object will require heap
9063 -- allocation, violating the corresponding restriction. It is preferable
9064 -- to make this check here, because it provides a better error message
9065 -- than the back-end, which refers to the object as a whole.
9067 procedure Register_Handler
;
9068 -- For a protected operation that is an interrupt handler, add the
9069 -- freeze action that will register it as such.
9071 --------------------
9072 -- Check_Inlining --
9073 --------------------
9075 procedure Check_Inlining
(Subp
: Entity_Id
) is
9077 if Is_Inlined
(Subp
) then
9078 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
9079 Set_Is_Inlined
(Subp
, False);
9083 ------------------------
9084 -- Discriminated_Size --
9085 ------------------------
9087 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
9088 Typ
: constant Entity_Id
:= Etype
(Comp
);
9091 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
9092 -- Check whether the bound of an index is non-static and does denote
9093 -- a discriminant, in which case any protected object of the type
9094 -- will have a non-static size.
9096 ----------------------
9097 -- Non_Static_Bound --
9098 ----------------------
9100 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
9102 if Is_OK_Static_Expression
(Bound
) then
9105 elsif Is_Entity_Name
(Bound
)
9106 and then Present
(Discriminal_Link
(Entity
(Bound
)))
9113 end Non_Static_Bound
;
9115 -- Start of processing for Discriminated_Size
9118 if not Is_Array_Type
(Typ
) then
9122 if Ekind
(Typ
) = E_Array_Subtype
then
9123 Index
:= First_Index
(Typ
);
9124 while Present
(Index
) loop
9125 if Non_Static_Bound
(Low_Bound
(Index
))
9126 or else Non_Static_Bound
(High_Bound
(Index
))
9138 end Discriminated_Size
;
9140 ---------------------------
9141 -- Static_Component_Size --
9142 ---------------------------
9144 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
9145 Typ
: constant Entity_Id
:= Etype
(Comp
);
9149 if Is_Scalar_Type
(Typ
) then
9152 elsif Is_Array_Type
(Typ
) then
9153 return Compile_Time_Known_Bounds
(Typ
);
9155 elsif Is_Record_Type
(Typ
) then
9156 C
:= First_Component
(Typ
);
9157 while Present
(C
) loop
9158 if not Static_Component_Size
(C
) then
9167 -- Any other type will be checked by the back-end
9172 end Static_Component_Size
;
9174 ------------------------------
9175 -- Expand_Entry_Declaration --
9176 ------------------------------
9178 procedure Expand_Entry_Declaration
(Decl
: Node_Id
) is
9179 Ent_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
9185 E_Count
:= E_Count
+ 1;
9187 -- Create the protected body subprogram
9190 Make_Defining_Identifier
(Loc
,
9191 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'E'));
9192 Set_Protected_Body_Subprogram
(Ent_Id
, Bod_Id
);
9195 Make_Subprogram_Declaration
(Loc
,
9197 Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Ent_Id
));
9199 Insert_After
(Current_Node
, Subp
);
9200 Current_Node
:= Subp
;
9204 -- Build a wrapper procedure to handle contract cases, preconditions,
9205 -- and postconditions.
9207 Build_Contract_Wrapper
(Ent_Id
, N
);
9209 -- Create the barrier function
9212 Make_Defining_Identifier
(Loc
,
9213 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'B'));
9214 Set_Barrier_Function
(Ent_Id
, Bar_Id
);
9217 Make_Subprogram_Declaration
(Loc
,
9219 Build_Barrier_Function_Specification
(Loc
, Bar_Id
));
9220 Set_Is_Entry_Barrier_Function
(Subp
);
9222 Insert_After
(Current_Node
, Subp
);
9223 Current_Node
:= Subp
;
9227 Set_Protected_Body_Subprogram
(Bar_Id
, Bar_Id
);
9228 Set_Scope
(Bar_Id
, Scope
(Ent_Id
));
9230 -- Collect pointers to the protected subprogram and the barrier
9231 -- of the current entry, for insertion into Entry_Bodies_Array.
9233 Append_To
(Expressions
(Entries_Aggr
),
9234 Make_Aggregate
(Loc
,
9235 Expressions
=> New_List
(
9236 Make_Attribute_Reference
(Loc
,
9237 Prefix
=> New_Occurrence_Of
(Bar_Id
, Loc
),
9238 Attribute_Name
=> Name_Unrestricted_Access
),
9239 Make_Attribute_Reference
(Loc
,
9240 Prefix
=> New_Occurrence_Of
(Bod_Id
, Loc
),
9241 Attribute_Name
=> Name_Unrestricted_Access
))));
9242 end Expand_Entry_Declaration
;
9244 ----------------------
9245 -- Register_Handler --
9246 ----------------------
9248 procedure Register_Handler
is
9250 -- All semantic checks already done in Sem_Prag
9252 Prot_Proc
: constant Entity_Id
:=
9253 Defining_Unit_Name
(Specification
(Current_Node
));
9255 Proc_Address
: constant Node_Id
:=
9256 Make_Attribute_Reference
(Loc
,
9258 New_Occurrence_Of
(Prot_Proc
, Loc
),
9259 Attribute_Name
=> Name_Address
);
9261 RTS_Call
: constant Entity_Id
:=
9262 Make_Procedure_Call_Statement
(Loc
,
9265 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
9266 Parameter_Associations
=> New_List
(Proc_Address
));
9268 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
9269 end Register_Handler
;
9275 -- Start of processing for Expand_N_Protected_Type_Declaration
9278 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
9281 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
9284 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
9286 Qualify_Entity_Names
(N
);
9288 -- If the type has discriminants, their occurrences in the declaration
9289 -- have been replaced by the corresponding discriminals. For components
9290 -- that are constrained by discriminants, their homologues in the
9291 -- corresponding record type must refer to the discriminants of that
9292 -- record, so we must apply a new renaming to subtypes_indications:
9294 -- protected discriminant => discriminal => record discriminant
9296 -- This replacement is not applied to default expressions, for which
9297 -- the discriminal is correct.
9299 if Has_Discriminants
(Prot_Typ
) then
9305 Disc
:= First_Discriminant
(Prot_Typ
);
9306 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
9307 while Present
(Disc
) loop
9308 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
9309 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
9310 Next_Discriminant
(Disc
);
9316 -- Fill in the component declarations
9318 -- Add components for entry families. For each entry family, create an
9319 -- anonymous type declaration with the same size, and analyze the type.
9321 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
9323 pragma Assert
(Present
(Pdef
));
9325 -- Add private field components
9327 if Present
(Private_Declarations
(Pdef
)) then
9328 Priv
:= First
(Private_Declarations
(Pdef
));
9329 while Present
(Priv
) loop
9330 if Nkind
(Priv
) = N_Component_Declaration
then
9331 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
9333 -- When compiling for a restricted profile, the private
9334 -- components must have a static size. If not, this is an
9335 -- error for a single protected declaration, and rates a
9336 -- warning on a protected type declaration.
9338 if not Comes_From_Source
(Prot_Typ
) then
9340 -- It's ok to be checking this restriction at expansion
9341 -- time, because this is only for the restricted profile,
9342 -- which is not subject to strict RM conformance, so it
9343 -- is OK to miss this check in -gnatc mode.
9345 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
9347 (No_Implicit_Protected_Object_Allocations
, Priv
);
9349 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
9350 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9352 -- Any object of the type will be non-static.
9354 Error_Msg_N
("component has non-static size??", Priv
);
9356 ("\creation of protected object of type& will "
9357 & "violate restriction "
9358 & "No_Implicit_Heap_Allocations??", Priv
, Prot_Typ
);
9361 -- Object will be non-static if discriminants are.
9364 ("creation of protected object of type& with "
9365 & "non-static discriminants will violate"
9366 & " restriction No_Implicit_Heap_Allocations??",
9370 -- Likewise for No_Implicit_Protected_Object_Allocations
9372 elsif Restriction_Active
9373 (No_Implicit_Protected_Object_Allocations
)
9375 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9377 -- Any object of the type will be non-static.
9379 Error_Msg_N
("component has non-static size??", Priv
);
9381 ("\creation of protected object of type& will "
9382 & "violate restriction "
9383 & "No_Implicit_Protected_Object_Allocations??",
9386 -- Object will be non-static if discriminants are.
9389 ("creation of protected object of type& with "
9390 & "non-static discriminants will violate "
9392 & "No_Implicit_Protected_Object_Allocations??",
9398 -- The component definition consists of a subtype indication,
9399 -- or (in Ada 2005) an access definition. Make a copy of the
9400 -- proper definition.
9403 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
9404 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
9405 Nent
: constant Entity_Id
:=
9406 Make_Defining_Identifier
(Sloc
(Oent
),
9407 Chars
=> Chars
(Oent
));
9411 if Present
(Subtype_Indication
(Old_Comp
)) then
9413 Make_Component_Definition
(Sloc
(Oent
),
9414 Aliased_Present
=> False,
9415 Subtype_Indication
=>
9417 (Subtype_Indication
(Old_Comp
), Discr_Map
));
9420 Make_Component_Definition
(Sloc
(Oent
),
9421 Aliased_Present
=> False,
9422 Access_Definition
=>
9424 (Access_Definition
(Old_Comp
), Discr_Map
));
9428 Make_Component_Declaration
(Loc
,
9429 Defining_Identifier
=> Nent
,
9430 Component_Definition
=> New_Comp
,
9431 Expression
=> Expression
(Priv
));
9433 Set_Has_Per_Object_Constraint
(Nent
,
9434 Has_Per_Object_Constraint
(Oent
));
9436 Append_To
(Cdecls
, New_Priv
);
9439 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
9441 -- Make the unprotected version of the subprogram available
9442 -- for expansion of intra object calls. There is need for
9443 -- a protected version only if the subprogram is an interrupt
9444 -- handler, otherwise this operation can only be called from
9448 Make_Subprogram_Declaration
(Loc
,
9450 Build_Protected_Sub_Specification
9451 (Priv
, Prot_Typ
, Unprotected_Mode
));
9453 Insert_After
(Current_Node
, Sub
);
9456 Set_Protected_Body_Subprogram
9457 (Defining_Unit_Name
(Specification
(Priv
)),
9458 Defining_Unit_Name
(Specification
(Sub
)));
9459 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
9460 Current_Node
:= Sub
;
9463 Make_Subprogram_Declaration
(Loc
,
9465 Build_Protected_Sub_Specification
9466 (Priv
, Prot_Typ
, Protected_Mode
));
9468 Insert_After
(Current_Node
, Sub
);
9470 Current_Node
:= Sub
;
9472 if Is_Interrupt_Handler
9473 (Defining_Unit_Name
(Specification
(Priv
)))
9475 if not Restricted_Profile
then
9485 -- Except for the lock-free implementation, append the _Object field
9486 -- with the right type to the component list. We need to compute the
9487 -- number of entries, and in some cases the number of Attach_Handler
9490 if not Lock_Free_Active
then
9492 Entry_Count_Expr
: constant Node_Id
:=
9493 Build_Entry_Count_Expression
9494 (Prot_Typ
, Cdecls
, Loc
);
9495 Num_Attach_Handler
: Int
:= 0;
9496 Protection_Subtype
: Node_Id
;
9500 if Has_Attach_Handler
(Prot_Typ
) then
9501 Ritem
:= First_Rep_Item
(Prot_Typ
);
9502 while Present
(Ritem
) loop
9503 if Nkind
(Ritem
) = N_Pragma
9504 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
9506 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
9509 Next_Rep_Item
(Ritem
);
9513 -- Determine the proper protection type. There are two special
9514 -- cases: 1) when the protected type has dynamic interrupt
9515 -- handlers, and 2) when it has static handlers and we use a
9516 -- restricted profile.
9518 if Has_Attach_Handler
(Prot_Typ
)
9519 and then not Restricted_Profile
9521 Protection_Subtype
:=
9522 Make_Subtype_Indication
(Loc
,
9525 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
9527 Make_Index_Or_Discriminant_Constraint
(Loc
,
9528 Constraints
=> New_List
(
9530 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
9532 elsif Has_Interrupt_Handler
(Prot_Typ
)
9533 and then not Restriction_Active
(No_Dynamic_Attachment
)
9535 Protection_Subtype
:=
9536 Make_Subtype_Indication
(Loc
,
9539 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
9541 Make_Index_Or_Discriminant_Constraint
(Loc
,
9542 Constraints
=> New_List
(Entry_Count_Expr
)));
9545 case Corresponding_Runtime_Package
(Prot_Typ
) is
9546 when System_Tasking_Protected_Objects_Entries
=>
9547 Protection_Subtype
:=
9548 Make_Subtype_Indication
(Loc
,
9551 (RTE
(RE_Protection_Entries
), Loc
),
9553 Make_Index_Or_Discriminant_Constraint
(Loc
,
9554 Constraints
=> New_List
(Entry_Count_Expr
)));
9556 when System_Tasking_Protected_Objects_Single_Entry
=>
9557 Protection_Subtype
:=
9558 New_Occurrence_Of
(RTE
(RE_Protection_Entry
), Loc
);
9560 when System_Tasking_Protected_Objects
=>
9561 Protection_Subtype
:=
9562 New_Occurrence_Of
(RTE
(RE_Protection
), Loc
);
9565 raise Program_Error
;
9570 Make_Component_Declaration
(Loc
,
9571 Defining_Identifier
=>
9572 Make_Defining_Identifier
(Loc
, Name_uObject
),
9573 Component_Definition
=>
9574 Make_Component_Definition
(Loc
,
9575 Aliased_Present
=> True,
9576 Subtype_Indication
=> Protection_Subtype
));
9579 -- Put the _Object component after the private component so that it
9580 -- be finalized early as required by 9.4 (20)
9582 Append_To
(Cdecls
, Object_Comp
);
9585 Insert_After
(Current_Node
, Rec_Decl
);
9586 Current_Node
:= Rec_Decl
;
9588 -- Analyze the record declaration immediately after construction,
9589 -- because the initialization procedure is needed for single object
9590 -- declarations before the next entity is analyzed (the freeze call
9591 -- that generates this initialization procedure is found below).
9593 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
9595 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9596 -- the corresponding record is frozen. If any wrappers are generated,
9597 -- Current_Node is updated accordingly.
9599 if Ada_Version
>= Ada_2005
then
9600 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
9603 -- Collect pointers to entry bodies and their barriers, to be placed
9604 -- in the Entry_Bodies_Array for the type. For each entry/family we
9605 -- add an expression to the aggregate which is the initial value of
9606 -- this array. The array is declared after all protected subprograms.
9608 if Has_Entries
(Prot_Typ
) then
9609 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
9611 Entries_Aggr
:= Empty
;
9614 -- Build two new procedure specifications for each protected subprogram;
9615 -- one to call from outside the object and one to call from inside.
9616 -- Build a barrier function and an entry body action procedure
9617 -- specification for each protected entry. Initialize the entry body
9618 -- array. If subprogram is flagged as eliminated, do not generate any
9619 -- internal operations.
9622 Comp
:= First
(Visible_Declarations
(Pdef
));
9623 while Present
(Comp
) loop
9624 if Nkind
(Comp
) = N_Subprogram_Declaration
then
9626 Make_Subprogram_Declaration
(Loc
,
9628 Build_Protected_Sub_Specification
9629 (Comp
, Prot_Typ
, Unprotected_Mode
));
9631 Insert_After
(Current_Node
, Sub
);
9634 Set_Protected_Body_Subprogram
9635 (Defining_Unit_Name
(Specification
(Comp
)),
9636 Defining_Unit_Name
(Specification
(Sub
)));
9637 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
9639 -- Make the protected version of the subprogram available for
9640 -- expansion of external calls.
9642 Current_Node
:= Sub
;
9645 Make_Subprogram_Declaration
(Loc
,
9647 Build_Protected_Sub_Specification
9648 (Comp
, Prot_Typ
, Protected_Mode
));
9650 Insert_After
(Current_Node
, Sub
);
9653 Current_Node
:= Sub
;
9655 -- Generate an overriding primitive operation specification for
9656 -- this subprogram if the protected type implements an interface.
9658 if Ada_Version
>= Ada_2005
9660 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9663 Make_Subprogram_Declaration
(Loc
,
9665 Build_Protected_Sub_Specification
9666 (Comp
, Prot_Typ
, Dispatching_Mode
));
9668 Insert_After
(Current_Node
, Sub
);
9671 Current_Node
:= Sub
;
9674 -- If a pragma Interrupt_Handler applies, build and add a call to
9675 -- Register_Interrupt_Handler to the freezing actions of the
9676 -- protected version (Current_Node) of the subprogram:
9678 -- system.interrupts.register_interrupt_handler
9679 -- (prot_procP'address);
9681 if not Restricted_Profile
9682 and then Is_Interrupt_Handler
9683 (Defining_Unit_Name
(Specification
(Comp
)))
9688 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9689 Expand_Entry_Declaration
(Comp
);
9695 -- If there are some private entry declarations, expand it as if they
9696 -- were visible entries.
9698 if Present
(Private_Declarations
(Pdef
)) then
9699 Comp
:= First
(Private_Declarations
(Pdef
));
9700 while Present
(Comp
) loop
9701 if Nkind
(Comp
) = N_Entry_Declaration
then
9702 Expand_Entry_Declaration
(Comp
);
9709 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9710 -- all protected subprograms have been collected.
9712 if Has_Entries
(Prot_Typ
) then
9714 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9715 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9717 case Corresponding_Runtime_Package
(Prot_Typ
) is
9718 when System_Tasking_Protected_Objects_Entries
=>
9720 Make_Object_Declaration
(Loc
,
9721 Defining_Identifier
=> Body_Id
,
9722 Aliased_Present
=> True,
9723 Object_Definition
=>
9724 Make_Subtype_Indication
(Loc
,
9727 (RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9729 Make_Index_Or_Discriminant_Constraint
(Loc
,
9730 Constraints
=> New_List
(
9732 Make_Integer_Literal
(Loc
, 1),
9733 Make_Integer_Literal
(Loc
, E_Count
))))),
9734 Expression
=> Entries_Aggr
);
9736 when System_Tasking_Protected_Objects_Single_Entry
=>
9738 Make_Object_Declaration
(Loc
,
9739 Defining_Identifier
=> Body_Id
,
9740 Aliased_Present
=> True,
9741 Object_Definition
=>
9742 New_Occurrence_Of
(RTE
(RE_Entry_Body
), Loc
),
9743 Expression
=> Remove_Head
(Expressions
(Entries_Aggr
)));
9746 raise Program_Error
;
9749 -- A pointer to this array will be placed in the corresponding record
9750 -- by its initialization procedure so this needs to be analyzed here.
9752 Insert_After
(Current_Node
, Body_Arr
);
9753 Current_Node
:= Body_Arr
;
9756 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9758 -- Finally, build the function that maps an entry index into the
9759 -- corresponding body. A pointer to this function is placed in each
9760 -- object of the type. Except for a ravenscar-like profile (no abort,
9761 -- no entry queue, 1 entry)
9763 if Corresponding_Runtime_Package
(Prot_Typ
) =
9764 System_Tasking_Protected_Objects_Entries
9767 Make_Subprogram_Declaration
(Loc
,
9768 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9769 Insert_After
(Current_Node
, Sub
);
9773 end Expand_N_Protected_Type_Declaration
;
9775 --------------------------------
9776 -- Expand_N_Requeue_Statement --
9777 --------------------------------
9779 -- A non-dispatching requeue statement is expanded into one of four GNARLI
9780 -- operations, depending on the source and destination (task or protected
9781 -- object). A dispatching requeue statement is expanded into a call to the
9782 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9783 -- jump around the remainder of processing for the original entry and, if
9784 -- the destination is (different) protected object, to attempt to service
9785 -- it. The following illustrates the various cases:
9788 -- (O : System.Address;
9789 -- P : System.Address;
9790 -- E : Protected_Entry_Index)
9792 -- <discriminant renamings>
9793 -- <private object renamings>
9794 -- type poVP is access poV;
9795 -- _object : ptVP := ptVP!(O);
9799 -- <start of statement sequence for entry>
9801 -- -- Requeue from one protected entry body to another protected
9804 -- Requeue_Protected_Entry (
9805 -- _object._object'Access,
9806 -- new._object'Access,
9811 -- <some more of the statement sequence for entry>
9813 -- -- Requeue from an entry body to a task entry
9815 -- Requeue_Protected_To_Task_Entry (
9821 -- <rest of statement sequence for entry>
9822 -- Complete_Entry_Body (_object._object);
9825 -- when all others =>
9826 -- Exceptional_Complete_Entry_Body (
9827 -- _object._object, Get_GNAT_Exception);
9831 -- Requeue of a task entry call to a task entry
9833 -- Accept_Call (E, Ann);
9834 -- <start of statement sequence for accept statement>
9835 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9837 -- <rest of statement sequence for accept statement>
9839 -- Complete_Rendezvous;
9842 -- when all others =>
9843 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9845 -- Requeue of a task entry call to a protected entry
9847 -- Accept_Call (E, Ann);
9848 -- <start of statement sequence for accept statement>
9849 -- Requeue_Task_To_Protected_Entry (
9850 -- new._object'Access,
9855 -- <rest of statement sequence for accept statement>
9857 -- Complete_Rendezvous;
9860 -- when all others =>
9861 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9863 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9864 -- marked by pragma Implemented (XXX, By_Entry).
9866 -- The requeue is inside a protected entry:
9869 -- (O : System.Address;
9870 -- P : System.Address;
9871 -- E : Protected_Entry_Index)
9873 -- <discriminant renamings>
9874 -- <private object renamings>
9875 -- type poVP is access poV;
9876 -- _object : ptVP := ptVP!(O);
9880 -- <start of statement sequence for entry>
9883 -- (<interface class-wide object>,
9886 -- Ada.Tags.Get_Offset_Index
9888 -- <interface dispatch table index of target entry>),
9892 -- <rest of statement sequence for entry>
9893 -- Complete_Entry_Body (_object._object);
9896 -- when all others =>
9897 -- Exceptional_Complete_Entry_Body (
9898 -- _object._object, Get_GNAT_Exception);
9902 -- The requeue is inside a task entry:
9904 -- Accept_Call (E, Ann);
9905 -- <start of statement sequence for accept statement>
9907 -- (<interface class-wide object>,
9910 -- Ada.Tags.Get_Offset_Index
9912 -- <interface dispatch table index of target entrt>),
9916 -- <rest of statement sequence for accept statement>
9918 -- Complete_Rendezvous;
9921 -- when all others =>
9922 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9924 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9925 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9926 -- statement is replaced by a dispatching call with actual parameters taken
9927 -- from the inner-most accept statement or entry body.
9929 -- Target.Primitive (Param1, ..., ParamN);
9931 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9932 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9936 -- S : constant Offset_Index :=
9937 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9938 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9941 -- if C = POK_Protected_Entry
9942 -- or else C = POK_Task_Entry
9944 -- <statements for dispatching requeue>
9946 -- elsif C = POK_Protected_Procedure then
9947 -- <dispatching call equivalent>
9950 -- raise Program_Error;
9954 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
9955 Loc
: constant Source_Ptr
:= Sloc
(N
);
9956 Conc_Typ
: Entity_Id
;
9960 Old_Typ
: Entity_Id
;
9962 function Build_Dispatching_Call_Equivalent
return Node_Id
;
9963 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9964 -- the form Concval.Ename. It is statically known that Ename is allowed
9965 -- to be implemented by a protected procedure. Create a dispatching call
9966 -- equivalent of Concval.Ename taking the actual parameters from the
9967 -- inner-most accept statement or entry body.
9969 function Build_Dispatching_Requeue
return Node_Id
;
9970 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9971 -- the form Concval.Ename. It is statically known that Ename is allowed
9972 -- to be implemented by a protected or a task entry. Create a call to
9973 -- primitive _Disp_Requeue which handles the low-level actions.
9975 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
9976 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9977 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9978 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9979 -- determines at runtime whether Ename denotes an entry or a procedure
9980 -- and perform the appropriate kind of dispatching select.
9982 function Build_Normal_Requeue
return Node_Id
;
9983 -- N denotes a non-dispatching requeue statement to either a task or a
9984 -- protected entry. Build the appropriate runtime call to perform the
9987 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
9988 -- For a protected entry, create a return statement to skip the rest of
9989 -- the entry body. Otherwise, create a goto statement to skip the rest
9990 -- of a task accept statement. The lookup for the enclosing entry body
9991 -- or accept statement starts from Search.
9993 ---------------------------------------
9994 -- Build_Dispatching_Call_Equivalent --
9995 ---------------------------------------
9997 function Build_Dispatching_Call_Equivalent
return Node_Id
is
9998 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
9999 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10006 -- Climb the parent chain looking for the inner-most entry body or
10007 -- accept statement.
10010 while Present
(Acc_Ent
)
10011 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
10014 Acc_Ent
:= Parent
(Acc_Ent
);
10017 -- A requeue statement should be housed inside an entry body or an
10018 -- accept statement at some level. If this is not the case, then the
10019 -- tree is malformed.
10021 pragma Assert
(Present
(Acc_Ent
));
10023 -- Recover the list of formal parameters
10025 if Nkind
(Acc_Ent
) = N_Entry_Body
then
10026 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
10029 Formals
:= Parameter_Specifications
(Acc_Ent
);
10031 -- Create the actual parameters for the dispatching call. These are
10032 -- simply copies of the entry body or accept statement formals in the
10033 -- same order as they appear.
10035 Actuals
:= No_List
;
10037 if Present
(Formals
) then
10038 Actuals
:= New_List
;
10039 Formal
:= First
(Formals
);
10040 while Present
(Formal
) loop
10041 Append_To
(Actuals
,
10042 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
10048 -- Obj.Call_Ent (Actuals);
10051 Make_Procedure_Call_Statement
(Loc
,
10053 Make_Selected_Component
(Loc
,
10054 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
10055 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
10057 Parameter_Associations
=> Actuals
);
10058 end Build_Dispatching_Call_Equivalent
;
10060 -------------------------------
10061 -- Build_Dispatching_Requeue --
10062 -------------------------------
10064 function Build_Dispatching_Requeue
return Node_Id
is
10065 Params
: constant List_Id
:= New_List
;
10068 -- Process the "with abort" parameter
10070 Prepend_To
(Params
,
10071 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10073 -- Process the entry wrapper's position in the primary dispatch
10074 -- table parameter. Generate:
10076 -- Ada.Tags.Get_Entry_Index
10077 -- (T => To_Tag_Ptr (Obj'Address).all,
10079 -- Ada.Tags.Get_Offset_Index
10080 -- (Ada.Tags.Tag (Concval),
10081 -- <interface dispatch table position of Ename>));
10083 -- Note that Obj'Address is recursively expanded into a call to
10084 -- Base_Address (Obj).
10086 if Tagged_Type_Expansion
then
10087 Prepend_To
(Params
,
10088 Make_Function_Call
(Loc
,
10089 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10090 Parameter_Associations
=> New_List
(
10092 Make_Explicit_Dereference
(Loc
,
10093 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
10094 Make_Attribute_Reference
(Loc
,
10095 Prefix
=> New_Copy_Tree
(Concval
),
10096 Attribute_Name
=> Name_Address
))),
10098 Make_Function_Call
(Loc
,
10099 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10100 Parameter_Associations
=> New_List
(
10101 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
10102 Make_Integer_Literal
(Loc
,
10103 DT_Position
(Entity
(Ename
))))))));
10108 Prepend_To
(Params
,
10109 Make_Function_Call
(Loc
,
10110 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10111 Parameter_Associations
=> New_List
(
10113 Make_Attribute_Reference
(Loc
,
10115 Attribute_Name
=> Name_Tag
),
10117 Make_Function_Call
(Loc
,
10118 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10120 Parameter_Associations
=> New_List
(
10124 Make_Attribute_Reference
(Loc
,
10126 Attribute_Name
=> Name_Tag
),
10130 Make_Attribute_Reference
(Loc
,
10131 Prefix
=> New_Occurrence_Of
(Etype
(Concval
), Loc
),
10132 Attribute_Name
=> Name_Tag
),
10136 Make_Integer_Literal
(Loc
,
10137 DT_Position
(Entity
(Ename
))))))));
10140 -- Specific actuals for protected to XXX requeue
10142 if Is_Protected_Type
(Old_Typ
) then
10143 Prepend_To
(Params
,
10144 Make_Attribute_Reference
(Loc
, -- _object'Address
10146 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10147 Attribute_Name
=> Name_Address
));
10149 Prepend_To
(Params
, -- True
10150 New_Occurrence_Of
(Standard_True
, Loc
));
10152 -- Specific actuals for task to XXX requeue
10155 pragma Assert
(Is_Task_Type
(Old_Typ
));
10157 Prepend_To
(Params
, -- null
10158 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
10160 Prepend_To
(Params
, -- False
10161 New_Occurrence_Of
(Standard_False
, Loc
));
10164 -- Add the object parameter
10166 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
10169 -- _Disp_Requeue (<Params>);
10171 -- Find entity for Disp_Requeue operation, which belongs to
10172 -- the type and may not be directly visible.
10179 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
10180 while Present
(Elmt
) loop
10182 exit when Chars
(Op
) = Name_uDisp_Requeue
;
10187 Make_Procedure_Call_Statement
(Loc
,
10188 Name
=> New_Occurrence_Of
(Op
, Loc
),
10189 Parameter_Associations
=> Params
);
10191 end Build_Dispatching_Requeue
;
10193 --------------------------------------
10194 -- Build_Dispatching_Requeue_To_Any --
10195 --------------------------------------
10197 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
10198 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10199 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10200 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
10210 -- Dispatch table slot processing, generate:
10213 S
:= Build_S
(Loc
, Decls
);
10215 -- Call kind processing, generate:
10216 -- C : Ada.Tags.Prim_Op_Kind;
10218 C
:= Build_C
(Loc
, Decls
);
10221 -- S := Ada.Tags.Get_Offset_Index
10222 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10224 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10227 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10230 Make_Procedure_Call_Statement
(Loc
,
10232 New_Occurrence_Of
(
10233 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10234 Name_uDisp_Get_Prim_Op_Kind
),
10236 Parameter_Associations
=> New_List
(
10237 New_Copy_Tree
(Obj
),
10238 New_Occurrence_Of
(S
, Loc
),
10239 New_Occurrence_Of
(C
, Loc
))));
10243 -- if C = POK_Protected_Entry
10244 -- or else C = POK_Task_Entry
10247 Make_Implicit_If_Statement
(N
,
10253 New_Occurrence_Of
(C
, Loc
),
10255 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
10260 New_Occurrence_Of
(C
, Loc
),
10262 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
10264 -- Dispatching requeue equivalent
10266 Then_Statements
=> New_List
(
10267 Build_Dispatching_Requeue
,
10270 -- elsif C = POK_Protected_Procedure then
10272 Elsif_Parts
=> New_List
(
10273 Make_Elsif_Part
(Loc
,
10277 New_Occurrence_Of
(C
, Loc
),
10279 New_Occurrence_Of
(
10280 RTE
(RE_POK_Protected_Procedure
), Loc
)),
10282 -- Dispatching call equivalent
10284 Then_Statements
=> New_List
(
10285 Build_Dispatching_Call_Equivalent
))),
10288 -- raise Program_Error;
10291 Else_Statements
=> New_List
(
10292 Make_Raise_Program_Error
(Loc
,
10293 Reason
=> PE_Explicit_Raise
))));
10295 -- Wrap everything into a block
10298 Make_Block_Statement
(Loc
,
10299 Declarations
=> Decls
,
10300 Handled_Statement_Sequence
=>
10301 Make_Handled_Sequence_Of_Statements
(Loc
,
10302 Statements
=> Stmts
));
10303 end Build_Dispatching_Requeue_To_Any
;
10305 --------------------------
10306 -- Build_Normal_Requeue --
10307 --------------------------
10309 function Build_Normal_Requeue
return Node_Id
is
10310 Params
: constant List_Id
:= New_List
;
10315 -- Process the "with abort" parameter
10317 Prepend_To
(Params
,
10318 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10320 -- Add the index expression to the parameters. It is common among all
10323 Prepend_To
(Params
,
10324 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
10326 if Is_Protected_Type
(Old_Typ
) then
10328 Self_Param
: Node_Id
;
10332 Make_Attribute_Reference
(Loc
,
10334 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10336 Name_Unchecked_Access
);
10338 -- Protected to protected requeue
10340 if Is_Protected_Type
(Conc_Typ
) then
10342 New_Occurrence_Of
(
10343 RTE
(RE_Requeue_Protected_Entry
), Loc
);
10346 Make_Attribute_Reference
(Loc
,
10348 Concurrent_Ref
(Concval
),
10350 Name_Unchecked_Access
);
10352 -- Protected to task requeue
10354 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10356 New_Occurrence_Of
(
10357 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
10359 Param
:= Concurrent_Ref
(Concval
);
10362 Prepend_To
(Params
, Param
);
10363 Prepend_To
(Params
, Self_Param
);
10366 else pragma Assert
(Is_Task_Type
(Old_Typ
));
10368 -- Task to protected requeue
10370 if Is_Protected_Type
(Conc_Typ
) then
10372 New_Occurrence_Of
(
10373 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
10376 Make_Attribute_Reference
(Loc
,
10378 Concurrent_Ref
(Concval
),
10380 Name_Unchecked_Access
);
10382 -- Task to task requeue
10384 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10386 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
);
10388 Param
:= Concurrent_Ref
(Concval
);
10391 Prepend_To
(Params
, Param
);
10395 Make_Procedure_Call_Statement
(Loc
,
10397 Parameter_Associations
=> Params
);
10398 end Build_Normal_Requeue
;
10400 --------------------------
10401 -- Build_Skip_Statement --
10402 --------------------------
10404 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
10405 Skip_Stmt
: Node_Id
;
10408 -- Build a return statement to skip the rest of the entire body
10410 if Is_Protected_Type
(Old_Typ
) then
10411 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
10413 -- If the requeue is within a task, find the end label of the
10414 -- enclosing accept statement and create a goto statement to it.
10422 -- Climb the parent chain looking for the enclosing accept
10425 Acc
:= Parent
(Search
);
10426 while Present
(Acc
)
10427 and then Nkind
(Acc
) /= N_Accept_Statement
10429 Acc
:= Parent
(Acc
);
10432 -- The last statement is the second label used for completing
10433 -- the rendezvous the usual way. The label we are looking for
10434 -- is right before it.
10437 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
10439 pragma Assert
(Nkind
(Label
) = N_Label
);
10441 -- Generate a goto statement to skip the rest of the accept
10444 Make_Goto_Statement
(Loc
,
10446 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
10450 Set_Analyzed
(Skip_Stmt
);
10453 end Build_Skip_Statement
;
10455 -- Start of processing for Expand_N_Requeue_Statement
10458 -- Extract the components of the entry call
10460 Extract_Entry
(N
, Concval
, Ename
, Index
);
10461 Conc_Typ
:= Etype
(Concval
);
10463 -- If the prefix is an access to class-wide type, dereference to get
10464 -- object and entry type.
10466 if Is_Access_Type
(Conc_Typ
) then
10467 Conc_Typ
:= Designated_Type
(Conc_Typ
);
10469 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Concval
)));
10470 Analyze_And_Resolve
(Concval
, Conc_Typ
);
10473 -- Examine the scope stack in order to find nearest enclosing protected
10474 -- or task type. This will constitute our invocation source.
10476 Old_Typ
:= Current_Scope
;
10477 while Present
(Old_Typ
)
10478 and then not Is_Protected_Type
(Old_Typ
)
10479 and then not Is_Task_Type
(Old_Typ
)
10481 Old_Typ
:= Scope
(Old_Typ
);
10484 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10485 -- Concval.Ename where the type of Concval is class-wide concurrent
10488 if Ada_Version
>= Ada_2012
10489 and then Present
(Concval
)
10490 and then Is_Class_Wide_Type
(Conc_Typ
)
10491 and then Is_Concurrent_Interface
(Conc_Typ
)
10494 Has_Impl
: Boolean := False;
10495 Impl_Kind
: Name_Id
:= No_Name
;
10498 -- Check whether the Ename is flagged by pragma Implemented
10500 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
10502 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
10505 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10506 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10508 if Has_Impl
and then Impl_Kind
= Name_By_Entry
then
10509 Rewrite
(N
, Build_Dispatching_Requeue
);
10511 Insert_After
(N
, Build_Skip_Statement
(N
));
10513 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10514 -- a protected procedure. In this case the requeue is transformed
10515 -- into a dispatching call.
10518 and then Impl_Kind
= Name_By_Protected_Procedure
10520 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
10523 -- The procedure_or_entry_NAME's implementation kind is either
10524 -- By_Any, Optional, or pragma Implemented was not applied at all.
10525 -- In this case a runtime test determines whether Ename denotes an
10526 -- entry or a protected procedure and performs the appropriate
10530 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
10535 -- Processing for regular (non-dispatching) requeues
10538 Rewrite
(N
, Build_Normal_Requeue
);
10540 Insert_After
(N
, Build_Skip_Statement
(N
));
10542 end Expand_N_Requeue_Statement
;
10544 -------------------------------
10545 -- Expand_N_Selective_Accept --
10546 -------------------------------
10548 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10549 Loc
: constant Source_Ptr
:= Sloc
(N
);
10550 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10552 -- Note: in the below declarations a lot of new lists are allocated
10553 -- unconditionally which may well not end up being used. That's not
10554 -- a good idea since it wastes space gratuitously ???
10556 Accept_Case
: List_Id
;
10557 Accept_List
: constant List_Id
:= New_List
;
10560 Alt_List
: constant List_Id
:= New_List
;
10561 Alt_Stats
: List_Id
;
10562 Ann
: Entity_Id
:= Empty
;
10564 Check_Guard
: Boolean := True;
10566 Decls
: constant List_Id
:= New_List
;
10567 Stats
: constant List_Id
:= New_List
;
10568 Body_List
: constant List_Id
:= New_List
;
10569 Trailing_List
: constant List_Id
:= New_List
;
10572 Else_Present
: Boolean := False;
10573 Terminate_Alt
: Node_Id
:= Empty
;
10574 Select_Mode
: Node_Id
;
10576 Delay_Case
: List_Id
;
10577 Delay_Count
: Integer := 0;
10578 Delay_Val
: Entity_Id
;
10579 Delay_Index
: Entity_Id
;
10580 Delay_Min
: Entity_Id
;
10581 Delay_Num
: Int
:= 1;
10582 Delay_Alt_List
: List_Id
:= New_List
;
10583 Delay_List
: constant List_Id
:= New_List
;
10587 First_Delay
: Boolean := True;
10588 Guard_Open
: Entity_Id
;
10594 Num_Accept
: Nat
:= 0;
10596 Time_Type
: Entity_Id
;
10597 Select_Call
: Node_Id
;
10599 Qnam
: constant Entity_Id
:=
10600 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10602 Xnam
: constant Entity_Id
:=
10603 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10605 -----------------------
10606 -- Local subprograms --
10607 -----------------------
10609 function Accept_Or_Raise
return List_Id
;
10610 -- For the rare case where delay alternatives all have guards, and
10611 -- all of them are closed, it is still possible that there were open
10612 -- accept alternatives with no callers. We must reexamine the
10613 -- Accept_List, and execute a selective wait with no else if some
10614 -- accept is open. If none, we raise program_error.
10616 procedure Add_Accept
(Alt
: Node_Id
);
10617 -- Process a single accept statement in a select alternative. Build
10618 -- procedure for body of accept, and add entry to dispatch table with
10619 -- expression for guard, in preparation for call to run time select.
10621 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10622 -- Manufacture a label using Num as a serial number and declare it.
10623 -- The declaration is appended to Decls. The label marks the trailing
10624 -- statements of an accept or delay alternative.
10626 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10627 -- Build call to Selective_Wait runtime routine
10629 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10630 -- Add code to compare value of delay with previous values, and
10631 -- generate case entry for trailing statements.
10633 procedure Process_Accept_Alternative
10637 -- Add code to call corresponding procedure, and branch to
10638 -- trailing statements, if any.
10640 ---------------------
10641 -- Accept_Or_Raise --
10642 ---------------------
10644 function Accept_Or_Raise
return List_Id
is
10647 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10650 -- We generate the following:
10652 -- for J in q'range loop
10653 -- if q(J).S /=null_task_entry then
10654 -- selective_wait (simple_mode,...);
10660 -- if no rendez_vous then
10661 -- raise program_error;
10664 -- Note that the code needs to know that the selector name
10665 -- in an Accept_Alternative is named S.
10667 Cond
:= Make_Op_Ne
(Loc
,
10669 Make_Selected_Component
(Loc
,
10671 Make_Indexed_Component
(Loc
,
10672 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10673 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))),
10674 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10676 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Loc
));
10678 Stats
:= New_List
(
10679 Make_Implicit_Loop_Statement
(N
,
10680 Iteration_Scheme
=>
10681 Make_Iteration_Scheme
(Loc
,
10682 Loop_Parameter_Specification
=>
10683 Make_Loop_Parameter_Specification
(Loc
,
10684 Defining_Identifier
=> J
,
10685 Discrete_Subtype_Definition
=>
10686 Make_Attribute_Reference
(Loc
,
10687 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10688 Attribute_Name
=> Name_Range
,
10689 Expressions
=> New_List
(
10690 Make_Integer_Literal
(Loc
, 1))))),
10692 Statements
=> New_List
(
10693 Make_Implicit_If_Statement
(N
,
10695 Then_Statements
=> New_List
(
10697 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)),
10698 Make_Exit_Statement
(Loc
))))));
10701 Make_Raise_Program_Error
(Loc
,
10702 Condition
=> Make_Op_Eq
(Loc
,
10703 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
10705 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
10706 Reason
=> PE_All_Guards_Closed
));
10709 end Accept_Or_Raise
;
10715 procedure Add_Accept
(Alt
: Node_Id
) is
10716 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10717 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10718 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10719 Eent
: constant Entity_Id
:= Entity
(Ename
);
10720 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10721 Null_Body
: Node_Id
;
10722 Proc_Body
: Node_Id
;
10723 PB_Ent
: Entity_Id
;
10729 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10732 if Present
(Condition
(Alt
)) then
10734 Make_If_Expression
(Eloc
, New_List
(
10736 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10737 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10740 Entry_Index_Expression
10741 (Eloc
, Eent
, Index
, Scope
(Eent
));
10744 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10745 Null_Body
:= New_Occurrence_Of
(Standard_False
, Eloc
);
10747 -- Always add call to Abort_Undefer when generating code, since
10748 -- this is what the runtime expects (abort deferred in
10749 -- Selective_Wait). In CodePeer mode this only confuses the
10750 -- analysis with unknown calls, so don't do it.
10752 if not CodePeer_Mode
then
10753 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10755 (First
(Statements
(Handled_Statement_Sequence
10756 (Accept_Statement
(Alt
)))),
10762 Make_Defining_Identifier
(Eloc
,
10763 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10765 if Comes_From_Source
(Alt
) then
10766 Set_Debug_Info_Needed
(PB_Ent
);
10770 Make_Subprogram_Body
(Eloc
,
10772 Make_Procedure_Specification
(Eloc
,
10773 Defining_Unit_Name
=> PB_Ent
),
10774 Declarations
=> Declarations
(Acc_Stm
),
10775 Handled_Statement_Sequence
=>
10776 Build_Accept_Body
(Accept_Statement
(Alt
)));
10778 -- During the analysis of the body of the accept statement, any
10779 -- zero cost exception handler records were collected in the
10780 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10781 -- This is where we move them to where they belong, namely the
10782 -- newly created procedure.
10784 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10785 Append
(Proc_Body
, Body_List
);
10788 Null_Body
:= New_Occurrence_Of
(Standard_True
, Eloc
);
10790 -- if accept statement has declarations, insert above, given that
10791 -- we are not creating a body for the accept.
10793 if Present
(Declarations
(Acc_Stm
)) then
10794 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10798 Append_To
(Accept_List
,
10799 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10801 Num_Accept
:= Num_Accept
+ 1;
10804 ----------------------------
10805 -- Make_And_Declare_Label --
10806 ----------------------------
10808 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10812 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10814 Make_Label
(Loc
, Lab_Id
);
10817 Make_Implicit_Label_Declaration
(Loc
,
10818 Defining_Identifier
=>
10819 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10820 Label_Construct
=> Lab
));
10823 end Make_And_Declare_Label
;
10825 ----------------------
10826 -- Make_Select_Call --
10827 ----------------------
10829 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10830 Params
: constant List_Id
:= New_List
;
10834 Make_Attribute_Reference
(Loc
,
10835 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10836 Attribute_Name
=> Name_Unchecked_Access
));
10837 Append_To
(Params
, Select_Mode
);
10838 Append_To
(Params
, New_Occurrence_Of
(Ann
, Loc
));
10839 Append_To
(Params
, New_Occurrence_Of
(Xnam
, Loc
));
10842 Make_Procedure_Call_Statement
(Loc
,
10843 Name
=> New_Occurrence_Of
(RTE
(RE_Selective_Wait
), Loc
),
10844 Parameter_Associations
=> Params
);
10845 end Make_Select_Call
;
10847 --------------------------------
10848 -- Process_Accept_Alternative --
10849 --------------------------------
10851 procedure Process_Accept_Alternative
10856 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10857 Alt_Stats
: List_Id
;
10860 Adjust_Condition
(Condition
(Alt
));
10862 -- Accept with body
10864 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10867 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10870 (Defining_Unit_Name
(Specification
(Proc
)),
10873 -- Accept with no body (followed by trailing statements)
10876 Alt_Stats
:= Empty_List
;
10879 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
10881 -- After the call, if any, branch to trailing statements, if any.
10882 -- We create a label for each, as well as the corresponding label
10885 if not Is_Empty_List
(Statements
(Alt
)) then
10886 Lab
:= Make_And_Declare_Label
(Index
);
10887 Append
(Lab
, Trailing_List
);
10888 Append_List
(Statements
(Alt
), Trailing_List
);
10889 Append_To
(Trailing_List
,
10890 Make_Goto_Statement
(Loc
,
10891 Name
=> New_Copy
(Identifier
(End_Lab
))));
10897 Append_To
(Alt_Stats
,
10898 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
10900 Append_To
(Alt_List
,
10901 Make_Case_Statement_Alternative
(Loc
,
10902 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
10903 Statements
=> Alt_Stats
));
10904 end Process_Accept_Alternative
;
10906 -------------------------------
10907 -- Process_Delay_Alternative --
10908 -------------------------------
10910 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
10911 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
10913 Delay_Alt
: List_Id
;
10916 -- Deal with C/Fortran boolean as delay condition
10918 Adjust_Condition
(Condition
(Alt
));
10920 -- Determine the smallest specified delay
10922 -- for each delay alternative generate:
10924 -- if guard-expression then
10925 -- Delay_Val := delay-expression;
10926 -- Guard_Open := True;
10927 -- if Delay_Val < Delay_Min then
10928 -- Delay_Min := Delay_Val;
10929 -- Delay_Index := Index;
10933 -- The enclosing if-statement is omitted if there is no guard
10935 if Delay_Count
= 1 or else First_Delay
then
10936 First_Delay
:= False;
10938 Delay_Alt
:= New_List
(
10939 Make_Assignment_Statement
(Loc
,
10940 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10941 Expression
=> Expression
(Delay_Statement
(Alt
))));
10943 if Delay_Count
> 1 then
10944 Append_To
(Delay_Alt
,
10945 Make_Assignment_Statement
(Loc
,
10946 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10947 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
10951 Delay_Alt
:= New_List
(
10952 Make_Assignment_Statement
(Loc
,
10953 Name
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10954 Expression
=> Expression
(Delay_Statement
(Alt
))));
10956 if Time_Type
= Standard_Duration
then
10959 Left_Opnd
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10960 Right_Opnd
=> New_Occurrence_Of
(Delay_Min
, Loc
));
10963 -- The scope of the time type must define a comparison
10964 -- operator. The scope itself may not be visible, so we
10965 -- construct a node with entity information to insure that
10966 -- semantic analysis can find the proper operator.
10969 Make_Function_Call
(Loc
,
10970 Name
=> Make_Selected_Component
(Loc
,
10972 New_Occurrence_Of
(Scope
(Time_Type
), Loc
),
10974 Make_Operator_Symbol
(Loc
,
10975 Chars
=> Name_Op_Lt
,
10976 Strval
=> No_String
)),
10977 Parameter_Associations
=>
10979 New_Occurrence_Of
(Delay_Val
, Loc
),
10980 New_Occurrence_Of
(Delay_Min
, Loc
)));
10982 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
10985 Append_To
(Delay_Alt
,
10986 Make_Implicit_If_Statement
(N
,
10988 Then_Statements
=> New_List
(
10989 Make_Assignment_Statement
(Loc
,
10990 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10991 Expression
=> New_Occurrence_Of
(Delay_Val
, Loc
)),
10993 Make_Assignment_Statement
(Loc
,
10994 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10995 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
10998 if Check_Guard
then
10999 Append_To
(Delay_Alt
,
11000 Make_Assignment_Statement
(Loc
,
11001 Name
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11002 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11005 if Present
(Condition
(Alt
)) then
11006 Delay_Alt
:= New_List
(
11007 Make_Implicit_If_Statement
(N
,
11008 Condition
=> Condition
(Alt
),
11009 Then_Statements
=> Delay_Alt
));
11012 Append_List
(Delay_Alt
, Delay_List
);
11014 Ensure_Statement_Present
(Dloc
, Alt
);
11016 -- If the delay alternative has a statement part, add choice to the
11017 -- case statements for delays.
11019 if not Is_Empty_List
(Statements
(Alt
)) then
11021 if Delay_Count
= 1 then
11022 Append_List
(Statements
(Alt
), Delay_Alt_List
);
11025 Append_To
(Delay_Alt_List
,
11026 Make_Case_Statement_Alternative
(Loc
,
11027 Discrete_Choices
=> New_List
(
11028 Make_Integer_Literal
(Loc
, Index
)),
11029 Statements
=> Statements
(Alt
)));
11032 elsif Delay_Count
= 1 then
11034 -- If the single delay has no trailing statements, add a branch
11035 -- to the exit label to the selective wait.
11037 Delay_Alt_List
:= New_List
(
11038 Make_Goto_Statement
(Loc
,
11039 Name
=> New_Copy
(Identifier
(End_Lab
))));
11042 end Process_Delay_Alternative
;
11044 -- Start of processing for Expand_N_Selective_Accept
11047 Process_Statements_For_Controlled_Objects
(N
);
11049 -- First insert some declarations before the select. The first is:
11053 -- This variable holds the parameters passed to the accept body. This
11054 -- declaration has already been inserted by the time we get here by
11055 -- a call to Expand_Accept_Declarations made from the semantics when
11056 -- processing the first accept statement contained in the select. We
11057 -- can find this entity as Accept_Address (E), where E is any of the
11058 -- entries references by contained accept statements.
11060 -- The first step is to scan the list of Selective_Accept_Statements
11061 -- to find this entity, and also count the number of accepts, and
11062 -- determine if terminated, delay or else is present:
11066 Alt
:= First
(Alts
);
11067 while Present
(Alt
) loop
11068 Process_Statements_For_Controlled_Objects
(Alt
);
11070 if Nkind
(Alt
) = N_Accept_Alternative
then
11073 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11074 Delay_Count
:= Delay_Count
+ 1;
11076 -- If the delays are relative delays, the delay expressions have
11077 -- type Standard_Duration. Otherwise they must have some time type
11078 -- recognized by GNAT.
11080 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
11081 Time_Type
:= Standard_Duration
;
11083 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
11085 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
11086 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
11091 "& is not a time type (RM 9.6(6))",
11092 Expression
(Delay_Statement
(Alt
)), Time_Type
);
11093 Time_Type
:= Standard_Duration
;
11094 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
11098 if No
(Condition
(Alt
)) then
11100 -- This guard will always be open
11102 Check_Guard
:= False;
11105 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
11106 Adjust_Condition
(Condition
(Alt
));
11107 Terminate_Alt
:= Alt
;
11110 Num_Alts
:= Num_Alts
+ 1;
11114 Else_Present
:= Present
(Else_Statements
(N
));
11116 -- At the same time (see procedure Add_Accept) we build the accept list:
11118 -- Qnn : Accept_List (1 .. num-select) := (
11119 -- (null-body, entry-index),
11120 -- (null-body, entry-index),
11122 -- (null_body, entry-index));
11124 -- In the above declaration, null-body is True if the corresponding
11125 -- accept has no body, and false otherwise. The entry is either the
11126 -- entry index expression if there is no guard, or if a guard is
11127 -- present, then an if expression of the form:
11129 -- (if guard then entry-index else Null_Task_Entry)
11131 -- If a guard is statically known to be false, the entry can simply
11132 -- be omitted from the accept list.
11135 Make_Object_Declaration
(Loc
,
11136 Defining_Identifier
=> Qnam
,
11137 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11138 Aliased_Present
=> True,
11140 Make_Qualified_Expression
(Loc
,
11142 New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11144 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
11146 -- Then we declare the variable that holds the index for the accept
11147 -- that will be selected for service:
11149 -- Xnn : Select_Index;
11152 Make_Object_Declaration
(Loc
,
11153 Defining_Identifier
=> Xnam
,
11154 Object_Definition
=>
11155 New_Occurrence_Of
(RTE
(RE_Select_Index
), Loc
),
11157 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)));
11159 -- After this follow procedure declarations for each accept body
11161 -- procedure Pnn is
11166 -- where the ... are statements from the corresponding procedure body.
11167 -- No parameters are involved, since the parameters are passed via Ann
11168 -- and the parameter references have already been expanded to be direct
11169 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11170 -- any embedded tasking statements (which would normally be illegal in
11171 -- procedures), have been converted to calls to the tasking runtime so
11172 -- there is no problem in putting them into procedures.
11174 -- The original accept statement has been expanded into a block in
11175 -- the same fashion as for simple accepts (see Build_Accept_Body).
11177 -- Note: we don't really need to build these procedures for the case
11178 -- where no delay statement is present, but it is just as easy to
11179 -- build them unconditionally, and not significantly inefficient,
11180 -- since if they are short they will be inlined anyway.
11182 -- The procedure declarations have been assembled in Body_List
11184 -- If delays are present, we must compute the required delay.
11185 -- We first generate the declarations:
11187 -- Delay_Index : Boolean := 0;
11188 -- Delay_Min : Some_Time_Type.Time;
11189 -- Delay_Val : Some_Time_Type.Time;
11191 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11192 -- active delay that is actually chosen as the basis for the possible
11193 -- delay if an immediate rendez-vous is not possible.
11195 -- In the most common case there is a single delay statement, and this
11196 -- is handled specially.
11198 if Delay_Count
> 0 then
11200 -- Generate the required declarations
11203 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
11205 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
11207 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
11210 Make_Object_Declaration
(Loc
,
11211 Defining_Identifier
=> Delay_Val
,
11212 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
)));
11215 Make_Object_Declaration
(Loc
,
11216 Defining_Identifier
=> Delay_Index
,
11217 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11218 Expression
=> Make_Integer_Literal
(Loc
, 0)));
11221 Make_Object_Declaration
(Loc
,
11222 Defining_Identifier
=> Delay_Min
,
11223 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
),
11225 Unchecked_Convert_To
(Time_Type
,
11226 Make_Attribute_Reference
(Loc
,
11228 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
11229 Attribute_Name
=> Name_Last
))));
11231 -- Create Duration and Delay_Mode objects used for passing a delay
11234 D
:= Make_Temporary
(Loc
, 'D');
11235 M
:= Make_Temporary
(Loc
, 'M');
11241 -- Note that these values are defined in s-osprim.ads and must
11242 -- be kept in sync:
11244 -- Relative : constant := 0;
11245 -- Absolute_Calendar : constant := 1;
11246 -- Absolute_RT : constant := 2;
11248 if Time_Type
= Standard_Duration
then
11249 Discr
:= Make_Integer_Literal
(Loc
, 0);
11251 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11252 Discr
:= Make_Integer_Literal
(Loc
, 1);
11256 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11257 Discr
:= Make_Integer_Literal
(Loc
, 2);
11261 Make_Object_Declaration
(Loc
,
11262 Defining_Identifier
=> D
,
11263 Object_Definition
=>
11264 New_Occurrence_Of
(Standard_Duration
, Loc
)));
11267 Make_Object_Declaration
(Loc
,
11268 Defining_Identifier
=> M
,
11269 Object_Definition
=>
11270 New_Occurrence_Of
(Standard_Integer
, Loc
),
11271 Expression
=> Discr
));
11274 if Check_Guard
then
11276 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
11279 Make_Object_Declaration
(Loc
,
11280 Defining_Identifier
=> Guard_Open
,
11281 Object_Definition
=>
11282 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11284 New_Occurrence_Of
(Standard_False
, Loc
)));
11287 -- Delay_Count is zero, don't need M and D set (suppress warning)
11294 if Present
(Terminate_Alt
) then
11296 -- If the terminate alternative guard is False, use
11297 -- Simple_Mode; otherwise use Terminate_Mode.
11299 if Present
(Condition
(Terminate_Alt
)) then
11300 Select_Mode
:= Make_If_Expression
(Loc
,
11301 New_List
(Condition
(Terminate_Alt
),
11302 New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
),
11303 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)));
11305 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
);
11308 elsif Else_Present
or Delay_Count
> 0 then
11309 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Else_Mode
), Loc
);
11312 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
);
11315 Select_Call
:= Make_Select_Call
(Select_Mode
);
11316 Append
(Select_Call
, Stats
);
11318 -- Now generate code to act on the result. There is an entry
11319 -- in this case for each accept statement with a non-null body,
11320 -- followed by a branch to the statements that follow the Accept.
11321 -- In the absence of delay alternatives, we generate:
11324 -- when No_Rendezvous => -- omitted if simple mode
11339 -- Lab0: Else_Statements;
11342 -- Lab1: Trailing_Statements1;
11345 -- Lab2: Trailing_Statements2;
11350 -- Generate label for common exit
11352 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
11354 -- First entry is the default case, when no rendezvous is possible
11356 Choices
:= New_List
(New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
));
11358 if Else_Present
then
11360 -- If no rendezvous is possible, the else part is executed
11362 Lab
:= Make_And_Declare_Label
(0);
11363 Alt_Stats
:= New_List
(
11364 Make_Goto_Statement
(Loc
,
11365 Name
=> New_Copy
(Identifier
(Lab
))));
11367 Append
(Lab
, Trailing_List
);
11368 Append_List
(Else_Statements
(N
), Trailing_List
);
11369 Append_To
(Trailing_List
,
11370 Make_Goto_Statement
(Loc
,
11371 Name
=> New_Copy
(Identifier
(End_Lab
))));
11373 Alt_Stats
:= New_List
(
11374 Make_Goto_Statement
(Loc
,
11375 Name
=> New_Copy
(Identifier
(End_Lab
))));
11378 Append_To
(Alt_List
,
11379 Make_Case_Statement_Alternative
(Loc
,
11380 Discrete_Choices
=> Choices
,
11381 Statements
=> Alt_Stats
));
11383 -- We make use of the fact that Accept_Index is an integer type, and
11384 -- generate successive literals for entries for each accept. Only those
11385 -- for which there is a body or trailing statements get a case entry.
11387 Alt
:= First
(Select_Alternatives
(N
));
11388 Proc
:= First
(Body_List
);
11389 while Present
(Alt
) loop
11391 if Nkind
(Alt
) = N_Accept_Alternative
then
11392 Process_Accept_Alternative
(Alt
, Index
, Proc
);
11393 Index
:= Index
+ 1;
11396 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
11401 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11402 Process_Delay_Alternative
(Alt
, Delay_Num
);
11403 Delay_Num
:= Delay_Num
+ 1;
11409 -- An others choice is always added to the main case, as well
11410 -- as the delay case (to satisfy the compiler).
11412 Append_To
(Alt_List
,
11413 Make_Case_Statement_Alternative
(Loc
,
11414 Discrete_Choices
=>
11415 New_List
(Make_Others_Choice
(Loc
)),
11417 New_List
(Make_Goto_Statement
(Loc
,
11418 Name
=> New_Copy
(Identifier
(End_Lab
))))));
11420 Accept_Case
:= New_List
(
11421 Make_Case_Statement
(Loc
,
11422 Expression
=> New_Occurrence_Of
(Xnam
, Loc
),
11423 Alternatives
=> Alt_List
));
11425 Append_List
(Trailing_List
, Accept_Case
);
11426 Append_List
(Body_List
, Decls
);
11428 -- Construct case statement for trailing statements of delay
11429 -- alternatives, if there are several of them.
11431 if Delay_Count
> 1 then
11432 Append_To
(Delay_Alt_List
,
11433 Make_Case_Statement_Alternative
(Loc
,
11434 Discrete_Choices
=>
11435 New_List
(Make_Others_Choice
(Loc
)),
11437 New_List
(Make_Null_Statement
(Loc
))));
11439 Delay_Case
:= New_List
(
11440 Make_Case_Statement
(Loc
,
11441 Expression
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11442 Alternatives
=> Delay_Alt_List
));
11444 Delay_Case
:= Delay_Alt_List
;
11447 -- If there are no delay alternatives, we append the case statement
11448 -- to the statement list.
11450 if Delay_Count
= 0 then
11451 Append_List
(Accept_Case
, Stats
);
11453 -- Delay alternatives present
11456 -- If delay alternatives are present we generate:
11458 -- find minimum delay.
11459 -- DX := minimum delay;
11460 -- M := <delay mode>;
11461 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11464 -- if X = No_Rendezvous then
11465 -- case statement for delay statements.
11467 -- case statement for accept alternatives.
11478 -- The type of the delay expression is known to be legal
11480 if Time_Type
= Standard_Duration
then
11481 Conv
:= New_Occurrence_Of
(Delay_Min
, Loc
);
11483 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11484 Conv
:= Make_Function_Call
(Loc
,
11485 New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
11486 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11490 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11492 Conv
:= Make_Function_Call
(Loc
,
11493 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
11494 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11497 Stmt
:= Make_Assignment_Statement
(Loc
,
11498 Name
=> New_Occurrence_Of
(D
, Loc
),
11499 Expression
=> Conv
);
11501 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11503 Parms
:= Parameter_Associations
(Select_Call
);
11505 Parm
:= First
(Parms
);
11506 while Present
(Parm
) and then Parm
/= Select_Mode
loop
11510 pragma Assert
(Present
(Parm
));
11511 Rewrite
(Parm
, New_Occurrence_Of
(RTE
(RE_Delay_Mode
), Loc
));
11514 -- Prepare two new parameters of Duration and Delay_Mode type
11515 -- which represent the value and the mode of the minimum delay.
11518 Insert_After
(Parm
, New_Occurrence_Of
(M
, Loc
));
11519 Insert_After
(Parm
, New_Occurrence_Of
(D
, Loc
));
11521 -- Create a call to RTS
11523 Rewrite
(Select_Call
,
11524 Make_Procedure_Call_Statement
(Loc
,
11525 Name
=> New_Occurrence_Of
(RTE
(RE_Timed_Selective_Wait
), Loc
),
11526 Parameter_Associations
=> Parms
));
11528 -- This new call should follow the calculation of the minimum
11531 Insert_List_Before
(Select_Call
, Delay_List
);
11533 if Check_Guard
then
11535 Make_Implicit_If_Statement
(N
,
11536 Condition
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11537 Then_Statements
=> New_List
(
11538 New_Copy_Tree
(Stmt
),
11539 New_Copy_Tree
(Select_Call
)),
11540 Else_Statements
=> Accept_Or_Raise
);
11541 Rewrite
(Select_Call
, Stmt
);
11543 Insert_Before
(Select_Call
, Stmt
);
11547 Make_Implicit_If_Statement
(N
,
11548 Condition
=> Make_Op_Eq
(Loc
,
11549 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
11551 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
11553 Then_Statements
=> Delay_Case
,
11554 Else_Statements
=> Accept_Case
);
11556 Append
(Cases
, Stats
);
11560 Append
(End_Lab
, Stats
);
11562 -- Replace accept statement with appropriate block
11565 Make_Block_Statement
(Loc
,
11566 Declarations
=> Decls
,
11567 Handled_Statement_Sequence
=>
11568 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11571 -- Note: have to worry more about abort deferral in above code ???
11573 -- Final step is to unstack the Accept_Address entries for all accept
11574 -- statements appearing in accept alternatives in the select statement
11576 Alt
:= First
(Alts
);
11577 while Present
(Alt
) loop
11578 if Nkind
(Alt
) = N_Accept_Alternative
then
11579 Remove_Last_Elmt
(Accept_Address
11580 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11585 end Expand_N_Selective_Accept
;
11587 -------------------------------------------
11588 -- Expand_N_Single_Protected_Declaration --
11589 -------------------------------------------
11591 -- A single protected declaration should never be present after semantic
11592 -- analysis because it is transformed into a protected type declaration
11593 -- and an accompanying anonymous object. This routine ensures that the
11594 -- transformation takes place.
11596 procedure Expand_N_Single_Protected_Declaration
(N
: Node_Id
) is
11598 raise Program_Error
;
11599 end Expand_N_Single_Protected_Declaration
;
11601 --------------------------------------
11602 -- Expand_N_Single_Task_Declaration --
11603 --------------------------------------
11605 -- A single task declaration should never be present after semantic
11606 -- analysis because it is transformed into a task type declaration and
11607 -- an accompanying anonymous object. This routine ensures that the
11608 -- transformation takes place.
11610 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11612 raise Program_Error
;
11613 end Expand_N_Single_Task_Declaration
;
11615 ------------------------
11616 -- Expand_N_Task_Body --
11617 ------------------------
11619 -- Given a task body
11621 -- task body tname is
11627 -- This expansion routine converts it into a procedure and sets the
11628 -- elaboration flag for the procedure to true, to represent the fact
11629 -- that the task body is now elaborated:
11631 -- procedure tnameB (_Task : access tnameV) is
11632 -- discriminal : dtype renames _Task.discriminant;
11634 -- procedure _clean is
11636 -- Abort_Defer.all;
11638 -- Abort_Undefer.all;
11643 -- Abort_Undefer.all;
11645 -- System.Task_Stages.Complete_Activation;
11653 -- In addition, if the task body is an activator, then a call to activate
11654 -- tasks is added at the start of the statements, before the call to
11655 -- Complete_Activation, and if in addition the task is a master then it
11656 -- must be established as a master. These calls are inserted and analyzed
11657 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11660 -- There is one discriminal declaration line generated for each
11661 -- discriminant that is present to provide an easy reference point for
11662 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11664 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11665 -- task body procedures have a profile (Arg : System.Address). That is
11666 -- needed because GNARLI has to use the same access-to-subprogram type
11667 -- for all task types. We depend here on knowing that in GNAT, passing
11668 -- an address argument by value is identical to passing a record value
11669 -- by access (in either case a single pointer is passed), so even though
11670 -- this procedure has the wrong profile. In fact it's all OK, since the
11671 -- callings sequence is identical.
11673 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11674 Loc
: constant Source_Ptr
:= Sloc
(N
);
11675 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11679 Insert_Nod
: Node_Id
;
11680 -- Used to determine the proper location of wrapper body insertions
11683 -- if no task body procedure, means we had an error in configurable
11684 -- run-time mode, and there is no point in proceeding further.
11686 if No
(Task_Body_Procedure
(Ttyp
)) then
11690 -- Add renaming declarations for discriminals and a declaration for the
11691 -- entry family index (if applicable).
11693 Install_Private_Data_Declarations
11694 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11696 -- Add a call to Abort_Undefer at the very beginning of the task
11697 -- body since this body is called with abort still deferred.
11699 if Abort_Allowed
then
11700 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11702 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11706 -- The statement part has already been protected with an at_end and
11707 -- cleanup actions. The call to Complete_Activation must be placed
11708 -- at the head of the sequence of statements of that block. The
11709 -- declarations have been merged in this sequence of statements but
11710 -- the first real statement is accessible from the First_Real_Statement
11711 -- field (which was set for exactly this purpose).
11713 if Restricted_Profile
then
11714 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11716 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11720 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11724 Make_Subprogram_Body
(Loc
,
11725 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11726 Declarations
=> Declarations
(N
),
11727 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11728 Set_Is_Task_Body_Procedure
(New_N
);
11730 -- If the task contains generic instantiations, cleanup actions are
11731 -- delayed until after instantiation. Transfer the activation chain to
11732 -- the subprogram, to insure that the activation call is properly
11733 -- generated. It the task body contains inner tasks, indicate that the
11734 -- subprogram is a task master.
11736 if Delay_Cleanups
(Ttyp
) then
11737 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11738 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11741 Rewrite
(N
, New_N
);
11744 -- Set elaboration flag immediately after task body. If the body is a
11745 -- subunit, the flag is set in the declarative part containing the stub.
11747 if Nkind
(Parent
(N
)) /= N_Subunit
then
11749 Make_Assignment_Statement
(Loc
,
11751 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11752 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11755 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11756 -- the task body. At this point all wrapper specs have been created,
11757 -- frozen and included in the dispatch table for the task type.
11759 if Ada_Version
>= Ada_2005
then
11760 if Nkind
(Parent
(N
)) = N_Subunit
then
11761 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11766 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11768 end Expand_N_Task_Body
;
11770 ------------------------------------
11771 -- Expand_N_Task_Type_Declaration --
11772 ------------------------------------
11774 -- We have several things to do. First we must create a Boolean flag used
11775 -- to mark if the body is elaborated yet. This variable gets set to True
11776 -- when the body of the task is elaborated (we can't rely on the normal
11777 -- ABE mechanism for the task body, since we need to pass an access to
11778 -- this elaboration boolean to the runtime routines).
11780 -- taskE : aliased Boolean := False;
11782 -- Next a variable is declared to hold the task stack size (either the
11783 -- default : Unspecified_Size, or a value that is set by a pragma
11784 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11785 -- the variable is initialized with this value:
11787 -- taskZ : Size_Type := Unspecified_Size;
11789 -- taskZ : Size_Type := Size_Type (size_expression);
11791 -- Note: No variable is needed to hold the task relative deadline since
11792 -- its value would never be static because the parameter is of a private
11793 -- type (Ada.Real_Time.Time_Span).
11795 -- Next we create a corresponding record type declaration used to represent
11796 -- values of this task. The general form of this type declaration is
11798 -- type taskV (discriminants) is record
11799 -- _Task_Id : Task_Id;
11800 -- entry_family : array (bounds) of Void;
11801 -- _Priority : Integer := priority_expression;
11802 -- _Size : Size_Type := size_expression;
11803 -- _Task_Info : Task_Info_Type := task_info_expression;
11804 -- _CPU : Integer := cpu_range_expression;
11805 -- _Relative_Deadline : Time_Span := time_span_expression;
11806 -- _Domain : Dispatching_Domain := dd_expression;
11809 -- The discriminants are present only if the corresponding task type has
11810 -- discriminants, and they exactly mirror the task type discriminants.
11812 -- The Id field is always present. It contains the Task_Id value, as set by
11813 -- the call to Create_Task. Note that although the task is limited, the
11814 -- task value record type is not limited, so there is no problem in passing
11815 -- this field as an out parameter to Create_Task.
11817 -- One entry_family component is present for each entry family in the task
11818 -- definition. The bounds correspond to the bounds of the entry family
11819 -- (which may depend on discriminants). The element type is void, since we
11820 -- only need the bounds information for determining the entry index. Note
11821 -- that the use of an anonymous array would normally be illegal in this
11822 -- context, but this is a parser check, and the semantics is quite prepared
11823 -- to handle such a case.
11825 -- The _Size field is present only if a Storage_Size pragma appears in the
11826 -- task definition. The expression captures the argument that was present
11827 -- in the pragma, and is used to override the task stack size otherwise
11828 -- associated with the task type.
11830 -- The _Priority field is present only if the task entity has a Priority or
11831 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11832 -- definition clause). It will be filled at the freeze point, when the
11833 -- record init proc is built, to capture the expression of the rep item
11834 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11835 -- here since aspect evaluations are delayed till the freeze point.
11837 -- The _Task_Info field is present only if a Task_Info pragma appears in
11838 -- the task definition. The expression captures the argument that was
11839 -- present in the pragma, and is used to provide the Task_Image parameter
11840 -- to the call to Create_Task.
11842 -- The _CPU field is present only if the task entity has a CPU rep item
11843 -- (pragma, aspect specification or attribute definition clause). It will
11844 -- be filled at the freeze point, when the record init proc is built, to
11845 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11846 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11847 -- are delayed till the freeze point.
11849 -- The _Relative_Deadline field is present only if a Relative_Deadline
11850 -- pragma appears in the task definition. The expression captures the
11851 -- argument that was present in the pragma, and is used to provide the
11852 -- Relative_Deadline parameter to the call to Create_Task.
11854 -- The _Domain field is present only if the task entity has a
11855 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11856 -- definition clause). It will be filled at the freeze point, when the
11857 -- record init proc is built, to capture the expression of the rep item
11858 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11859 -- here since aspect evaluations are delayed till the freeze point.
11861 -- When a task is declared, an instance of the task value record is
11862 -- created. The elaboration of this declaration creates the correct bounds
11863 -- for the entry families, and also evaluates the size, priority, and
11864 -- task_Info expressions if needed. The initialization routine for the task
11865 -- type itself then calls Create_Task with appropriate parameters to
11866 -- initialize the value of the Task_Id field.
11868 -- Note: the address of this record is passed as the "Discriminants"
11869 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11870 -- body procedure, it does not matter that it does not quite match the
11871 -- GNARLI model of what is being passed (the record contains more than just
11872 -- the discriminants, but the discriminants can be found from the record
11875 -- The Entity_Id for this created record type is placed in the
11876 -- Corresponding_Record_Type field of the associated task type entity.
11878 -- Next we create a procedure specification for the task body procedure:
11880 -- procedure taskB (_Task : access taskV);
11882 -- Note that this must come after the record type declaration, since
11883 -- the spec refers to this type. It turns out that the initialization
11884 -- procedure for the value type references the task body spec, but that's
11885 -- fine, since it won't be generated till the freeze point for the type,
11886 -- which is certainly after the task body spec declaration.
11888 -- Finally, we set the task index value field of the entry attribute in
11889 -- the case of a simple entry.
11891 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
11892 Loc
: constant Source_Ptr
:= Sloc
(N
);
11893 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
11894 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
11895 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
11896 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
11898 Body_Decl
: Node_Id
;
11900 Decl_Stack
: Node_Id
;
11901 Elab_Decl
: Node_Id
;
11902 Ent_Stack
: Entity_Id
;
11903 Proc_Spec
: Node_Id
;
11904 Rec_Decl
: Node_Id
;
11905 Rec_Ent
: Entity_Id
;
11906 Size_Decl
: Entity_Id
;
11907 Task_Size
: Node_Id
;
11909 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
11910 -- Searches the task definition T for the first occurrence of the pragma
11911 -- Relative Deadline. The caller has ensured that the pragma is present
11912 -- in the task definition. Note that this routine cannot be implemented
11913 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11914 -- not chained because their expansion into a procedure call statement
11915 -- would cause a break in the chain.
11917 ----------------------------------
11918 -- Get_Relative_Deadline_Pragma --
11919 ----------------------------------
11921 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
11925 N
:= First
(Visible_Declarations
(T
));
11926 while Present
(N
) loop
11927 if Nkind
(N
) = N_Pragma
11928 and then Pragma_Name
(N
) = Name_Relative_Deadline
11936 N
:= First
(Private_Declarations
(T
));
11937 while Present
(N
) loop
11938 if Nkind
(N
) = N_Pragma
11939 and then Pragma_Name
(N
) = Name_Relative_Deadline
11947 raise Program_Error
;
11948 end Get_Relative_Deadline_Pragma
;
11950 -- Start of processing for Expand_N_Task_Type_Declaration
11953 -- If already expanded, nothing to do
11955 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
11959 -- Here we will do the expansion
11961 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
11963 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
11964 Cdecls
:= Component_Items
(Component_List
11965 (Type_Definition
(Rec_Decl
)));
11967 Qualify_Entity_Names
(N
);
11969 -- First create the elaboration variable
11972 Make_Object_Declaration
(Loc
,
11973 Defining_Identifier
=>
11974 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11975 Chars
=> New_External_Name
(Tasknm
, 'E')),
11976 Aliased_Present
=> True,
11977 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
11978 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
11980 Insert_After
(N
, Elab_Decl
);
11982 -- Next create the declaration of the size variable (tasknmZ)
11984 Set_Storage_Size_Variable
(Tasktyp
,
11985 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11986 Chars
=> New_External_Name
(Tasknm
, 'Z')));
11988 if Present
(Taskdef
)
11989 and then Has_Storage_Size_Pragma
(Taskdef
)
11991 Is_OK_Static_Expression
11993 (First
(Pragma_Argument_Associations
11994 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
11997 Make_Object_Declaration
(Loc
,
11998 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11999 Object_Definition
=>
12000 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12002 Convert_To
(RTE
(RE_Size_Type
),
12004 (Expression
(First
(Pragma_Argument_Associations
12006 (TaskId
, Name_Storage_Size
)))))));
12010 Make_Object_Declaration
(Loc
,
12011 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
12012 Object_Definition
=>
12013 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12015 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
12018 Insert_After
(Elab_Decl
, Size_Decl
);
12020 -- Next build the rest of the corresponding record declaration. This is
12021 -- done last, since the corresponding record initialization procedure
12022 -- will reference the previously created entities.
12024 -- Fill in the component declarations -- first the _Task_Id field
12027 Make_Component_Declaration
(Loc
,
12028 Defining_Identifier
=>
12029 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
12030 Component_Definition
=>
12031 Make_Component_Definition
(Loc
,
12032 Aliased_Present
=> False,
12033 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RO_ST_Task_Id
),
12036 -- Declare static ATCB (that is, created by the expander) if we are
12037 -- using the Restricted run time.
12039 if Restricted_Profile
then
12041 Make_Component_Declaration
(Loc
,
12042 Defining_Identifier
=>
12043 Make_Defining_Identifier
(Loc
, Name_uATCB
),
12045 Component_Definition
=>
12046 Make_Component_Definition
(Loc
,
12047 Aliased_Present
=> True,
12048 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12050 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
12053 Make_Index_Or_Discriminant_Constraint
(Loc
,
12055 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
12059 -- Declare static stack (that is, created by the expander) if we are
12060 -- using the Restricted run time on a bare board configuration.
12062 if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
12064 -- First we need to extract the appropriate stack size
12066 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
12068 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12070 Expr_N
: constant Node_Id
:=
12071 Expression
(First
(
12072 Pragma_Argument_Associations
(
12073 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
12074 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
12075 P
: constant Node_Id
:= Parent
(Expr_N
);
12078 -- The stack is defined inside the corresponding record.
12079 -- Therefore if the size of the stack is set by means of
12080 -- a discriminant, we must reference the discriminant of the
12081 -- corresponding record type.
12083 if Nkind
(Expr_N
) in N_Has_Entity
12084 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
12088 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
12090 Set_Parent
(Task_Size
, P
);
12091 Set_Etype
(Task_Size
, Etyp
);
12092 Set_Analyzed
(Task_Size
);
12095 Task_Size
:= Relocate_Node
(Expr_N
);
12101 New_Occurrence_Of
(RTE
(RE_Default_Stack_Size
), Loc
);
12104 Decl_Stack
:= Make_Component_Declaration
(Loc
,
12105 Defining_Identifier
=> Ent_Stack
,
12107 Component_Definition
=>
12108 Make_Component_Definition
(Loc
,
12109 Aliased_Present
=> True,
12110 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12112 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
12115 Make_Index_Or_Discriminant_Constraint
(Loc
,
12116 Constraints
=> New_List
(Make_Range
(Loc
,
12117 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
12118 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
12121 Append_To
(Cdecls
, Decl_Stack
);
12123 -- The appropriate alignment for the stack is ensured by the run-time
12124 -- code in charge of task creation.
12128 -- Add components for entry families
12130 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
12132 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12133 -- item is present.
12135 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
12137 Make_Component_Declaration
(Loc
,
12138 Defining_Identifier
=>
12139 Make_Defining_Identifier
(Loc
, Name_uPriority
),
12140 Component_Definition
=>
12141 Make_Component_Definition
(Loc
,
12142 Aliased_Present
=> False,
12143 Subtype_Indication
=>
12144 New_Occurrence_Of
(Standard_Integer
, Loc
))));
12147 -- Add the _Size component if a Storage_Size pragma is present
12149 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12151 Make_Component_Declaration
(Loc
,
12152 Defining_Identifier
=>
12153 Make_Defining_Identifier
(Loc
, Name_uSize
),
12155 Component_Definition
=>
12156 Make_Component_Definition
(Loc
,
12157 Aliased_Present
=> False,
12158 Subtype_Indication
=>
12159 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
)),
12162 Convert_To
(RTE
(RE_Size_Type
),
12164 Expression
(First
(
12165 Pragma_Argument_Associations
(
12166 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
12169 -- Add the _Task_Info component if a Task_Info pragma is present
12171 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
12173 Make_Component_Declaration
(Loc
,
12174 Defining_Identifier
=>
12175 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
12177 Component_Definition
=>
12178 Make_Component_Definition
(Loc
,
12179 Aliased_Present
=> False,
12180 Subtype_Indication
=>
12181 New_Occurrence_Of
(RTE
(RE_Task_Info_Type
), Loc
)),
12183 Expression
=> New_Copy
(
12184 Expression
(First
(
12185 Pragma_Argument_Associations
(
12187 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
12190 -- Add the _CPU component if a CPU rep item is present
12192 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
12194 Make_Component_Declaration
(Loc
,
12195 Defining_Identifier
=>
12196 Make_Defining_Identifier
(Loc
, Name_uCPU
),
12198 Component_Definition
=>
12199 Make_Component_Definition
(Loc
,
12200 Aliased_Present
=> False,
12201 Subtype_Indication
=>
12202 New_Occurrence_Of
(RTE
(RE_CPU_Range
), Loc
))));
12205 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12206 -- present. If we are using a restricted run time this component will
12207 -- not be added (deadlines are not allowed by the Ravenscar profile).
12209 if not Restricted_Profile
12210 and then Present
(Taskdef
)
12211 and then Has_Relative_Deadline_Pragma
(Taskdef
)
12214 Make_Component_Declaration
(Loc
,
12215 Defining_Identifier
=>
12216 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
12218 Component_Definition
=>
12219 Make_Component_Definition
(Loc
,
12220 Aliased_Present
=> False,
12221 Subtype_Indication
=>
12222 New_Occurrence_Of
(RTE
(RE_Time_Span
), Loc
)),
12225 Convert_To
(RTE
(RE_Time_Span
),
12227 Expression
(First
(
12228 Pragma_Argument_Associations
(
12229 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
12232 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12233 -- item is present. If we are using a restricted run time this component
12234 -- will not be added (dispatching domains are not allowed by the
12235 -- Ravenscar profile).
12237 if not Restricted_Profile
12240 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
12243 Make_Component_Declaration
(Loc
,
12244 Defining_Identifier
=>
12245 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
12247 Component_Definition
=>
12248 Make_Component_Definition
(Loc
,
12249 Aliased_Present
=> False,
12250 Subtype_Indication
=>
12252 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
12255 Insert_After
(Size_Decl
, Rec_Decl
);
12257 -- Analyze the record declaration immediately after construction,
12258 -- because the initialization procedure is needed for single task
12259 -- declarations before the next entity is analyzed.
12261 Analyze
(Rec_Decl
);
12263 -- Create the declaration of the task body procedure
12265 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
12267 Make_Subprogram_Declaration
(Loc
,
12268 Specification
=> Proc_Spec
);
12269 Set_Is_Task_Body_Procedure
(Body_Decl
);
12271 Insert_After
(Rec_Decl
, Body_Decl
);
12273 -- The subprogram does not comes from source, so we have to indicate the
12274 -- need for debugging information explicitly.
12276 if Comes_From_Source
(Original_Node
(N
)) then
12277 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
12280 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12281 -- the corresponding record has been frozen.
12283 if Ada_Version
>= Ada_2005
then
12284 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
12287 -- Ada 2005 (AI-345): We must defer freezing to allow further
12288 -- declaration of primitive subprograms covering task interfaces
12290 if Ada_Version
<= Ada_95
then
12292 -- Now we can freeze the corresponding record. This needs manually
12293 -- freezing, since it is really part of the task type, and the task
12294 -- type is frozen at this stage. We of course need the initialization
12295 -- procedure for this corresponding record type and we won't get it
12296 -- in time if we don't freeze now.
12299 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
12301 if Is_Non_Empty_List
(L
) then
12302 Insert_List_After
(Body_Decl
, L
);
12307 -- Complete the expansion of access types to the current task type, if
12308 -- any were declared.
12310 Expand_Previous_Access_Type
(Tasktyp
);
12312 -- Create wrappers for entries that have contract cases, preconditions
12313 -- and postconditions.
12319 Ent
:= First_Entity
(Tasktyp
);
12320 while Present
(Ent
) loop
12321 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
) then
12322 Build_Contract_Wrapper
(Ent
, N
);
12328 end Expand_N_Task_Type_Declaration
;
12330 -------------------------------
12331 -- Expand_N_Timed_Entry_Call --
12332 -------------------------------
12334 -- A timed entry call in normal case is not implemented using ATC mechanism
12335 -- anymore for efficiency reason.
12345 -- is expanded as follows:
12347 -- 1) When T.E is a task entry_call;
12351 -- X : Task_Entry_Index := <entry index>;
12352 -- DX : Duration := To_Duration (D);
12353 -- M : Delay_Mode := <discriminant>;
12354 -- P : parms := (parm, parm, parm);
12357 -- Timed_Protected_Entry_Call
12358 -- (<acceptor-task>, X, P'Address, DX, M, B);
12366 -- 2) When T.E is a protected entry_call;
12370 -- X : Protected_Entry_Index := <entry index>;
12371 -- DX : Duration := To_Duration (D);
12372 -- M : Delay_Mode := <discriminant>;
12373 -- P : parms := (parm, parm, parm);
12376 -- Timed_Protected_Entry_Call
12377 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12385 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12386 -- is no delay and the triggering statements are executed. We first
12387 -- determine the kind of the triggering call and then execute a
12388 -- synchronized operation or a direct call.
12391 -- B : Boolean := False;
12392 -- C : Ada.Tags.Prim_Op_Kind;
12393 -- DX : Duration := To_Duration (D)
12394 -- K : Ada.Tags.Tagged_Kind :=
12395 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12396 -- M : Integer :=...;
12397 -- P : Parameters := (Param1 .. ParamN);
12401 -- if K = Ada.Tags.TK_Limited_Tagged
12402 -- or else K = Ada.Tags.TK_Tagged
12404 -- <dispatching-call>;
12409 -- Ada.Tags.Get_Offset_Index
12410 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12412 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12414 -- if C = POK_Protected_Entry
12415 -- or else C = POK_Task_Entry
12417 -- Param1 := P.Param1;
12419 -- ParamN := P.ParamN;
12423 -- if C = POK_Procedure
12424 -- or else C = POK_Protected_Procedure
12425 -- or else C = POK_Task_Procedure
12427 -- <dispatching-call>;
12433 -- <triggering-statements>
12435 -- <timed-statements>
12439 -- The triggering statement and the sequence of timed statements have not
12440 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12441 -- global references if within an instantiation.
12443 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
12444 Loc
: constant Source_Ptr
:= Sloc
(N
);
12447 Blk_Typ
: Entity_Id
;
12449 Call_Ent
: Entity_Id
;
12450 Conc_Typ_Stmts
: List_Id
;
12452 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
12455 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
12457 D_Type
: Entity_Id
;
12460 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
12461 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
12466 Is_Disp_Select
: Boolean;
12467 Lim_Typ_Stmts
: List_Id
;
12476 B
: Entity_Id
; -- Call status flag
12477 C
: Entity_Id
; -- Call kind
12478 D
: Entity_Id
; -- Delay
12479 K
: Entity_Id
; -- Tagged kind
12480 M
: Entity_Id
; -- Delay mode
12481 P
: Entity_Id
; -- Parameter block
12482 S
: Entity_Id
; -- Primitive operation slot
12484 -- Start of processing for Expand_N_Timed_Entry_Call
12487 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12488 -- was already reported on spec, so do not attempt to expand the call.
12490 if Restriction_Active
(No_Select_Statements
) then
12494 Process_Statements_For_Controlled_Objects
(E_Alt
);
12495 Process_Statements_For_Controlled_Objects
(D_Alt
);
12497 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
12499 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12500 -- may wrap them in blocks.
12502 E_Stats
:= Statements
(E_Alt
);
12503 D_Stats
:= Statements
(D_Alt
);
12505 -- The arguments in the call may require dynamic allocation, and the
12506 -- call statement may have been transformed into a block. The block
12507 -- may contain additional declarations for internal entities, and the
12508 -- original call is found by sequential search.
12510 if Nkind
(E_Call
) = N_Block_Statement
then
12511 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
12512 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
12513 N_Entry_Call_Statement
)
12520 Ada_Version
>= Ada_2005
12521 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
12523 if Is_Disp_Select
then
12524 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
12530 -- B : Boolean := False;
12532 B
:= Build_B
(Loc
, Decls
);
12535 -- C : Ada.Tags.Prim_Op_Kind;
12537 C
:= Build_C
(Loc
, Decls
);
12539 -- Because the analysis of all statements was disabled, manually
12540 -- analyze the delay statement.
12543 D_Stat
:= Original_Node
(D_Stat
);
12546 -- Build an entry call using Simple_Entry_Call
12548 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
12549 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
12551 Decls
:= Declarations
(E_Call
);
12552 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
12561 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12564 Make_Object_Declaration
(Loc
,
12565 Defining_Identifier
=> B
,
12566 Object_Definition
=>
12567 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
12570 -- Duration and mode processing
12572 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12574 -- Use the type of the delay expression (Calendar or Real_Time) to
12575 -- generate the appropriate conversion.
12577 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12578 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12579 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12581 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12582 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12584 Make_Function_Call
(Loc
,
12585 Name
=> New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
12586 Parameter_Associations
=>
12587 New_List
(New_Copy
(Expression
(D_Stat
))));
12589 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12590 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12592 Make_Function_Call
(Loc
,
12593 Name
=> New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
12594 Parameter_Associations
=>
12595 New_List
(New_Copy
(Expression
(D_Stat
))));
12598 D
:= Make_Temporary
(Loc
, 'D');
12604 Make_Object_Declaration
(Loc
,
12605 Defining_Identifier
=> D
,
12606 Object_Definition
=> New_Occurrence_Of
(Standard_Duration
, Loc
)));
12608 M
:= Make_Temporary
(Loc
, 'M');
12611 -- M : Integer := (0 | 1 | 2);
12614 Make_Object_Declaration
(Loc
,
12615 Defining_Identifier
=> M
,
12616 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
12617 Expression
=> D_Disc
));
12619 -- Do the assignment at this stage only because the evaluation of the
12620 -- expression must not occur before (see ACVC C97302A).
12623 Make_Assignment_Statement
(Loc
,
12624 Name
=> New_Occurrence_Of
(D
, Loc
),
12625 Expression
=> D_Conv
));
12627 -- Parameter block processing
12629 -- Manually create the parameter block for dispatching calls. In the
12630 -- case of entries, the block has already been created during the call
12631 -- to Build_Simple_Entry_Call.
12633 if Is_Disp_Select
then
12635 -- Tagged kind processing, generate:
12636 -- K : Ada.Tags.Tagged_Kind :=
12637 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12639 K
:= Build_K
(Loc
, Decls
, Obj
);
12641 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12643 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12645 -- Dispatch table slot processing, generate:
12648 S
:= Build_S
(Loc
, Decls
);
12651 -- S := Ada.Tags.Get_Offset_Index
12652 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12655 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12658 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12660 -- where Obj is the controlling formal parameter, S is the dispatch
12661 -- table slot number of the dispatching operation, P is the wrapped
12662 -- parameter block, D is the duration, M is the duration mode, C is
12663 -- the call kind and B is the call status.
12665 Params
:= New_List
;
12667 Append_To
(Params
, New_Copy_Tree
(Obj
));
12668 Append_To
(Params
, New_Occurrence_Of
(S
, Loc
));
12670 Make_Attribute_Reference
(Loc
,
12671 Prefix
=> New_Occurrence_Of
(P
, Loc
),
12672 Attribute_Name
=> Name_Address
));
12673 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12674 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12675 Append_To
(Params
, New_Occurrence_Of
(C
, Loc
));
12676 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12678 Append_To
(Conc_Typ_Stmts
,
12679 Make_Procedure_Call_Statement
(Loc
,
12683 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12684 Parameter_Associations
=> Params
));
12687 -- if C = POK_Protected_Entry
12688 -- or else C = POK_Task_Entry
12690 -- Param1 := P.Param1;
12692 -- ParamN := P.ParamN;
12695 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12697 -- Generate the if statement only when the packed parameters need
12698 -- explicit assignments to their corresponding actuals.
12700 if Present
(Unpack
) then
12701 Append_To
(Conc_Typ_Stmts
,
12702 Make_Implicit_If_Statement
(N
,
12708 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12711 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12715 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12717 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
12719 Then_Statements
=> Unpack
));
12725 -- if C = POK_Procedure
12726 -- or else C = POK_Protected_Procedure
12727 -- or else C = POK_Task_Procedure
12729 -- <dispatching-call>
12733 N_Stats
:= New_List
(
12734 Make_Implicit_If_Statement
(N
,
12739 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12741 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
12747 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12749 New_Occurrence_Of
(RTE
(
12750 RE_POK_Protected_Procedure
), Loc
)),
12753 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12756 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12758 Then_Statements
=> New_List
(E_Call
)));
12760 Append_To
(Conc_Typ_Stmts
,
12761 Make_Implicit_If_Statement
(N
,
12762 Condition
=> New_Occurrence_Of
(B
, Loc
),
12763 Then_Statements
=> N_Stats
));
12766 -- <dispatching-call>;
12770 New_List
(New_Copy_Tree
(E_Call
),
12771 Make_Assignment_Statement
(Loc
,
12772 Name
=> New_Occurrence_Of
(B
, Loc
),
12773 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12776 -- if K = Ada.Tags.TK_Limited_Tagged
12777 -- or else K = Ada.Tags.TK_Tagged
12785 Make_Implicit_If_Statement
(N
,
12786 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
12787 Then_Statements
=> Lim_Typ_Stmts
,
12788 Else_Statements
=> Conc_Typ_Stmts
));
12793 -- <triggering-statements>
12795 -- <timed-statements>
12799 Make_Implicit_If_Statement
(N
,
12800 Condition
=> New_Occurrence_Of
(B
, Loc
),
12801 Then_Statements
=> E_Stats
,
12802 Else_Statements
=> D_Stats
));
12805 -- Simple case of a non-dispatching trigger. Skip assignments to
12806 -- temporaries created for in-out parameters.
12808 -- This makes unwarranted assumptions about the shape of the expanded
12809 -- tree for the call, and should be cleaned up ???
12811 Stmt
:= First
(Stmts
);
12812 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
12816 -- Do the assignment at this stage only because the evaluation
12817 -- of the expression must not occur before (see ACVC C97302A).
12819 Insert_Before
(Stmt
,
12820 Make_Assignment_Statement
(Loc
,
12821 Name
=> New_Occurrence_Of
(D
, Loc
),
12822 Expression
=> D_Conv
));
12825 Params
:= Parameter_Associations
(Call
);
12827 -- For a protected type, we build a Timed_Protected_Entry_Call
12829 if Is_Protected_Type
(Etype
(Concval
)) then
12831 -- Create a new call statement
12833 Param
:= First
(Params
);
12834 while Present
(Param
)
12835 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
12840 Dummy
:= Remove_Next
(Next
(Param
));
12842 -- Remove garbage is following the Cancel_Param if present
12844 Dummy
:= Next
(Param
);
12846 -- Remove the mode of the Protected_Entry_Call call, then remove
12847 -- the Communication_Block of the Protected_Entry_Call call, and
12848 -- finally add Duration and a Delay_Mode parameter
12850 pragma Assert
(Present
(Param
));
12851 Rewrite
(Param
, New_Occurrence_Of
(D
, Loc
));
12853 Rewrite
(Dummy
, New_Occurrence_Of
(M
, Loc
));
12855 -- Add a Boolean flag for successful entry call
12857 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12859 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
12860 when System_Tasking_Protected_Objects_Entries
=>
12862 Make_Procedure_Call_Statement
(Loc
,
12865 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
12866 Parameter_Associations
=> Params
));
12869 raise Program_Error
;
12872 -- For the task case, build a Timed_Task_Entry_Call
12875 -- Create a new call statement
12877 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12878 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12879 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12882 Make_Procedure_Call_Statement
(Loc
,
12884 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
12885 Parameter_Associations
=> Params
));
12889 Make_Implicit_If_Statement
(N
,
12890 Condition
=> New_Occurrence_Of
(B
, Loc
),
12891 Then_Statements
=> E_Stats
,
12892 Else_Statements
=> D_Stats
));
12896 Make_Block_Statement
(Loc
,
12897 Declarations
=> Decls
,
12898 Handled_Statement_Sequence
=>
12899 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
12902 end Expand_N_Timed_Entry_Call
;
12904 ----------------------------------------
12905 -- Expand_Protected_Body_Declarations --
12906 ----------------------------------------
12908 procedure Expand_Protected_Body_Declarations
12910 Spec_Id
: Entity_Id
)
12913 if No_Run_Time_Mode
then
12914 Error_Msg_CRT
("protected body", N
);
12917 elsif Expander_Active
then
12919 -- Associate discriminals with the first subprogram or entry body to
12922 if Present
(First_Protected_Operation
(Declarations
(N
))) then
12923 Set_Discriminals
(Parent
(Spec_Id
));
12926 end Expand_Protected_Body_Declarations
;
12928 -------------------------
12929 -- External_Subprogram --
12930 -------------------------
12932 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
12933 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
12936 -- The internal and external subprograms follow each other on the entity
12937 -- chain. Note that previously private operations had no separate
12938 -- external subprogram. We now create one in all cases, because a
12939 -- private operation may actually appear in an external call, through
12940 -- a 'Access reference used for a callback.
12942 -- If the operation is a function that returns an anonymous access type,
12943 -- the corresponding itype appears before the operation, and must be
12946 -- This mechanism is fragile, there should be a real link between the
12947 -- two versions of the operation, but there is no place to put it ???
12949 if Is_Access_Type
(Next_Entity
(Subp
)) then
12950 return Next_Entity
(Next_Entity
(Subp
));
12952 return Next_Entity
(Subp
);
12954 end External_Subprogram
;
12956 ------------------------------
12957 -- Extract_Dispatching_Call --
12958 ------------------------------
12960 procedure Extract_Dispatching_Call
12962 Call_Ent
: out Entity_Id
;
12963 Object
: out Entity_Id
;
12964 Actuals
: out List_Id
;
12965 Formals
: out List_Id
)
12967 Call_Nam
: Node_Id
;
12970 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
12972 if Present
(Original_Node
(N
)) then
12973 Call_Nam
:= Name
(Original_Node
(N
));
12975 Call_Nam
:= Name
(N
);
12978 -- Retrieve the name of the dispatching procedure. It contains the
12979 -- dispatch table slot number.
12982 case Nkind
(Call_Nam
) is
12983 when N_Identifier
=>
12986 when N_Selected_Component
=>
12987 Call_Nam
:= Selector_Name
(Call_Nam
);
12990 raise Program_Error
;
12995 Actuals
:= Parameter_Associations
(N
);
12996 Call_Ent
:= Entity
(Call_Nam
);
12997 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
12998 Object
:= First
(Actuals
);
13000 if Present
(Original_Node
(Object
)) then
13001 Object
:= Original_Node
(Object
);
13004 -- If the type of the dispatching object is an access type then return
13005 -- an explicit dereference.
13007 if Is_Access_Type
(Etype
(Object
)) then
13008 Object
:= Make_Explicit_Dereference
(Sloc
(N
), Object
);
13011 end Extract_Dispatching_Call
;
13013 -------------------
13014 -- Extract_Entry --
13015 -------------------
13017 procedure Extract_Entry
13019 Concval
: out Node_Id
;
13020 Ename
: out Node_Id
;
13021 Index
: out Node_Id
)
13023 Nam
: constant Node_Id
:= Name
(N
);
13026 -- For a simple entry, the name is a selected component, with the
13027 -- prefix being the task value, and the selector being the entry.
13029 if Nkind
(Nam
) = N_Selected_Component
then
13030 Concval
:= Prefix
(Nam
);
13031 Ename
:= Selector_Name
(Nam
);
13034 -- For a member of an entry family, the name is an indexed component
13035 -- where the prefix is a selected component, whose prefix in turn is
13036 -- the task value, and whose selector is the entry family. The single
13037 -- expression in the expressions list of the indexed component is the
13038 -- subscript for the family.
13040 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
13041 Concval
:= Prefix
(Prefix
(Nam
));
13042 Ename
:= Selector_Name
(Prefix
(Nam
));
13043 Index
:= First
(Expressions
(Nam
));
13046 -- Through indirection, the type may actually be a limited view of a
13047 -- concurrent type. When compiling a call, the non-limited view of the
13048 -- type is visible.
13050 if From_Limited_With
(Etype
(Concval
)) then
13051 Set_Etype
(Concval
, Non_Limited_View
(Etype
(Concval
)));
13055 -------------------
13056 -- Family_Offset --
13057 -------------------
13059 function Family_Offset
13064 Cap
: Boolean) return Node_Id
13070 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
13071 -- If one of the bounds is a reference to a discriminant, replace with
13072 -- corresponding discriminal of type. Within the body of a task retrieve
13073 -- the renamed discriminant by simple visibility, using its generated
13074 -- name. Within a protected object, find the original discriminant and
13075 -- replace it with the discriminal of the current protected operation.
13077 ------------------------------
13078 -- Convert_Discriminant_Ref --
13079 ------------------------------
13081 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
13082 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
13087 if Is_Entity_Name
(Bound
)
13088 and then Ekind
(Entity
(Bound
)) = E_Discriminant
13090 if Is_Task_Type
(Ttyp
) and then Has_Completion
(Ttyp
) then
13091 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13092 Find_Direct_Name
(B
);
13094 elsif Is_Protected_Type
(Ttyp
) then
13095 D
:= First_Discriminant
(Ttyp
);
13096 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
13097 Next_Discriminant
(D
);
13100 B
:= New_Occurrence_Of
(Discriminal
(D
), Loc
);
13103 B
:= New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
13106 elsif Nkind
(Bound
) = N_Attribute_Reference
then
13110 B
:= New_Copy_Tree
(Bound
);
13114 Make_Attribute_Reference
(Loc
,
13115 Attribute_Name
=> Name_Pos
,
13116 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
13117 Expressions
=> New_List
(B
));
13118 end Convert_Discriminant_Ref
;
13120 -- Start of processing for Family_Offset
13123 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
13124 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
13127 if Is_Task_Type
(Ttyp
) then
13128 Ityp
:= RTE
(RE_Task_Entry_Index
);
13130 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13134 Make_Attribute_Reference
(Loc
,
13135 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13136 Attribute_Name
=> Name_Min
,
13137 Expressions
=> New_List
(
13139 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
13142 Make_Attribute_Reference
(Loc
,
13143 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13144 Attribute_Name
=> Name_Max
,
13145 Expressions
=> New_List
(
13147 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
13150 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
13157 function Family_Size
13162 Cap
: Boolean) return Node_Id
13167 if Is_Task_Type
(Ttyp
) then
13168 Ityp
:= RTE
(RE_Task_Entry_Index
);
13170 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13174 Make_Attribute_Reference
(Loc
,
13175 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13176 Attribute_Name
=> Name_Max
,
13177 Expressions
=> New_List
(
13179 Left_Opnd
=> Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
13180 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
13181 Make_Integer_Literal
(Loc
, 0)));
13184 ----------------------------
13185 -- Find_Enclosing_Context --
13186 ----------------------------
13188 procedure Find_Enclosing_Context
13190 Context
: out Node_Id
;
13191 Context_Id
: out Entity_Id
;
13192 Context_Decls
: out List_Id
)
13195 -- Traverse the parent chain looking for an enclosing body, block,
13196 -- package or return statement.
13198 Context
:= Parent
(N
);
13199 while not Nkind_In
(Context
, N_Block_Statement
,
13201 N_Extended_Return_Statement
,
13203 N_Package_Declaration
,
13207 Context
:= Parent
(Context
);
13210 -- Extract the constituents of the context
13212 if Nkind
(Context
) = N_Extended_Return_Statement
then
13213 Context_Decls
:= Return_Object_Declarations
(Context
);
13214 Context_Id
:= Return_Statement_Entity
(Context
);
13216 -- Package declarations and bodies use a common library-level activation
13217 -- chain or task master, therefore return the package declaration as the
13218 -- proper carrier for the appropriate flag.
13220 elsif Nkind
(Context
) = N_Package_Body
then
13221 Context_Decls
:= Declarations
(Context
);
13222 Context_Id
:= Corresponding_Spec
(Context
);
13223 Context
:= Parent
(Context_Id
);
13225 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
13226 Context
:= Parent
(Parent
(Context
));
13228 Context
:= Parent
(Context
);
13231 elsif Nkind
(Context
) = N_Package_Declaration
then
13232 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
13233 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13235 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13236 Context_Id
:= Defining_Identifier
(Context_Id
);
13240 Context_Decls
:= Declarations
(Context
);
13242 if Nkind
(Context
) = N_Block_Statement
then
13243 Context_Id
:= Entity
(Identifier
(Context
));
13245 elsif Nkind
(Context
) = N_Entry_Body
then
13246 Context_Id
:= Defining_Identifier
(Context
);
13248 elsif Nkind
(Context
) = N_Subprogram_Body
then
13249 if Present
(Corresponding_Spec
(Context
)) then
13250 Context_Id
:= Corresponding_Spec
(Context
);
13252 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13254 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13255 Context_Id
:= Defining_Identifier
(Context_Id
);
13259 elsif Nkind
(Context
) = N_Task_Body
then
13260 Context_Id
:= Corresponding_Spec
(Context
);
13263 raise Program_Error
;
13267 pragma Assert
(Present
(Context
));
13268 pragma Assert
(Present
(Context_Id
));
13269 pragma Assert
(Present
(Context_Decls
));
13270 end Find_Enclosing_Context
;
13272 -----------------------
13273 -- Find_Master_Scope --
13274 -----------------------
13276 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
13280 -- In Ada 2005, the master is the innermost enclosing scope that is not
13281 -- transient. If the enclosing block is the rewriting of a call or the
13282 -- scope is an extended return statement this is valid master. The
13283 -- master in an extended return is only used within the return, and is
13284 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13285 -- now before that overwriting occurs.
13289 if Ada_Version
>= Ada_2005
then
13290 while Is_Internal
(S
) loop
13291 if Nkind
(Parent
(S
)) = N_Block_Statement
13293 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
13297 elsif Ekind
(S
) = E_Return_Statement
then
13307 end Find_Master_Scope
;
13309 -------------------------------
13310 -- First_Protected_Operation --
13311 -------------------------------
13313 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
13314 First_Op
: Node_Id
;
13317 First_Op
:= First
(D
);
13318 while Present
(First_Op
)
13319 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
13325 end First_Protected_Operation
;
13327 ---------------------------------------
13328 -- Install_Private_Data_Declarations --
13329 ---------------------------------------
13331 procedure Install_Private_Data_Declarations
13333 Spec_Id
: Entity_Id
;
13334 Conc_Typ
: Entity_Id
;
13335 Body_Nod
: Node_Id
;
13337 Barrier
: Boolean := False;
13338 Family
: Boolean := False)
13340 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
13343 Insert_Node
: Node_Id
:= Empty
;
13344 Obj_Ent
: Entity_Id
;
13346 procedure Add
(Decl
: Node_Id
);
13347 -- Add a single declaration after Insert_Node. If this is the first
13348 -- addition, Decl is added to the front of Decls and it becomes the
13351 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
13352 -- The bounds of an entry index may depend on discriminants, create a
13353 -- reference to the corresponding prival. Otherwise return a duplicate
13354 -- of the original bound.
13360 procedure Add
(Decl
: Node_Id
) is
13362 if No
(Insert_Node
) then
13363 Prepend_To
(Decls
, Decl
);
13365 Insert_After
(Insert_Node
, Decl
);
13368 Insert_Node
:= Decl
;
13371 --------------------------
13372 -- Replace_Discriminant --
13373 --------------------------
13375 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
13377 if Nkind
(Bound
) = N_Identifier
13378 and then Is_Discriminal
(Entity
(Bound
))
13380 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13382 return Duplicate_Subexpr
(Bound
);
13386 -- Start of processing for Install_Private_Data_Declarations
13389 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13390 -- formal parameter _O, _object or _task depending on the context.
13392 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
13394 -- Special processing of _O for barrier functions, protected entries
13401 (Ekind
(Spec_Id
) = E_Entry
13402 or else Ekind
(Spec_Id
) = E_Entry_Family
))
13405 Conc_Rec
: constant Entity_Id
:=
13406 Corresponding_Record_Type
(Conc_Typ
);
13407 Typ_Id
: constant Entity_Id
:=
13408 Make_Defining_Identifier
(Loc
,
13409 New_External_Name
(Chars
(Conc_Rec
), 'P'));
13412 -- type prot_typVP is access prot_typV;
13415 Make_Full_Type_Declaration
(Loc
,
13416 Defining_Identifier
=> Typ_Id
,
13418 Make_Access_To_Object_Definition
(Loc
,
13419 Subtype_Indication
=>
13420 New_Occurrence_Of
(Conc_Rec
, Loc
)));
13424 -- _object : prot_typVP := prot_typV (_O);
13427 Make_Object_Declaration
(Loc
,
13428 Defining_Identifier
=>
13429 Make_Defining_Identifier
(Loc
, Name_uObject
),
13430 Object_Definition
=> New_Occurrence_Of
(Typ_Id
, Loc
),
13432 Unchecked_Convert_To
(Typ_Id
,
13433 New_Occurrence_Of
(Obj_Ent
, Loc
)));
13436 -- Set the reference to the concurrent object
13438 Obj_Ent
:= Defining_Identifier
(Decl
);
13442 -- Step 2: Create the Protection object and build its declaration for
13443 -- any protected entry (family) of subprogram. Note for the lock-free
13444 -- implementation, the Protection object is not needed anymore.
13446 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
13448 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
13452 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
13454 -- Determine the proper protection type
13456 if Has_Attach_Handler
(Conc_Typ
)
13457 and then not Restricted_Profile
13459 Prot_Typ
:= RE_Static_Interrupt_Protection
;
13461 elsif Has_Interrupt_Handler
(Conc_Typ
)
13462 and then not Restriction_Active
(No_Dynamic_Attachment
)
13464 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
13467 case Corresponding_Runtime_Package
(Conc_Typ
) is
13468 when System_Tasking_Protected_Objects_Entries
=>
13469 Prot_Typ
:= RE_Protection_Entries
;
13471 when System_Tasking_Protected_Objects_Single_Entry
=>
13472 Prot_Typ
:= RE_Protection_Entry
;
13474 when System_Tasking_Protected_Objects
=>
13475 Prot_Typ
:= RE_Protection
;
13478 raise Program_Error
;
13483 -- conc_typR : protection_typ renames _object._object;
13486 Make_Object_Renaming_Declaration
(Loc
,
13487 Defining_Identifier
=> Prot_Ent
,
13489 New_Occurrence_Of
(RTE
(Prot_Typ
), Loc
),
13491 Make_Selected_Component
(Loc
,
13492 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13493 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
13498 -- Step 3: Add discriminant renamings (if any)
13500 if Has_Discriminants
(Conc_Typ
) then
13505 D
:= First_Discriminant
(Conc_Typ
);
13506 while Present
(D
) loop
13508 -- Adjust the source location
13510 Set_Sloc
(Discriminal
(D
), Loc
);
13513 -- discr_name : discr_typ renames _object.discr_name;
13515 -- discr_name : discr_typ renames _task.discr_name;
13518 Make_Object_Renaming_Declaration
(Loc
,
13519 Defining_Identifier
=> Discriminal
(D
),
13520 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
13522 Make_Selected_Component
(Loc
,
13523 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13524 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
13527 Next_Discriminant
(D
);
13532 -- Step 4: Add private component renamings (if any)
13534 if Is_Protected
then
13535 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
13537 if Present
(Private_Declarations
(Def
)) then
13540 Comp_Id
: Entity_Id
;
13541 Decl_Id
: Entity_Id
;
13544 Comp
:= First
(Private_Declarations
(Def
));
13545 while Present
(Comp
) loop
13546 if Nkind
(Comp
) = N_Component_Declaration
then
13547 Comp_Id
:= Defining_Identifier
(Comp
);
13549 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
13551 -- Minimal decoration
13553 if Ekind
(Spec_Id
) = E_Function
then
13554 Set_Ekind
(Decl_Id
, E_Constant
);
13556 Set_Ekind
(Decl_Id
, E_Variable
);
13559 Set_Prival
(Comp_Id
, Decl_Id
);
13560 Set_Prival_Link
(Decl_Id
, Comp_Id
);
13561 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13564 -- comp_name : comp_typ renames _object.comp_name;
13567 Make_Object_Renaming_Declaration
(Loc
,
13568 Defining_Identifier
=> Decl_Id
,
13570 New_Occurrence_Of
(Etype
(Comp_Id
), Loc
),
13572 Make_Selected_Component
(Loc
,
13574 New_Occurrence_Of
(Obj_Ent
, Loc
),
13576 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
13586 -- Step 5: Add the declaration of the entry index and the associated
13587 -- type for barrier functions and entry families.
13589 if (Barrier
and Family
) or else Ekind
(Spec_Id
) = E_Entry_Family
then
13591 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13592 Index
: constant Entity_Id
:=
13593 Defining_Identifier
13594 (Entry_Index_Specification
13595 (Entry_Body_Formal_Part
(Body_Nod
)));
13596 Index_Con
: constant Entity_Id
:=
13597 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13599 Index_Typ
: Entity_Id
;
13603 -- Minimal decoration
13605 Set_Ekind
(Index_Con
, E_Constant
);
13606 Set_Entry_Index_Constant
(Index
, Index_Con
);
13607 Set_Discriminal_Link
(Index_Con
, Index
);
13609 -- Retrieve the bounds of the entry family
13611 High
:= Type_High_Bound
(Etype
(Index
));
13612 Low
:= Type_Low_Bound
(Etype
(Index
));
13614 -- In the simple case the entry family is given by a subtype
13615 -- mark and the index constant has the same type.
13617 if Is_Entity_Name
(Original_Node
(
13618 Discrete_Subtype_Definition
(Parent
(Index
))))
13620 Index_Typ
:= Etype
(Index
);
13622 -- Otherwise a new subtype declaration is required
13625 High
:= Replace_Bound
(High
);
13626 Low
:= Replace_Bound
(Low
);
13628 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13631 -- subtype Jnn is <Etype of Index> range Low .. High;
13634 Make_Subtype_Declaration
(Loc
,
13635 Defining_Identifier
=> Index_Typ
,
13636 Subtype_Indication
=>
13637 Make_Subtype_Indication
(Loc
,
13639 New_Occurrence_Of
(Base_Type
(Etype
(Index
)), Loc
),
13641 Make_Range_Constraint
(Loc
,
13642 Range_Expression
=>
13643 Make_Range
(Loc
, Low
, High
))));
13647 Set_Etype
(Index_Con
, Index_Typ
);
13649 -- Create the object which designates the index:
13650 -- J : constant Jnn :=
13651 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13653 -- where Jnn is the subtype created above or the original type of
13654 -- the index, _E is a formal of the protected body subprogram and
13655 -- <index expr> is the index of the first family member.
13658 Make_Object_Declaration
(Loc
,
13659 Defining_Identifier
=> Index_Con
,
13660 Constant_Present
=> True,
13661 Object_Definition
=>
13662 New_Occurrence_Of
(Index_Typ
, Loc
),
13665 Make_Attribute_Reference
(Loc
,
13667 New_Occurrence_Of
(Index_Typ
, Loc
),
13668 Attribute_Name
=> Name_Val
,
13670 Expressions
=> New_List
(
13674 Make_Op_Subtract
(Loc
,
13675 Left_Opnd
=> New_Occurrence_Of
(E
, Loc
),
13677 Entry_Index_Expression
(Loc
,
13678 Defining_Identifier
(Body_Nod
),
13682 Make_Attribute_Reference
(Loc
,
13684 New_Occurrence_Of
(Index_Typ
, Loc
),
13685 Attribute_Name
=> Name_Pos
,
13686 Expressions
=> New_List
(
13687 Make_Attribute_Reference
(Loc
,
13689 New_Occurrence_Of
(Index_Typ
, Loc
),
13690 Attribute_Name
=> Name_First
)))))));
13694 end Install_Private_Data_Declarations
;
13696 -----------------------
13697 -- Is_Exception_Safe --
13698 -----------------------
13700 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean is
13702 function Has_Side_Effect
(N
: Node_Id
) return Boolean;
13703 -- Return True whenever encountering a subprogram call or raise
13704 -- statement of any kind in the sequence of statements
13706 ---------------------
13707 -- Has_Side_Effect --
13708 ---------------------
13710 -- What is this doing buried two levels down in exp_ch9. It seems like a
13711 -- generally useful function, and indeed there may be code duplication
13712 -- going on here ???
13714 function Has_Side_Effect
(N
: Node_Id
) return Boolean is
13718 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean;
13719 -- Indicate whether N is a subprogram call or a raise statement
13721 ----------------------
13722 -- Is_Call_Or_Raise --
13723 ----------------------
13725 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean is
13727 return Nkind_In
(N
, N_Procedure_Call_Statement
,
13730 N_Raise_Constraint_Error
,
13731 N_Raise_Program_Error
,
13732 N_Raise_Storage_Error
);
13733 end Is_Call_Or_Raise
;
13735 -- Start of processing for Has_Side_Effect
13739 while Present
(Stmt
) loop
13740 if Is_Call_Or_Raise
(Stmt
) then
13744 -- An object declaration can also contain a function call or a
13745 -- raise statement.
13747 if Nkind
(Stmt
) = N_Object_Declaration
then
13748 Expr
:= Expression
(Stmt
);
13750 if Present
(Expr
) and then Is_Call_Or_Raise
(Expr
) then
13759 end Has_Side_Effect
;
13761 -- Start of processing for Is_Exception_Safe
13764 -- When exceptions can't be propagated, the subprogram returns normally
13766 if No_Exception_Handlers_Set
then
13770 -- If the checks handled by the back end are not disabled, we cannot
13771 -- ensure that no exception will be raised.
13773 if not Access_Checks_Suppressed
(Empty
)
13774 or else not Discriminant_Checks_Suppressed
(Empty
)
13775 or else not Range_Checks_Suppressed
(Empty
)
13776 or else not Index_Checks_Suppressed
(Empty
)
13777 or else Opt
.Stack_Checking_Enabled
13782 if Has_Side_Effect
(First
(Declarations
(Subprogram
)))
13785 (First
(Statements
(Handled_Statement_Sequence
(Subprogram
))))
13791 end Is_Exception_Safe
;
13793 ---------------------------------
13794 -- Is_Potentially_Large_Family --
13795 ---------------------------------
13797 function Is_Potentially_Large_Family
13798 (Base_Index
: Entity_Id
;
13799 Conctyp
: Entity_Id
;
13801 Hi
: Node_Id
) return Boolean
13804 return Scope
(Base_Index
) = Standard_Standard
13805 and then Base_Index
= Base_Type
(Standard_Integer
)
13806 and then Has_Discriminants
(Conctyp
)
13808 Present
(Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
13810 (Denotes_Discriminant
(Lo
, True)
13812 Denotes_Discriminant
(Hi
, True));
13813 end Is_Potentially_Large_Family
;
13815 -------------------------------------
13816 -- Is_Private_Primitive_Subprogram --
13817 -------------------------------------
13819 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13822 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13823 and then Is_Private_Primitive
(Id
);
13824 end Is_Private_Primitive_Subprogram
;
13830 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13831 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13832 Formal
: Entity_Id
;
13835 Formal
:= First_Formal
(Bod_Subp
);
13836 while Present
(Formal
) loop
13838 -- Look for formal parameter _E
13840 if Chars
(Formal
) = Name_uE
then
13844 Next_Formal
(Formal
);
13847 -- A protected body subprogram should always have the parameter in
13850 raise Program_Error
;
13853 --------------------------------
13854 -- Make_Initialize_Protection --
13855 --------------------------------
13857 function Make_Initialize_Protection
13858 (Protect_Rec
: Entity_Id
) return List_Id
13860 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
13863 Ptyp
: constant Node_Id
:=
13864 Corresponding_Concurrent_Type
(Protect_Rec
);
13866 L
: constant List_Id
:= New_List
;
13867 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
13868 Prio_Type
: Entity_Id
;
13869 Prio_Var
: Entity_Id
:= Empty
;
13870 Restricted
: constant Boolean := Restricted_Profile
;
13873 -- We may need two calls to properly initialize the object, one to
13874 -- Initialize_Protection, and possibly one to Install_Handlers if we
13875 -- have a pragma Attach_Handler.
13877 -- Get protected declaration. In the case of a task type declaration,
13878 -- this is simply the parent of the protected type entity. In the single
13879 -- protected object declaration, this parent will be the implicit type,
13880 -- and we can find the corresponding single protected object declaration
13881 -- by searching forward in the declaration list in the tree.
13883 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13884 -- of this type should have been removed during semantic analysis.
13886 Pdec
:= Parent
(Ptyp
);
13887 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
13888 N_Single_Protected_Declaration
)
13893 -- Build the parameter list for the call. Note that _Init is the name
13894 -- of the formal for the object to be initialized, which is the task
13895 -- value record itself.
13899 -- For lock-free implementation, skip initializations of the Protection
13902 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13904 -- Object parameter. This is a pointer to the object of type
13905 -- Protection used by the GNARL to control the protected object.
13908 Make_Attribute_Reference
(Loc
,
13910 Make_Selected_Component
(Loc
,
13911 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13912 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
13913 Attribute_Name
=> Name_Unchecked_Access
));
13915 -- Priority parameter. Set to Unspecified_Priority unless there is a
13916 -- Priority rep item, in which case we take the value from the pragma
13917 -- or attribute definition clause, or there is an Interrupt_Priority
13918 -- rep item and no Priority rep item, and we set the ceiling to
13919 -- Interrupt_Priority'Last, an implementation-defined value, see
13922 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
13924 Prio_Clause
: constant Node_Id
:=
13926 (Ptyp
, Name_Priority
, Check_Parents
=> False);
13933 if Nkind
(Prio_Clause
) = N_Pragma
then
13936 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
13938 -- Get_Rep_Item returns either priority pragma.
13940 if Pragma_Name
(Prio_Clause
) = Name_Priority
then
13941 Prio_Type
:= RTE
(RE_Any_Priority
);
13943 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13946 -- Attribute definition clause Priority
13949 if Chars
(Prio_Clause
) = Name_Priority
then
13950 Prio_Type
:= RTE
(RE_Any_Priority
);
13952 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13955 Prio
:= Expression
(Prio_Clause
);
13958 -- Always create a locale variable to capture the priority.
13959 -- The priority is also passed to Install_Restriced_Handlers.
13960 -- Note that it is really necessary to create this variable
13961 -- explicitly. It might be thought that removing side effects
13962 -- would the appropriate approach, but that could generate
13963 -- declarations improperly placed in the enclosing scope.
13965 Prio_Var
:= Make_Temporary
(Loc
, 'R', Prio
);
13967 Make_Object_Declaration
(Loc
,
13968 Defining_Identifier
=> Prio_Var
,
13969 Object_Definition
=> New_Occurrence_Of
(Prio_Type
, Loc
),
13970 Expression
=> Relocate_Node
(Prio
)));
13972 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
13975 -- When no priority is specified but an xx_Handler pragma is, we
13976 -- default to System.Interrupts.Default_Interrupt_Priority, see
13979 elsif Has_Attach_Handler
(Ptyp
)
13980 or else Has_Interrupt_Handler
(Ptyp
)
13983 New_Occurrence_Of
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
13985 -- Normal case, no priority or xx_Handler specified, default priority
13989 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
13992 -- Test for Compiler_Info parameter. This parameter allows entry body
13993 -- procedures and barrier functions to be called from the runtime. It
13994 -- is a pointer to the record generated by the compiler to represent
13995 -- the protected object.
13997 -- A protected type without entries that covers an interface and
13998 -- overrides the abstract routines with protected procedures is
13999 -- considered equivalent to a protected type with entries in the
14000 -- context of dispatching select statements.
14002 -- Protected types with interrupt handlers (when not using a
14003 -- restricted profile) are also considered equivalent to protected
14004 -- types with entries.
14006 -- The types which are used (Static_Interrupt_Protection and
14007 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14010 Pkg_Id
: constant RTU_Id
:= Corresponding_Runtime_Package
(Ptyp
);
14012 Called_Subp
: RE_Id
;
14016 when System_Tasking_Protected_Objects_Entries
=>
14017 Called_Subp
:= RE_Initialize_Protection_Entries
;
14019 -- Argument Compiler_Info
14022 Make_Attribute_Reference
(Loc
,
14023 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14024 Attribute_Name
=> Name_Address
));
14026 when System_Tasking_Protected_Objects_Single_Entry
=>
14027 Called_Subp
:= RE_Initialize_Protection_Entry
;
14029 -- Argument Compiler_Info
14032 Make_Attribute_Reference
(Loc
,
14033 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14034 Attribute_Name
=> Name_Address
));
14036 when System_Tasking_Protected_Objects
=>
14037 Called_Subp
:= RE_Initialize_Protection
;
14040 raise Program_Error
;
14043 -- Entry_Bodies parameter. This is a pointer to an array of
14044 -- pointers to the entry body procedures and barrier functions of
14045 -- the object. If the protected type has no entries this object
14046 -- will not exist, in this case, pass a null (it can happen when
14047 -- there are protected interrupt handlers or interfaces).
14050 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
14052 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14053 -- multiple entries).
14056 Make_Attribute_Reference
(Loc
,
14057 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14058 Attribute_Name
=> Name_Unrestricted_Access
));
14060 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14062 -- Find index mapping function (clumsy but ok for now)
14064 while Ekind
(P_Arr
) /= E_Function
loop
14065 Next_Entity
(P_Arr
);
14069 Make_Attribute_Reference
(Loc
,
14070 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14071 Attribute_Name
=> Name_Unrestricted_Access
));
14074 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
14076 -- This is the case where we have a protected object with
14077 -- interfaces and no entries, and the single entry restriction
14078 -- is in effect. We pass a null pointer for the entry
14079 -- parameter because there is no actual entry.
14081 Append_To
(Args
, Make_Null
(Loc
));
14083 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14085 -- This is the case where we have a protected object with no
14087 -- - either interrupt handlers with non restricted profile,
14089 -- Note that the types which are used for interrupt handlers
14090 -- (Static/Dynamic_Interrupt_Protection) are derived from
14091 -- Protection_Entries. We pass two null pointers because there
14092 -- is no actual entry, and the initialization procedure needs
14093 -- both Entry_Bodies and Find_Body_Index.
14095 Append_To
(Args
, Make_Null
(Loc
));
14096 Append_To
(Args
, Make_Null
(Loc
));
14100 Make_Procedure_Call_Statement
(Loc
,
14102 New_Occurrence_Of
(RTE
(Called_Subp
), Loc
),
14103 Parameter_Associations
=> Args
));
14107 if Has_Attach_Handler
(Ptyp
) then
14109 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14110 -- make the following call:
14112 -- Install_Handlers (_object,
14113 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14115 -- or, in the case of Ravenscar:
14117 -- Install_Restricted_Handlers
14118 -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14121 Args
: constant List_Id
:= New_List
;
14122 Table
: constant List_Id
:= New_List
;
14123 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
14126 -- Build the Priority parameter (only for ravenscar)
14130 -- Priority comes from a pragma
14132 if Present
(Prio_Var
) then
14133 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14135 -- Priority is the default one
14140 (RTE
(RE_Default_Interrupt_Priority
), Loc
));
14144 -- Build the Attach_Handler table argument
14146 while Present
(Ritem
) loop
14147 if Nkind
(Ritem
) = N_Pragma
14148 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
14151 Handler
: constant Node_Id
:=
14152 First
(Pragma_Argument_Associations
(Ritem
));
14154 Interrupt
: constant Node_Id
:= Next
(Handler
);
14155 Expr
: constant Node_Id
:= Expression
(Interrupt
);
14159 Make_Aggregate
(Loc
, Expressions
=> New_List
(
14160 Unchecked_Convert_To
14161 (RTE
(RE_System_Interrupt_Id
), Expr
),
14162 Make_Attribute_Reference
(Loc
,
14164 Make_Selected_Component
(Loc
,
14166 Make_Identifier
(Loc
, Name_uInit
),
14168 Duplicate_Subexpr_No_Checks
14169 (Expression
(Handler
))),
14170 Attribute_Name
=> Name_Access
))));
14174 Next_Rep_Item
(Ritem
);
14177 -- Append the table argument we just built
14179 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
14181 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14182 -- call to the statements.
14185 -- Call a simplified version of Install_Handlers to be used
14186 -- when the Ravenscar restrictions are in effect
14187 -- (Install_Restricted_Handlers).
14190 Make_Procedure_Call_Statement
(Loc
,
14193 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
14194 Parameter_Associations
=> Args
));
14197 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14199 -- First, prepends the _object argument
14202 Make_Attribute_Reference
(Loc
,
14204 Make_Selected_Component
(Loc
,
14205 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14207 Make_Identifier
(Loc
, Name_uObject
)),
14208 Attribute_Name
=> Name_Unchecked_Access
));
14211 -- Then, insert call to Install_Handlers
14214 Make_Procedure_Call_Statement
(Loc
,
14216 New_Occurrence_Of
(RTE
(RE_Install_Handlers
), Loc
),
14217 Parameter_Associations
=> Args
));
14223 end Make_Initialize_Protection
;
14225 ---------------------------
14226 -- Make_Task_Create_Call --
14227 ---------------------------
14229 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
14230 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
14240 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
14241 Tnam
:= Chars
(Ttyp
);
14243 -- Get task declaration. In the case of a task type declaration, this is
14244 -- simply the parent of the task type entity. In the single task
14245 -- declaration, this parent will be the implicit type, and we can find
14246 -- the corresponding single task declaration by searching forward in the
14247 -- declaration list in the tree.
14249 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14250 -- this type should have been removed during semantic analysis.
14252 Tdec
:= Parent
(Ttyp
);
14253 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
14254 N_Single_Task_Declaration
)
14259 -- Now we can find the task definition from this declaration
14261 Tdef
:= Task_Definition
(Tdec
);
14263 -- Build the parameter list for the call. Note that _Init is the name
14264 -- of the formal for the object to be initialized, which is the task
14265 -- value record itself.
14269 -- Priority parameter. Set to Unspecified_Priority unless there is a
14270 -- Priority rep item, in which case we take the value from the rep item.
14272 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
14274 Make_Selected_Component
(Loc
,
14275 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14276 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
14279 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14282 -- Optional Stack parameter
14284 if Restricted_Profile
then
14286 -- If the stack has been preallocated by the expander then
14287 -- pass its address. Otherwise, pass a null address.
14289 if Preallocated_Stacks_On_Target
then
14291 Make_Attribute_Reference
(Loc
,
14293 Make_Selected_Component
(Loc
,
14294 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14295 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
14296 Attribute_Name
=> Name_Address
));
14300 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
14304 -- Size parameter. If no Storage_Size pragma is present, then
14305 -- the size is taken from the taskZ variable for the type, which
14306 -- is either Unspecified_Size, or has been reset by the use of
14307 -- a Storage_Size attribute definition clause. If a pragma is
14308 -- present, then the size is taken from the _Size field of the
14309 -- task value record, which was set from the pragma value.
14311 if Present
(Tdef
) and then Has_Storage_Size_Pragma
(Tdef
) then
14313 Make_Selected_Component
(Loc
,
14314 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14315 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
14319 New_Occurrence_Of
(Storage_Size_Variable
(Ttyp
), Loc
));
14322 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14323 -- Task_Info pragma, in which case we take the value from the pragma.
14325 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
14327 Make_Selected_Component
(Loc
,
14328 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14329 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
14333 New_Occurrence_Of
(RTE
(RE_Unspecified_Task_Info
), Loc
));
14336 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14337 -- in which case we take the value from the rep item. The parameter is
14338 -- passed as an Integer because in the case of unspecified CPU the
14339 -- value is not in the range of CPU_Range.
14341 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
14343 Convert_To
(Standard_Integer
,
14344 Make_Selected_Component
(Loc
,
14345 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14346 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
14349 New_Occurrence_Of
(RTE
(RE_Unspecified_CPU
), Loc
));
14352 if not Restricted_Profile
then
14354 -- Deadline parameter. If no Relative_Deadline pragma is present,
14355 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14356 -- the deadline is taken from the _Relative_Deadline field of the
14357 -- task value record, which was set from the pragma value. Note that
14358 -- this parameter must not be generated for the restricted profiles
14359 -- since Ravenscar does not allow deadlines.
14361 -- Case where pragma Relative_Deadline applies: use given value
14363 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
14365 Make_Selected_Component
(Loc
,
14366 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14368 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
14370 -- No pragma Relative_Deadline apply to the task
14374 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14377 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14378 -- present, then the dispatching domain is null. If a rep item is
14379 -- present, then the dispatching domain is taken from the
14380 -- _Dispatching_Domain field of the task value record, which was set
14381 -- from the rep item value.
14383 -- Case where Dispatching_Domain rep item applies: use given value
14386 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
14389 Make_Selected_Component
(Loc
,
14391 Make_Identifier
(Loc
, Name_uInit
),
14393 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
14395 -- No pragma or aspect Dispatching_Domain applies to the task
14398 Append_To
(Args
, Make_Null
(Loc
));
14401 -- Number of entries. This is an expression of the form:
14403 -- n + _Init.a'Length + _Init.a'B'Length + ...
14405 -- where a,b... are the entry family names for the task definition
14408 Build_Entry_Count_Expression
14413 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
14415 Append_To
(Args
, Ecount
);
14417 -- Master parameter. This is a reference to the _Master parameter of
14418 -- the initialization procedure, except in the case of the pragma
14419 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14420 -- System.Tasking.Library_Task_Level.
14422 if Restriction_Active
(No_Task_Hierarchy
) = False then
14423 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
14426 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
14430 -- State parameter. This is a pointer to the task body procedure. The
14431 -- required value is obtained by taking 'Unrestricted_Access of the task
14432 -- body procedure and converting it (with an unchecked conversion) to
14433 -- the type required by the task kernel. For further details, see the
14434 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14435 -- than 'Address in order to avoid creating trampolines.
14438 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
14439 Subp_Ptr_Typ
: constant Node_Id
:=
14440 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
14441 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
14444 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
14445 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
14447 -- Be sure to freeze a reference to the access-to-subprogram type,
14448 -- otherwise gigi will complain that it's in the wrong scope, because
14449 -- it's actually inside the init procedure for the record type that
14450 -- corresponds to the task type.
14452 Set_Itype
(Ref
, Subp_Ptr_Typ
);
14453 Append_Freeze_Action
(Task_Rec
, Ref
);
14456 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
14457 Make_Qualified_Expression
(Loc
,
14458 Subtype_Mark
=> New_Occurrence_Of
(Subp_Ptr_Typ
, Loc
),
14460 Make_Attribute_Reference
(Loc
,
14461 Prefix
=> New_Occurrence_Of
(Body_Proc
, Loc
),
14462 Attribute_Name
=> Name_Unrestricted_Access
))));
14465 -- Discriminants parameter. This is just the address of the task
14466 -- value record itself (which contains the discriminant values
14469 Make_Attribute_Reference
(Loc
,
14470 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14471 Attribute_Name
=> Name_Address
));
14473 -- Elaborated parameter. This is an access to the elaboration Boolean
14476 Make_Attribute_Reference
(Loc
,
14477 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
14478 Attribute_Name
=> Name_Unchecked_Access
));
14480 -- Add Chain parameter (not done for sequential elaboration policy, see
14481 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14483 if Partition_Elaboration_Policy
/= 'S' then
14484 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
14487 -- Task name parameter. Take this from the _Task_Id parameter to the
14488 -- init call unless there is a Task_Name pragma, in which case we take
14489 -- the value from the pragma.
14491 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
14492 -- Copy expression in full, because it may be dynamic and have
14499 (Pragma_Argument_Associations
14501 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
14504 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
14507 -- Created_Task parameter. This is the _Task_Id field of the task
14511 Make_Selected_Component
(Loc
,
14512 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14513 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
14519 if Restricted_Profile
then
14520 if Partition_Elaboration_Policy
= 'S' then
14521 Create_RE
:= RE_Create_Restricted_Task_Sequential
;
14523 Create_RE
:= RE_Create_Restricted_Task
;
14526 Create_RE
:= RE_Create_Task
;
14529 Name
:= New_Occurrence_Of
(RTE
(Create_RE
), Loc
);
14533 Make_Procedure_Call_Statement
(Loc
,
14535 Parameter_Associations
=> Args
);
14536 end Make_Task_Create_Call
;
14538 ------------------------------
14539 -- Next_Protected_Operation --
14540 ------------------------------
14542 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
14546 -- Check whether there is a subsequent body for a protected operation
14547 -- in the current protected body. In Ada2012 that includes expression
14548 -- functions that are completions.
14550 Next_Op
:= Next
(N
);
14551 while Present
(Next_Op
)
14552 and then not Nkind_In
(Next_Op
,
14553 N_Subprogram_Body
, N_Entry_Body
, N_Expression_Function
)
14559 end Next_Protected_Operation
;
14561 ---------------------
14562 -- Null_Statements --
14563 ---------------------
14565 function Null_Statements
(Stats
: List_Id
) return Boolean is
14569 Stmt
:= First
(Stats
);
14570 while Nkind
(Stmt
) /= N_Empty
14571 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
14573 (Nkind
(Stmt
) = N_Pragma
14575 Nam_In
(Pragma_Name
(Stmt
), Name_Unreferenced
,
14582 return Nkind
(Stmt
) = N_Empty
;
14583 end Null_Statements
;
14585 --------------------------
14586 -- Parameter_Block_Pack --
14587 --------------------------
14589 function Parameter_Block_Pack
14591 Blk_Typ
: Entity_Id
;
14595 Stmts
: List_Id
) return Node_Id
14597 Actual
: Entity_Id
;
14598 Expr
: Node_Id
:= Empty
;
14599 Formal
: Entity_Id
;
14600 Has_Param
: Boolean := False;
14603 Temp_Asn
: Node_Id
;
14604 Temp_Nam
: Node_Id
;
14607 Actual
:= First
(Actuals
);
14608 Formal
:= Defining_Identifier
(First
(Formals
));
14609 Params
:= New_List
;
14610 while Present
(Actual
) loop
14611 if Is_By_Copy_Type
(Etype
(Actual
)) then
14613 -- Jnn : aliased <formal-type>
14615 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14618 Make_Object_Declaration
(Loc
,
14619 Aliased_Present
=> True,
14620 Defining_Identifier
=> Temp_Nam
,
14621 Object_Definition
=>
14622 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
14624 if Ekind
(Formal
) /= E_Out_Parameter
then
14630 New_Occurrence_Of
(Temp_Nam
, Loc
);
14632 Set_Assignment_OK
(Temp_Asn
);
14635 Make_Assignment_Statement
(Loc
,
14637 Expression
=> New_Copy_Tree
(Actual
)));
14641 -- Jnn'unchecked_access
14644 Make_Attribute_Reference
(Loc
,
14645 Attribute_Name
=> Name_Unchecked_Access
,
14646 Prefix
=> New_Occurrence_Of
(Temp_Nam
, Loc
)));
14650 -- The controlling parameter is omitted
14653 if not Is_Controlling_Actual
(Actual
) then
14655 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14661 Next_Actual
(Actual
);
14662 Next_Formal_With_Extras
(Formal
);
14666 Expr
:= Make_Aggregate
(Loc
, Params
);
14671 -- J1'unchecked_access;
14672 -- <actual2>'reference;
14675 P
:= Make_Temporary
(Loc
, 'P');
14678 Make_Object_Declaration
(Loc
,
14679 Defining_Identifier
=> P
,
14680 Object_Definition
=> New_Occurrence_Of
(Blk_Typ
, Loc
),
14681 Expression
=> Expr
));
14684 end Parameter_Block_Pack
;
14686 ----------------------------
14687 -- Parameter_Block_Unpack --
14688 ----------------------------
14690 function Parameter_Block_Unpack
14694 Formals
: List_Id
) return List_Id
14696 Actual
: Entity_Id
;
14698 Formal
: Entity_Id
;
14699 Has_Asnmt
: Boolean := False;
14700 Result
: constant List_Id
:= New_List
;
14703 Actual
:= First
(Actuals
);
14704 Formal
:= Defining_Identifier
(First
(Formals
));
14705 while Present
(Actual
) loop
14706 if Is_By_Copy_Type
(Etype
(Actual
))
14707 and then Ekind
(Formal
) /= E_In_Parameter
14710 -- <actual> := P.<formal>;
14713 Make_Assignment_Statement
(Loc
,
14717 Make_Explicit_Dereference
(Loc
,
14718 Make_Selected_Component
(Loc
,
14720 New_Occurrence_Of
(P
, Loc
),
14722 Make_Identifier
(Loc
, Chars
(Formal
)))));
14724 Set_Assignment_OK
(Name
(Asnmt
));
14725 Append_To
(Result
, Asnmt
);
14730 Next_Actual
(Actual
);
14731 Next_Formal_With_Extras
(Formal
);
14737 return New_List
(Make_Null_Statement
(Loc
));
14739 end Parameter_Block_Unpack
;
14741 ----------------------
14742 -- Set_Discriminals --
14743 ----------------------
14745 procedure Set_Discriminals
(Dec
: Node_Id
) is
14748 D_Minal
: Entity_Id
;
14751 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
14752 Pdef
:= Defining_Identifier
(Dec
);
14754 if Has_Discriminants
(Pdef
) then
14755 D
:= First_Discriminant
(Pdef
);
14756 while Present
(D
) loop
14758 Make_Defining_Identifier
(Sloc
(D
),
14759 Chars
=> New_External_Name
(Chars
(D
), 'D'));
14761 Set_Ekind
(D_Minal
, E_Constant
);
14762 Set_Etype
(D_Minal
, Etype
(D
));
14763 Set_Scope
(D_Minal
, Pdef
);
14764 Set_Discriminal
(D
, D_Minal
);
14765 Set_Discriminal_Link
(D_Minal
, D
);
14767 Next_Discriminant
(D
);
14770 end Set_Discriminals
;
14772 -----------------------
14773 -- Trivial_Accept_OK --
14774 -----------------------
14776 function Trivial_Accept_OK
return Boolean is
14778 case Opt
.Task_Dispatching_Policy
is
14780 -- If we have the default task dispatching policy in effect, we can
14781 -- definitely do the optimization (one way of looking at this is to
14782 -- think of the formal definition of the default policy being allowed
14783 -- to run any task it likes after a rendezvous, so even if notionally
14784 -- a full rescheduling occurs, we can say that our dispatching policy
14785 -- (i.e. the default dispatching policy) reorders the queue to be the
14786 -- same as just before the call.
14791 -- FIFO_Within_Priorities certainly does not permit this
14792 -- optimization since the Rendezvous is a scheduling action that may
14793 -- require some other task to be run.
14798 -- For now, disallow the optimization for all other policies. This
14799 -- may be over-conservative, but it is certainly not incorrect.
14805 end Trivial_Accept_OK
;