1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Ch3
; use Exp_Ch3
;
32 with Exp_Ch6
; use Exp_Ch6
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Dbug
; use Exp_Dbug
;
35 with Exp_Disp
; use Exp_Disp
;
36 with Exp_Sel
; use Exp_Sel
;
37 with Exp_Smem
; use Exp_Smem
;
38 with Exp_Tss
; use Exp_Tss
;
39 with Exp_Util
; use Exp_Util
;
40 with Freeze
; use Freeze
;
42 with Itypes
; use Itypes
;
43 with Namet
; use Namet
;
44 with Nlists
; use Nlists
;
45 with Nmake
; use Nmake
;
47 with Restrict
; use Restrict
;
48 with Rident
; use Rident
;
49 with Rtsfind
; use Rtsfind
;
51 with Sem_Aux
; use Sem_Aux
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Ch9
; use Sem_Ch9
;
55 with Sem_Ch11
; use Sem_Ch11
;
56 with Sem_Elab
; use Sem_Elab
;
57 with Sem_Eval
; use Sem_Eval
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Util
; use Sem_Util
;
60 with Sinfo
; use Sinfo
;
61 with Snames
; use Snames
;
62 with Stand
; use Stand
;
63 with Stringt
; use Stringt
;
64 with Targparm
; use Targparm
;
65 with Tbuild
; use Tbuild
;
66 with Uintp
; use Uintp
;
68 package body Exp_Ch9
is
70 -- The following constant establishes the upper bound for the index of
71 -- an entry family. It is used to limit the allocated size of protected
72 -- types with defaulted discriminant of an integer type, when the bound
73 -- of some entry family depends on a discriminant. The limitation to entry
74 -- families of 128K should be reasonable in all cases, and is a documented
75 -- implementation restriction.
77 Entry_Family_Bound
: constant Pos
:= 2**16;
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Actual_Index_Expression
87 Tsk
: Entity_Id
) return Node_Id
;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
92 procedure Add_Object_Pointer
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
101 procedure Add_Formal_Renamings
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
113 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
118 function Build_Barrier_Function
121 Pid
: Node_Id
) return Node_Id
;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
125 function Build_Barrier_Function_Specification
127 Def_Id
: Entity_Id
) return Node_Id
;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
131 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
);
132 -- Build the body of a wrapper procedure for an entry or entry family that
133 -- has contract cases, preconditions, or postconditions. The body gathers
134 -- the executable contract items and expands them in the usual way, and
135 -- performs the entry call itself. This way preconditions are evaluated
136 -- before the call is queued. E is the entry in question, and Decl is the
137 -- enclosing synchronized type declaration at whose freeze point the
138 -- generated body is analyzed.
140 function Build_Corresponding_Record
143 Loc
: Source_Ptr
) return Node_Id
;
144 -- Common to tasks and protected types. Copy discriminant specifications,
145 -- build record declaration. N is the type declaration, Ctyp is the
146 -- concurrent entity (task type or protected type).
148 function Build_Dispatching_Tag_Check
150 N
: Node_Id
) return Node_Id
;
151 -- Utility to create the tree to check whether the dispatching call in
152 -- a timed entry call, a conditional entry call, or an asynchronous
153 -- transfer of control is a call to a primitive of a non-synchronized type.
154 -- K is the temporary that holds the tagged kind of the target object, and
155 -- N is the enclosing construct.
157 function Build_Entry_Count_Expression
158 (Concurrent_Type
: Node_Id
;
159 Component_List
: List_Id
;
160 Loc
: Source_Ptr
) return Node_Id
;
161 -- Compute number of entries for concurrent object. This is a count of
162 -- simple entries, followed by an expression that computes the length
163 -- of the range of each entry family. A single array with that size is
164 -- allocated for each concurrent object of the type.
166 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
;
167 -- Build the function that translates the entry index in the call
168 -- (which depends on the size of entry families) into an index into the
169 -- Entry_Bodies_Array, to determine the body and barrier function used
170 -- in a protected entry call. A pointer to this function appears in every
173 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
;
174 -- Build subprogram declaration for previous one
176 function Build_Lock_Free_Protected_Subprogram_Body
179 Unprot_Spec
: Node_Id
) return Node_Id
;
180 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
181 -- the subprogram specification of the unprotected version of N. Transform
182 -- N such that it invokes the unprotected version of the body.
184 function Build_Lock_Free_Unprotected_Subprogram_Body
186 Prot_Typ
: Node_Id
) return Node_Id
;
187 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
188 -- of N where the original statements of N are synchronized through atomic
189 -- actions such as compare and exchange. Prior to invoking this routine, it
190 -- has been established that N can be implemented in a lock-free fashion.
192 function Build_Parameter_Block
196 Decls
: List_Id
) return Entity_Id
;
197 -- Generate an access type for each actual parameter in the list Actuals.
198 -- Create an encapsulating record that contains all the actuals and return
199 -- its type. Generate:
200 -- type Ann1 is access all <actual1-type>
202 -- type AnnN is access all <actualN-type>
203 -- type Pnn is record
209 function Build_Protected_Entry
212 Pid
: Node_Id
) return Node_Id
;
213 -- Build the procedure implementing the statement sequence of the specified
216 function Build_Protected_Entry_Specification
219 Ent_Id
: Entity_Id
) return Node_Id
;
220 -- Build a specification for the procedure implementing the statements of
221 -- the specified entry body. Add attributes associating it with the entry
222 -- defining identifier Ent_Id.
224 function Build_Protected_Spec
226 Obj_Type
: Entity_Id
;
228 Unprotected
: Boolean := False) return List_Id
;
229 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
230 -- Subprogram_Type. Builds signature of protected subprogram, adding the
231 -- formal that corresponds to the object itself. For an access to protected
232 -- subprogram, there is no object type to specify, so the parameter has
233 -- type Address and mode In. An indirect call through such a pointer will
234 -- convert the address to a reference to the actual object. The object is
235 -- a limited record and therefore a by_reference type.
237 function Build_Protected_Subprogram_Body
240 N_Op_Spec
: Node_Id
) return Node_Id
;
241 -- This function is used to construct the protected version of a protected
242 -- subprogram. Its statement sequence first defers abort, then locks the
243 -- associated protected object, and then enters a block that contains a
244 -- call to the unprotected version of the subprogram (for details, see
245 -- Build_Unprotected_Subprogram_Body). This block statement requires a
246 -- cleanup handler that unlocks the object in all cases. For details,
247 -- see Exp_Ch7.Expand_Cleanup_Actions.
249 function Build_Renamed_Formal_Declaration
253 Renamed_Formal
: Node_Id
) return Node_Id
;
254 -- Create a renaming declaration for a formal, within a protected entry
255 -- body or an accept body. The renamed object is a component of the
256 -- parameter block that is a parameter in the entry call.
258 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
259 -- does not dereference the corresponding component to prevent an illegal
260 -- use of the incomplete type (AI05-0151).
262 function Build_Selected_Name
264 Selector
: Entity_Id
;
265 Append_Char
: Character := ' ') return Name_Id
;
266 -- Build a name in the form of Prefix__Selector, with an optional character
267 -- appended. This is used for internal subprograms generated for operations
268 -- of protected types, including barrier functions. For the subprograms
269 -- generated for entry bodies and entry barriers, the generated name
270 -- includes a sequence number that makes names unique in the presence of
271 -- entry overloading. This is necessary because entry body procedures and
272 -- barrier functions all have the same signature.
274 procedure Build_Simple_Entry_Call
279 -- Some comments here would be useful ???
281 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
;
282 -- This routine constructs a specification for the procedure that we will
283 -- build for the task body for task type T. The spec has the form:
285 -- procedure tnameB (_Task : access tnameV);
287 -- where name is the character name taken from the task type entity that
288 -- is passed as the argument to the procedure, and tnameV is the task
289 -- value type that is associated with the task type.
291 function Build_Unprotected_Subprogram_Body
293 Pid
: Node_Id
) return Node_Id
;
294 -- This routine constructs the unprotected version of a protected
295 -- subprogram body, which is contains all of the code in the original,
296 -- unexpanded body. This is the version of the protected subprogram that is
297 -- called from all protected operations on the same object, including the
298 -- protected version of the same subprogram.
300 procedure Build_Wrapper_Bodies
304 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
305 -- record of a concurrent type. N is the insertion node where all bodies
306 -- will be placed. This routine builds the bodies of the subprograms which
307 -- serve as an indirection mechanism to overriding primitives of concurrent
308 -- types, entries and protected procedures. Any new body is analyzed.
310 procedure Build_Wrapper_Specs
314 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
315 -- record of a concurrent type. N is the insertion node where all specs
316 -- will be placed. This routine builds the specs of the subprograms which
317 -- serve as an indirection mechanism to overriding primitives of concurrent
318 -- types, entries and protected procedures. Any new spec is analyzed.
320 procedure Collect_Entry_Families
323 Current_Node
: in out Node_Id
;
324 Conctyp
: Entity_Id
);
325 -- For each entry family in a concurrent type, create an anonymous array
326 -- type of the right size, and add a component to the corresponding_record.
328 function Concurrent_Object
329 (Spec_Id
: Entity_Id
;
330 Conc_Typ
: Entity_Id
) return Entity_Id
;
331 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
332 -- the entity associated with the concurrent object in the Protected_Body_
333 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
334 -- denotes formal parameter _O, _object or _task.
336 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
;
337 -- Copy the result type of a function specification, when building the
338 -- internal operation corresponding to a protected function, or when
339 -- expanding an access to protected function. If the result is an anonymous
340 -- access to subprogram itself, we need to create a new signature with the
341 -- same parameter names and the same resolved types, but with new entities
344 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
345 -- Decls is a list which may contain the declarations created by Install_
346 -- Private_Data_Declarations. All generated entities are marked as needing
347 -- debug info and debug nodes are manually generation where necessary. This
348 -- step of the expansion must to be done after private data has been moved
349 -- to its final resting scope to ensure proper visibility of debug objects.
351 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
);
352 -- If control flow optimizations are suppressed, and Alt is an accept,
353 -- delay, or entry call alternative with no trailing statements, insert
354 -- a null trailing statement with the given Loc (which is the sloc of
355 -- the accept, delay, or entry call statement). There might not be any
356 -- generated code for the accept, delay, or entry call itself (the effect
357 -- of these statements is part of the general processsing done for the
358 -- enclosing selective accept, timed entry call, or asynchronous select),
359 -- and the null statement is there to carry the sloc of that statement to
360 -- the back-end for trace-based coverage analysis purposes.
362 procedure Extract_Dispatching_Call
364 Call_Ent
: out Entity_Id
;
365 Object
: out Entity_Id
;
366 Actuals
: out List_Id
;
367 Formals
: out List_Id
);
368 -- Given a dispatching call, extract the entity of the name of the call,
369 -- its actual dispatching object, its actual parameters and the formal
370 -- parameters of the overridden interface-level version. If the type of
371 -- the dispatching object is an access type then an explicit dereference
372 -- is returned in Object.
374 procedure Extract_Entry
376 Concval
: out Node_Id
;
378 Index
: out Node_Id
);
379 -- Given an entry call, returns the associated concurrent object, the entry
380 -- name, and the entry family index.
382 function Family_Offset
387 Cap
: Boolean) return Node_Id
;
388 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
389 -- accept statement, or the upper bound in the discrete subtype of an entry
390 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
391 -- type of the entry. If Cap is true, the result is capped according to
392 -- Entry_Family_Bound.
399 Cap
: Boolean) return Node_Id
;
400 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
401 -- family, and handle properly the superflat case. This is equivalent to
402 -- the use of 'Length on the index type, but must use Family_Offset to
403 -- handle properly the case of bounds that depend on discriminants. If
404 -- Cap is true, the result is capped according to Entry_Family_Bound.
406 procedure Find_Enclosing_Context
408 Context
: out Node_Id
;
409 Context_Id
: out Entity_Id
;
410 Context_Decls
: out List_Id
);
411 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
412 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
413 -- nearest enclosing body, block, package, or return statement and return
414 -- its constituents. Context is the enclosing construct, Context_Id is
415 -- the scope of Context_Id and Context_Decls is the declarative list of
418 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
419 -- Given a subprogram identifier, return the entity which is associated
420 -- with the protection entry index in the Protected_Body_Subprogram or
421 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
424 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean;
425 -- Tell whether a given subprogram cannot raise an exception
427 function Is_Potentially_Large_Family
428 (Base_Index
: Entity_Id
;
431 Hi
: Node_Id
) return Boolean;
433 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
434 -- Determine whether Id is a function or a procedure and is marked as a
435 -- private primitive.
437 function Null_Statements
(Stats
: List_Id
) return Boolean;
438 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
439 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
440 -- to still count as null. Returns True for a null sequence. The argument
441 -- is the list of statements from the DO-END sequence.
443 function Parameter_Block_Pack
449 Stmts
: List_Id
) return Entity_Id
;
450 -- Set the components of the generated parameter block with the values
451 -- of the actual parameters. Generate aliased temporaries to capture the
452 -- values for types that are passed by copy. Otherwise generate a reference
453 -- to the actual's value. Return the address of the aggregate block.
455 -- Jnn1 : alias <formal-type1>;
456 -- Jnn1 := <actual1>;
459 -- Jnn1'unchecked_access;
460 -- <actual2>'reference;
463 function Parameter_Block_Unpack
467 Formals
: List_Id
) return List_Id
;
468 -- Retrieve the values of the components from the parameter block and
469 -- assign then to the original actual parameters. Generate:
470 -- <actual1> := P.<formal1>;
472 -- <actualN> := P.<formalN>;
474 function Trivial_Accept_OK
return Boolean;
475 -- If there is no DO-END block for an accept, or if the DO-END block has
476 -- only null statements, then it is possible to do the Rendezvous with much
477 -- less overhead using the Accept_Trivial routine in the run-time library.
478 -- However, this is not always a valid optimization. Whether it is valid or
479 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
480 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
481 -- a rescheduling is required, so this optimization is not allowed. This
482 -- function returns True if the optimization is permitted.
484 -----------------------------
485 -- Actual_Index_Expression --
486 -----------------------------
488 function Actual_Index_Expression
492 Tsk
: Entity_Id
) return Node_Id
494 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
502 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
503 -- Compute difference between bounds of entry family
505 --------------------------
506 -- Actual_Family_Offset --
507 --------------------------
509 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
511 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
512 -- Replace a reference to a discriminant with a selected component
513 -- denoting the discriminant of the target task.
515 -----------------------------
516 -- Actual_Discriminant_Ref --
517 -----------------------------
519 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
520 Typ
: constant Entity_Id
:= Etype
(Bound
);
524 if not Is_Entity_Name
(Bound
)
525 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
527 if Nkind
(Bound
) = N_Attribute_Reference
then
530 B
:= New_Copy_Tree
(Bound
);
535 Make_Selected_Component
(Sloc
,
536 Prefix
=> New_Copy_Tree
(Tsk
),
537 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
539 Analyze_And_Resolve
(B
, Typ
);
543 Make_Attribute_Reference
(Sloc
,
544 Attribute_Name
=> Name_Pos
,
545 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
546 Expressions
=> New_List
(B
));
547 end Actual_Discriminant_Ref
;
549 -- Start of processing for Actual_Family_Offset
553 Make_Op_Subtract
(Sloc
,
554 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
555 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
556 end Actual_Family_Offset
;
558 -- Start of processing for Actual_Index_Expression
561 -- The queues of entries and entry families appear in textual order in
562 -- the associated record. The entry index is computed as the sum of the
563 -- number of queues for all entries that precede the designated one, to
564 -- which is added the index expression, if this expression denotes a
565 -- member of a family.
567 -- The following is a place holder for the count of simple entries
569 Num
:= Make_Integer_Literal
(Sloc
, 1);
571 -- We construct an expression which is a series of addition operations.
572 -- See comments in Entry_Index_Expression, which is identical in
575 if Present
(Index
) then
576 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
582 Actual_Family_Offset
(
583 Make_Attribute_Reference
(Sloc
,
584 Attribute_Name
=> Name_Pos
,
585 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
586 Expressions
=> New_List
(Relocate_Node
(Index
))),
587 Type_Low_Bound
(S
)));
592 -- Now add lengths of preceding entries and entry families
594 Prev
:= First_Entity
(Ttyp
);
595 while Chars
(Prev
) /= Chars
(Ent
)
596 or else (Ekind
(Prev
) /= Ekind
(Ent
))
597 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
599 if Ekind
(Prev
) = E_Entry
then
600 Set_Intval
(Num
, Intval
(Num
) + 1);
602 elsif Ekind
(Prev
) = E_Entry_Family
then
604 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
606 -- The need for the following full view retrieval stems from this
607 -- complex case of nested generics and tasking:
610 -- type Formal_Index is range <>;
613 -- type Index is private;
620 -- type Index is new Formal_Index range 1 .. 10;
623 -- package body Outer is
625 -- entry Fam (Index); -- (2)
628 -- package body Inner is -- (3)
636 -- We are currently building the index expression for the entry
637 -- call "T.E" (1). Part of the expansion must mention the range
638 -- of the discrete type "Index" (2) of entry family "Fam".
640 -- However only the private view of type "Index" is available to
641 -- the inner generic (3) because there was no prior mention of
642 -- the type inside "Inner". This visibility requirement is
643 -- implicit and cannot be detected during the construction of
644 -- the generic trees and needs special handling.
647 and then Is_Private_Type
(S
)
648 and then Present
(Full_View
(S
))
653 Lo
:= Type_Low_Bound
(S
);
654 Hi
:= Type_High_Bound
(S
);
661 Left_Opnd
=> Actual_Family_Offset
(Hi
, Lo
),
662 Right_Opnd
=> Make_Integer_Literal
(Sloc
, 1)));
664 -- Other components are anonymous types to be ignored
674 end Actual_Index_Expression
;
676 --------------------------
677 -- Add_Formal_Renamings --
678 --------------------------
680 procedure Add_Formal_Renamings
686 Ptr
: constant Entity_Id
:=
688 (Next
(First
(Parameter_Specifications
(Spec
))));
689 -- The name of the formal that holds the address of the parameter block
696 Renamed_Formal
: Node_Id
;
699 Formal
:= First_Formal
(Ent
);
700 while Present
(Formal
) loop
701 Comp
:= Entry_Component
(Formal
);
703 Make_Defining_Identifier
(Sloc
(Formal
),
704 Chars
=> Chars
(Formal
));
705 Set_Etype
(New_F
, Etype
(Formal
));
706 Set_Scope
(New_F
, Ent
);
708 -- Now we set debug info needed on New_F even though it does not come
709 -- from source, so that the debugger will get the right information
710 -- for these generated names.
712 Set_Debug_Info_Needed
(New_F
);
714 if Ekind
(Formal
) = E_In_Parameter
then
715 Set_Ekind
(New_F
, E_Constant
);
717 Set_Ekind
(New_F
, E_Variable
);
718 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
721 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
724 Make_Selected_Component
(Loc
,
726 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
727 Make_Identifier
(Loc
, Chars
(Ptr
))),
728 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
731 Build_Renamed_Formal_Declaration
732 (New_F
, Formal
, Comp
, Renamed_Formal
);
734 Append
(Decl
, Decls
);
735 Set_Renamed_Object
(Formal
, New_F
);
736 Next_Formal
(Formal
);
738 end Add_Formal_Renamings
;
740 ------------------------
741 -- Add_Object_Pointer --
742 ------------------------
744 procedure Add_Object_Pointer
746 Conc_Typ
: Entity_Id
;
749 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
754 -- Create the renaming declaration for the Protection object of a
755 -- protected type. _Object is used by Complete_Entry_Body.
756 -- ??? An attempt to make this a renaming was unsuccessful.
758 -- Build the entity for the access type
761 Make_Defining_Identifier
(Loc
,
762 New_External_Name
(Chars
(Rec_Typ
), 'P'));
765 -- _object : poVP := poVP!O;
768 Make_Object_Declaration
(Loc
,
769 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uObject
),
770 Object_Definition
=> New_Occurrence_Of
(Obj_Ptr
, Loc
),
772 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
773 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
774 Prepend_To
(Decls
, Decl
);
777 -- type poVP is access poV;
780 Make_Full_Type_Declaration
(Loc
,
781 Defining_Identifier
=>
784 Make_Access_To_Object_Definition
(Loc
,
785 Subtype_Indication
=>
786 New_Occurrence_Of
(Rec_Typ
, Loc
)));
787 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
788 Prepend_To
(Decls
, Decl
);
789 end Add_Object_Pointer
;
791 -----------------------
792 -- Build_Accept_Body --
793 -----------------------
795 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
796 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
797 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
804 -- At the end of the statement sequence, Complete_Rendezvous is called.
805 -- A label skipping the Complete_Rendezvous, and all other accept
806 -- processing, has already been added for the expansion of requeue
807 -- statements. The Sloc is copied from the last statement since it
808 -- is really part of this last statement.
812 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
813 Insert_Before
(Last
(Statements
(Stats
)), Call
);
816 -- If exception handlers are present, then append Complete_Rendezvous
817 -- calls to the handlers, and construct the required outer block. As
818 -- above, the Sloc is copied from the last statement in the sequence.
820 if Present
(Exception_Handlers
(Stats
)) then
821 Hand
:= First
(Exception_Handlers
(Stats
));
822 while Present
(Hand
) loop
825 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
826 Append
(Call
, Statements
(Hand
));
832 Make_Handled_Sequence_Of_Statements
(Loc
,
833 Statements
=> New_List
(
834 Make_Block_Statement
(Loc
,
835 Handled_Statement_Sequence
=> Stats
)));
841 -- At this stage we know that the new statement sequence does
842 -- not have an exception handler part, so we supply one to call
843 -- Exceptional_Complete_Rendezvous. This handler is
845 -- when all others =>
846 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
848 -- We handle Abort_Signal to make sure that we properly catch the abort
849 -- case and wake up the caller.
851 Ohandle
:= Make_Others_Choice
(Loc
);
852 Set_All_Others
(Ohandle
);
854 Set_Exception_Handlers
(New_S
,
856 Make_Implicit_Exception_Handler
(Loc
,
857 Exception_Choices
=> New_List
(Ohandle
),
859 Statements
=> New_List
(
860 Make_Procedure_Call_Statement
(Sloc
(Stats
),
861 Name
=> New_Occurrence_Of
(
862 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
863 Parameter_Associations
=> New_List
(
864 Make_Function_Call
(Sloc
(Stats
),
867 (RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
869 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
870 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
871 Expand_Exception_Handlers
(New_S
);
873 -- Exceptional_Complete_Rendezvous must be called with abort still
874 -- deferred, which is the case for a "when all others" handler.
877 end Build_Accept_Body
;
879 -----------------------------------
880 -- Build_Activation_Chain_Entity --
881 -----------------------------------
883 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
884 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean;
885 -- Determine whether an extended return statement has activation chain
887 --------------------------
888 -- Has_Activation_Chain --
889 --------------------------
891 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean is
895 Decl
:= First
(Return_Object_Declarations
(Stmt
));
896 while Present
(Decl
) loop
897 if Nkind
(Decl
) = N_Object_Declaration
898 and then Chars
(Defining_Identifier
(Decl
)) = Name_uChain
907 end Has_Activation_Chain
;
912 Context_Id
: Entity_Id
;
915 -- Start of processing for Build_Activation_Chain_Entity
918 -- Activation chain is never used for sequential elaboration policy, see
919 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
921 if Partition_Elaboration_Policy
= 'S' then
925 Find_Enclosing_Context
(N
, Context
, Context_Id
, Decls
);
927 -- If activation chain entity has not been declared already, create one
929 if Nkind
(Context
) = N_Extended_Return_Statement
930 or else No
(Activation_Chain_Entity
(Context
))
932 -- Since extended return statements do not store the entity of the
933 -- chain, examine the return object declarations to avoid creating
936 if Nkind
(Context
) = N_Extended_Return_Statement
937 and then Has_Activation_Chain
(Context
)
943 Loc
: constant Source_Ptr
:= Sloc
(Context
);
948 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
950 -- Note: An extended return statement is not really a task
951 -- activator, but it does have an activation chain on which to
952 -- store the tasks temporarily. On successful return, the tasks
953 -- on this chain are moved to the chain passed in by the caller.
954 -- We do not build an Activation_Chain_Entity for an extended
955 -- return statement, because we do not want to build a call to
956 -- Activate_Tasks. Task activation is the responsibility of the
959 if Nkind
(Context
) /= N_Extended_Return_Statement
then
960 Set_Activation_Chain_Entity
(Context
, Chain
);
964 Make_Object_Declaration
(Loc
,
965 Defining_Identifier
=> Chain
,
966 Aliased_Present
=> True,
968 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
));
970 Prepend_To
(Decls
, Decl
);
972 -- Ensure that _chain appears in the proper scope of the context
974 if Context_Id
/= Current_Scope
then
975 Push_Scope
(Context_Id
);
983 end Build_Activation_Chain_Entity
;
985 ----------------------------
986 -- Build_Barrier_Function --
987 ----------------------------
989 function Build_Barrier_Function
992 Pid
: Node_Id
) return Node_Id
994 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
995 Cond
: constant Node_Id
:= Condition
(Ent_Formals
);
996 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
997 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
998 Op_Decls
: constant List_Id
:= New_List
;
1000 Func_Body
: Node_Id
;
1003 -- Add a declaration for the Protection object, renaming declarations
1004 -- for the discriminals and privals and finally a declaration for the
1005 -- entry family index (if applicable).
1007 Install_Private_Data_Declarations
(Sloc
(N
),
1013 Family
=> Ekind
(Ent
) = E_Entry_Family
);
1015 -- If compiling with -fpreserve-control-flow, make sure we insert an
1016 -- IF statement so that the back-end knows to generate a conditional
1017 -- branch instruction, even if the condition is just the name of a
1018 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1019 -- such redundant IF statements under -fpreserve-control-flow
1020 -- (whether coming from this routine, or directly from source).
1022 if Opt
.Suppress_Control_Flow_Optimizations
then
1024 Make_Implicit_If_Statement
(Cond
,
1026 Then_Statements
=> New_List
(
1027 Make_Simple_Return_Statement
(Loc
,
1028 New_Occurrence_Of
(Standard_True
, Loc
))),
1030 Else_Statements
=> New_List
(
1031 Make_Simple_Return_Statement
(Loc
,
1032 New_Occurrence_Of
(Standard_False
, Loc
))));
1035 Stmt
:= Make_Simple_Return_Statement
(Loc
, Cond
);
1038 -- Note: the condition in the barrier function needs to be properly
1039 -- processed for the C/Fortran boolean possibility, but this happens
1040 -- automatically since the return statement does this normalization.
1043 Make_Subprogram_Body
(Loc
,
1045 Build_Barrier_Function_Specification
(Loc
,
1046 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
1047 Declarations
=> Op_Decls
,
1048 Handled_Statement_Sequence
=>
1049 Make_Handled_Sequence_Of_Statements
(Loc
,
1050 Statements
=> New_List
(Stmt
)));
1051 Set_Is_Entry_Barrier_Function
(Func_Body
);
1054 end Build_Barrier_Function
;
1056 ------------------------------------------
1057 -- Build_Barrier_Function_Specification --
1058 ------------------------------------------
1060 function Build_Barrier_Function_Specification
1062 Def_Id
: Entity_Id
) return Node_Id
1065 Set_Debug_Info_Needed
(Def_Id
);
1068 Make_Function_Specification
(Loc
,
1069 Defining_Unit_Name
=> Def_Id
,
1070 Parameter_Specifications
=> New_List
(
1071 Make_Parameter_Specification
(Loc
,
1072 Defining_Identifier
=>
1073 Make_Defining_Identifier
(Loc
, Name_uO
),
1075 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
1077 Make_Parameter_Specification
(Loc
,
1078 Defining_Identifier
=>
1079 Make_Defining_Identifier
(Loc
, Name_uE
),
1081 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
1083 Result_Definition
=>
1084 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1085 end Build_Barrier_Function_Specification
;
1087 --------------------------
1088 -- Build_Call_With_Task --
1089 --------------------------
1091 function Build_Call_With_Task
1093 E
: Entity_Id
) return Node_Id
1095 Loc
: constant Source_Ptr
:= Sloc
(N
);
1098 Make_Function_Call
(Loc
,
1099 Name
=> New_Occurrence_Of
(E
, Loc
),
1100 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
1101 end Build_Call_With_Task
;
1103 -----------------------------
1104 -- Build_Class_Wide_Master --
1105 -----------------------------
1107 procedure Build_Class_Wide_Master
(Typ
: Entity_Id
) is
1108 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1109 Master_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 function Overriding_Possible
2447 (Iface_Op
: Entity_Id
;
2448 Wrapper
: Entity_Id
) return Boolean;
2449 -- Determine whether a primitive operation can be overridden by Wrapper.
2450 -- Iface_Op is the candidate primitive operation of an interface type,
2451 -- Wrapper is the generated entry wrapper.
2453 function Replicate_Formals
2455 Formals
: List_Id
) return List_Id
;
2456 -- An explicit parameter replication is required due to the Is_Entry_
2457 -- Formal flag being set for all the formals of an entry. The explicit
2458 -- replication removes the flag that would otherwise cause a different
2459 -- path of analysis.
2461 -------------------------
2462 -- Overriding_Possible --
2463 -------------------------
2465 function Overriding_Possible
2466 (Iface_Op
: Entity_Id
;
2467 Wrapper
: Entity_Id
) return Boolean
2469 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2470 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2472 function Type_Conformant_Parameters
2473 (Iface_Op_Params
: List_Id
;
2474 Wrapper_Params
: List_Id
) return Boolean;
2475 -- Determine whether the parameters of the generated entry wrapper
2476 -- and those of a primitive operation are type conformant. During
2477 -- this check, the first parameter of the primitive operation is
2478 -- skipped if it is a controlling argument: protected functions
2479 -- may have a controlling result.
2481 --------------------------------
2482 -- Type_Conformant_Parameters --
2483 --------------------------------
2485 function Type_Conformant_Parameters
2486 (Iface_Op_Params
: List_Id
;
2487 Wrapper_Params
: List_Id
) return Boolean
2489 Iface_Op_Param
: Node_Id
;
2490 Iface_Op_Typ
: Entity_Id
;
2491 Wrapper_Param
: Node_Id
;
2492 Wrapper_Typ
: Entity_Id
;
2495 -- Skip the first (controlling) parameter of primitive operation
2497 Iface_Op_Param
:= First
(Iface_Op_Params
);
2499 if Present
(First_Formal
(Iface_Op
))
2500 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2502 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2505 Wrapper_Param
:= First
(Wrapper_Params
);
2506 while Present
(Iface_Op_Param
)
2507 and then Present
(Wrapper_Param
)
2509 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2510 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2512 -- The two parameters must be mode conformant
2514 if not Conforming_Types
2515 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2520 Next
(Iface_Op_Param
);
2521 Next
(Wrapper_Param
);
2524 -- One of the lists is longer than the other
2526 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2531 end Type_Conformant_Parameters
;
2533 -- Start of processing for Overriding_Possible
2536 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2540 -- If an inherited subprogram is implemented by a protected procedure
2541 -- or an entry, then the first parameter of the inherited subprogram
2542 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2544 if Ekind
(Iface_Op
) = E_Procedure
2545 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2548 Obj_Param
: constant Node_Id
:=
2549 First
(Parameter_Specifications
(Iface_Op_Spec
));
2551 if not Out_Present
(Obj_Param
)
2552 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2561 Type_Conformant_Parameters
2562 (Parameter_Specifications
(Iface_Op_Spec
),
2563 Parameter_Specifications
(Wrapper_Spec
));
2564 end Overriding_Possible
;
2566 -----------------------
2567 -- Replicate_Formals --
2568 -----------------------
2570 function Replicate_Formals
2572 Formals
: List_Id
) return List_Id
2574 New_Formals
: constant List_Id
:= New_List
;
2576 Param_Type
: Node_Id
;
2579 Formal
:= First
(Formals
);
2581 -- Skip the object parameter when dealing with primitives declared
2582 -- between two views.
2584 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2585 and then not Has_Controlling_Result
(Subp_Id
)
2587 Formal
:= Next
(Formal
);
2590 while Present
(Formal
) loop
2592 -- Create an explicit copy of the entry parameter
2594 -- When creating the wrapper subprogram for a primitive operation
2595 -- of a protected interface we must construct an equivalent
2596 -- signature to that of the overriding operation. For regular
2597 -- parameters we can just use the type of the formal, but for
2598 -- access to subprogram parameters we need to reanalyze the
2599 -- parameter type to create local entities for the signature of
2600 -- the subprogram type. Using the entities of the overriding
2601 -- subprogram will result in out-of-scope errors in the back-end.
2603 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2604 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2607 New_Occurrence_Of
(Etype
(Parameter_Type
(Formal
)), Loc
);
2610 Append_To
(New_Formals
,
2611 Make_Parameter_Specification
(Loc
,
2612 Defining_Identifier
=>
2613 Make_Defining_Identifier
(Loc
,
2614 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2615 In_Present
=> In_Present
(Formal
),
2616 Out_Present
=> Out_Present
(Formal
),
2617 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
2618 Parameter_Type
=> Param_Type
));
2624 end Replicate_Formals
;
2628 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2629 First_Param
: Node_Id
:= Empty
;
2631 Iface_Elmt
: Elmt_Id
;
2632 Iface_Op
: Entity_Id
;
2633 Iface_Op_Elmt
: Elmt_Id
;
2634 Overridden_Subp
: Entity_Id
;
2636 -- Start of processing for Build_Wrapper_Spec
2639 -- No point in building wrappers for untagged concurrent types
2641 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2643 -- Check if this subprogram has a profile that matches some interface
2646 Check_Synchronized_Overriding
(Subp_Id
, Overridden_Subp
);
2648 if Present
(Overridden_Subp
) then
2650 First
(Parameter_Specifications
(Parent
(Overridden_Subp
)));
2652 -- An entry or a protected procedure can override a routine where the
2653 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2654 -- type. Since the wrapper must have the exact same signature as that of
2655 -- the overridden subprogram, we try to find the overriding candidate
2656 -- and use its controlling formal.
2658 -- Check every implemented interface
2660 elsif Present
(Interfaces
(Obj_Typ
)) then
2661 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2662 Search
: while Present
(Iface_Elmt
) loop
2663 Iface
:= Node
(Iface_Elmt
);
2665 -- Check every interface primitive
2667 if Present
(Primitive_Operations
(Iface
)) then
2668 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2669 while Present
(Iface_Op_Elmt
) loop
2670 Iface_Op
:= Node
(Iface_Op_Elmt
);
2672 -- Ignore predefined primitives
2674 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2675 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2677 -- The current primitive operation can be overridden by
2678 -- the generated entry wrapper.
2680 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2682 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2688 Next_Elmt
(Iface_Op_Elmt
);
2692 Next_Elmt
(Iface_Elmt
);
2696 -- Do not generate the wrapper if no interface primitive is covered by
2697 -- the subprogram and it is not a primitive declared declared between
2698 -- two views (see Process_Full_View).
2701 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2707 Wrapper_Id
: constant Entity_Id
:=
2708 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2709 New_Formals
: List_Id
;
2710 Obj_Param
: Node_Id
;
2711 Obj_Param_Typ
: Entity_Id
;
2714 -- Minimum decoration is needed to catch the entity in
2715 -- Sem_Ch6.Override_Dispatching_Operation.
2717 if Ekind
(Subp_Id
) = E_Function
then
2718 Set_Ekind
(Wrapper_Id
, E_Function
);
2720 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2723 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2724 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2725 Set_Is_Private_Primitive
(Wrapper_Id
,
2726 Is_Private_Primitive_Subprogram
(Subp_Id
));
2728 -- Process the formals
2730 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2732 -- A function with a controlling result and no first controlling
2733 -- formal needs no additional parameter.
2735 if Has_Controlling_Result
(Subp_Id
)
2737 (No
(First_Formal
(Subp_Id
))
2738 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2742 -- Routine Subp_Id has been found to override an interface primitive.
2743 -- If the interface operation has an access parameter, create a copy
2744 -- of it, with the same null exclusion indicator if present.
2746 elsif Present
(First_Param
) then
2747 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2749 Make_Access_Definition
(Loc
,
2751 New_Occurrence_Of
(Obj_Typ
, Loc
),
2752 Null_Exclusion_Present
=>
2753 Null_Exclusion_Present
(Parameter_Type
(First_Param
)),
2755 Constant_Present
(Parameter_Type
(First_Param
)));
2757 Obj_Param_Typ
:= New_Occurrence_Of
(Obj_Typ
, Loc
);
2761 Make_Parameter_Specification
(Loc
,
2762 Defining_Identifier
=>
2763 Make_Defining_Identifier
(Loc
,
2765 In_Present
=> In_Present
(First_Param
),
2766 Out_Present
=> Out_Present
(First_Param
),
2767 Parameter_Type
=> Obj_Param_Typ
);
2769 Prepend_To
(New_Formals
, Obj_Param
);
2771 -- If we are dealing with a primitive declared between two views,
2772 -- implemented by a synchronized operation, we need to create
2773 -- a default parameter. The mode of the parameter must match that
2774 -- of the primitive operation.
2777 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2780 Make_Parameter_Specification
(Loc
,
2781 Defining_Identifier
=>
2782 Make_Defining_Identifier
(Loc
, Name_uO
),
2784 In_Present
(Parent
(First_Entity
(Subp_Id
))),
2785 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2786 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2788 Prepend_To
(New_Formals
, Obj_Param
);
2791 -- Build the final spec. If it is a function with a controlling
2792 -- result, it is a primitive operation of the corresponding
2793 -- record type, so mark the spec accordingly.
2795 if Ekind
(Subp_Id
) = E_Function
then
2800 if Has_Controlling_Result
(Subp_Id
) then
2803 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2805 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2809 Make_Function_Specification
(Loc
,
2810 Defining_Unit_Name
=> Wrapper_Id
,
2811 Parameter_Specifications
=> New_Formals
,
2812 Result_Definition
=> Res_Def
);
2816 Make_Procedure_Specification
(Loc
,
2817 Defining_Unit_Name
=> Wrapper_Id
,
2818 Parameter_Specifications
=> New_Formals
);
2821 end Build_Wrapper_Spec
;
2823 -------------------------
2824 -- Build_Wrapper_Specs --
2825 -------------------------
2827 procedure Build_Wrapper_Specs
2833 Rec_Typ
: Entity_Id
;
2834 procedure Scan_Declarations
(L
: List_Id
);
2835 -- Common processing for visible and private declarations
2836 -- of a protected type.
2838 procedure Scan_Declarations
(L
: List_Id
) is
2840 Wrap_Decl
: Node_Id
;
2841 Wrap_Spec
: Node_Id
;
2849 while Present
(Decl
) loop
2852 if Nkind
(Decl
) = N_Entry_Declaration
2853 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2857 (Subp_Id
=> Defining_Identifier
(Decl
),
2859 Formals
=> Parameter_Specifications
(Decl
));
2861 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2864 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2867 Parameter_Specifications
(Specification
(Decl
)));
2870 if Present
(Wrap_Spec
) then
2872 Make_Subprogram_Declaration
(Loc
,
2873 Specification
=> Wrap_Spec
);
2875 Insert_After
(N
, Wrap_Decl
);
2878 Analyze
(Wrap_Decl
);
2883 end Scan_Declarations
;
2885 -- start of processing for Build_Wrapper_Specs
2888 if Is_Protected_Type
(Typ
) then
2889 Def
:= Protected_Definition
(Parent
(Typ
));
2890 else pragma Assert
(Is_Task_Type
(Typ
));
2891 Def
:= Task_Definition
(Parent
(Typ
));
2894 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2896 -- Generate wrapper specs for a concurrent type which implements an
2897 -- interface. Operations in both the visible and private parts may
2898 -- implement progenitor operations.
2900 if Present
(Interfaces
(Rec_Typ
)) and then Present
(Def
) then
2901 Scan_Declarations
(Visible_Declarations
(Def
));
2902 Scan_Declarations
(Private_Declarations
(Def
));
2904 end Build_Wrapper_Specs
;
2906 ---------------------------
2907 -- Build_Find_Body_Index --
2908 ---------------------------
2910 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2911 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2914 Has_F
: Boolean := False;
2916 If_St
: Node_Id
:= Empty
;
2919 Decls
: List_Id
:= New_List
;
2922 Siz
: Node_Id
:= Empty
;
2924 procedure Add_If_Clause
(Expr
: Node_Id
);
2925 -- Add test for range of current entry
2927 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2928 -- If a bound of an entry is given by a discriminant, retrieve the
2929 -- actual value of the discriminant from the enclosing object.
2935 procedure Add_If_Clause
(Expr
: Node_Id
) is
2937 Stats
: constant List_Id
:=
2939 Make_Simple_Return_Statement
(Loc
,
2940 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2943 -- Index for current entry body
2947 -- Compute total length of entry queues so far
2955 Right_Opnd
=> Expr
);
2960 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2963 -- Map entry queue indexes in the range of the current family
2964 -- into the current index, that designates the entry body.
2968 Make_Implicit_If_Statement
(Typ
,
2970 Then_Statements
=> Stats
,
2971 Elsif_Parts
=> New_List
);
2975 Append_To
(Elsif_Parts
(If_St
),
2976 Make_Elsif_Part
(Loc
,
2978 Then_Statements
=> Stats
));
2982 ------------------------------
2983 -- Convert_Discriminant_Ref --
2984 ------------------------------
2986 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2990 if Is_Entity_Name
(Bound
)
2991 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2994 Make_Selected_Component
(Loc
,
2996 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2997 Make_Explicit_Dereference
(Loc
,
2998 Make_Identifier
(Loc
, Name_uObject
))),
2999 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
3000 Set_Etype
(B
, Etype
(Entity
(Bound
)));
3002 B
:= New_Copy_Tree
(Bound
);
3006 end Convert_Discriminant_Ref
;
3008 -- Start of processing for Build_Find_Body_Index
3011 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
3013 Ent
:= First_Entity
(Typ
);
3014 while Present
(Ent
) loop
3015 if Ekind
(Ent
) = E_Entry_Family
then
3025 -- If the protected type has no entry families, there is a one-one
3026 -- correspondence between entry queue and entry body.
3029 Make_Simple_Return_Statement
(Loc
,
3030 Expression
=> Make_Identifier
(Loc
, Name_uE
));
3033 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
3036 -- if E <= l1 then return 1;
3037 -- elsif E <= l1 + l2 then return 2;
3042 Ent
:= First_Entity
(Typ
);
3044 Add_Object_Pointer
(Loc
, Typ
, Decls
);
3046 while Present
(Ent
) loop
3047 if Ekind
(Ent
) = E_Entry
then
3048 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
3050 elsif Ekind
(Ent
) = E_Entry_Family
then
3051 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
3052 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
3053 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
3054 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
3063 Make_Simple_Return_Statement
(Loc
,
3064 Expression
=> Make_Integer_Literal
(Loc
, 1));
3066 elsif Nkind
(Ret
) = N_If_Statement
then
3068 -- Ranges are in increasing order, so last one doesn't need guard
3071 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
3074 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
3080 Make_Subprogram_Body
(Loc
,
3081 Specification
=> Spec
,
3082 Declarations
=> Decls
,
3083 Handled_Statement_Sequence
=>
3084 Make_Handled_Sequence_Of_Statements
(Loc
,
3085 Statements
=> New_List
(Ret
)));
3086 end Build_Find_Body_Index
;
3088 --------------------------------
3089 -- Build_Find_Body_Index_Spec --
3090 --------------------------------
3092 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
3093 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3094 Id
: constant Entity_Id
:=
3095 Make_Defining_Identifier
(Loc
,
3096 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
3097 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
3098 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
3102 Make_Function_Specification
(Loc
,
3103 Defining_Unit_Name
=> Id
,
3104 Parameter_Specifications
=> New_List
(
3105 Make_Parameter_Specification
(Loc
,
3106 Defining_Identifier
=> Parm1
,
3108 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3110 Make_Parameter_Specification
(Loc
,
3111 Defining_Identifier
=> Parm2
,
3113 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
3115 Result_Definition
=> New_Occurrence_Of
(
3116 RTE
(RE_Protected_Entry_Index
), Loc
));
3117 end Build_Find_Body_Index_Spec
;
3119 -----------------------------------------------
3120 -- Build_Lock_Free_Protected_Subprogram_Body --
3121 -----------------------------------------------
3123 function Build_Lock_Free_Protected_Subprogram_Body
3126 Unprot_Spec
: Node_Id
) return Node_Id
3128 Actuals
: constant List_Id
:= New_List
;
3129 Loc
: constant Source_Ptr
:= Sloc
(N
);
3130 Spec
: constant Node_Id
:= Specification
(N
);
3131 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
3133 Prot_Spec
: Node_Id
;
3137 -- Create the protected version of the body
3140 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
3142 -- Build the actual parameters which appear in the call to the
3143 -- unprotected version of the body.
3145 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
3146 while Present
(Formal
) loop
3148 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
3153 -- Function case, generate:
3154 -- return <Unprot_Func_Call>;
3156 if Nkind
(Spec
) = N_Function_Specification
then
3158 Make_Simple_Return_Statement
(Loc
,
3160 Make_Function_Call
(Loc
,
3162 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
3163 Parameter_Associations
=> Actuals
));
3165 -- Procedure case, call the unprotected version
3169 Make_Procedure_Call_Statement
(Loc
,
3171 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
3172 Parameter_Associations
=> Actuals
);
3176 Make_Subprogram_Body
(Loc
,
3177 Declarations
=> Empty_List
,
3178 Specification
=> Prot_Spec
,
3179 Handled_Statement_Sequence
=>
3180 Make_Handled_Sequence_Of_Statements
(Loc
,
3181 Statements
=> New_List
(Stmt
)));
3182 end Build_Lock_Free_Protected_Subprogram_Body
;
3184 -------------------------------------------------
3185 -- Build_Lock_Free_Unprotected_Subprogram_Body --
3186 -------------------------------------------------
3188 -- Procedures which meet the lock-free implementation requirements and
3189 -- reference a unique scalar component Comp are expanded in the following
3192 -- procedure P (...) is
3193 -- Expected_Comp : constant Comp_Type :=
3195 -- (System.Atomic_Primitives.Lock_Free_Read_N
3196 -- (_Object.Comp'Address));
3200 -- <original declarations before the object renaming declaration
3203 -- Desired_Comp : Comp_Type := Expected_Comp;
3204 -- Comp : Comp_Type renames Desired_Comp;
3206 -- <original delarations after the object renaming declaration
3210 -- <original statements>
3211 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3212 -- (_Object.Comp'Address,
3213 -- Interfaces.Unsigned_N (Expected_Comp),
3214 -- Interfaces.Unsigned_N (Desired_Comp));
3219 -- Each return and raise statement of P is transformed into an atomic
3222 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3223 -- (_Object.Comp'Address,
3224 -- Interfaces.Unsigned_N (Expected_Comp),
3225 -- Interfaces.Unsigned_N (Desired_Comp));
3227 -- <original statement>
3232 -- Functions which meet the lock-free implementation requirements and
3233 -- reference a unique scalar component Comp are expanded in the following
3236 -- function F (...) return ... is
3237 -- <original declarations before the object renaming declaration
3240 -- Expected_Comp : constant Comp_Type :=
3242 -- (System.Atomic_Primitives.Lock_Free_Read_N
3243 -- (_Object.Comp'Address));
3244 -- Comp : Comp_Type renames Expected_Comp;
3246 -- <original delarations after the object renaming declaration of
3250 -- <original statements>
3253 function Build_Lock_Free_Unprotected_Subprogram_Body
3255 Prot_Typ
: Node_Id
) return Node_Id
3257 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
3258 -- Subprograms which meet the lock-free implementation criteria are
3259 -- allowed to reference only one unique component. Return the prival
3260 -- of the said component.
3262 --------------------------
3263 -- Referenced_Component --
3264 --------------------------
3266 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
3269 Source_Comp
: Entity_Id
:= Empty
;
3272 -- Find the unique source component which N references in its
3275 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
3277 Element
: Lock_Free_Subprogram
renames
3278 Lock_Free_Subprogram_Table
.Table
(Index
);
3280 if Element
.Sub_Body
= N
then
3281 Source_Comp
:= Element
.Comp_Id
;
3287 if No
(Source_Comp
) then
3291 -- Find the prival which corresponds to the source component within
3292 -- the declarations of N.
3294 Decl
:= First
(Declarations
(N
));
3295 while Present
(Decl
) loop
3297 -- Privals appear as object renamings
3299 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
3300 Comp
:= Defining_Identifier
(Decl
);
3302 if Present
(Prival_Link
(Comp
))
3303 and then Prival_Link
(Comp
) = Source_Comp
3313 end Referenced_Component
;
3317 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
3318 Loc
: constant Source_Ptr
:= Sloc
(N
);
3319 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
3320 Decls
: List_Id
:= Declarations
(N
);
3322 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
3325 -- Add renamings for the protection object, discriminals, privals, and
3326 -- the entry index constant for use by debugger.
3328 Debug_Private_Data_Declarations
(Decls
);
3330 -- Perform the lock-free expansion when the subprogram references a
3331 -- protected component.
3333 if Present
(Comp
) then
3334 Protected_Component_Ref
: declare
3335 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3336 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
3337 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
3339 Is_Procedure
: constant Boolean :=
3340 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
3341 -- Indicates if N is a protected procedure body
3343 Block_Decls
: List_Id
;
3344 Try_Write
: Entity_Id
;
3345 Desired_Comp
: Entity_Id
;
3348 Label_Id
: Entity_Id
:= Empty
;
3350 Expected_Comp
: Entity_Id
;
3353 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
3355 Unsigned
: Entity_Id
;
3357 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
3358 -- Transform a single node if it is a return statement, a raise
3359 -- statement or a reference to Comp.
3361 procedure Process_Stmts
(Stmts
: List_Id
);
3362 -- Given a statement sequence Stmts, wrap any return or raise
3363 -- statements in the following manner:
3365 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3366 -- (_Object.Comp'Address,
3367 -- Interfaces.Unsigned_N (Expected_Comp),
3368 -- Interfaces.Unsigned_N (Desired_Comp))
3379 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3381 procedure Wrap_Statement
(Stmt
: Node_Id
);
3382 -- Wrap an arbitrary statement inside an if statement where the
3383 -- condition does an atomic check on the state of the object.
3385 --------------------
3386 -- Wrap_Statement --
3387 --------------------
3389 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3391 -- The first time through, create the declaration of a label
3392 -- which is used to skip the remainder of source statements
3393 -- if the state of the object has changed.
3395 if No
(Label_Id
) then
3397 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3398 Set_Entity
(Label_Id
,
3399 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3403 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3404 -- (_Object.Comp'Address,
3405 -- Interfaces.Unsigned_N (Expected_Comp),
3406 -- Interfaces.Unsigned_N (Desired_Comp))
3414 Make_Implicit_If_Statement
(N
,
3416 Make_Function_Call
(Loc
,
3418 New_Occurrence_Of
(Try_Write
, Loc
),
3419 Parameter_Associations
=> New_List
(
3420 Make_Attribute_Reference
(Loc
,
3421 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3422 Attribute_Name
=> Name_Address
),
3424 Unchecked_Convert_To
(Unsigned
,
3425 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3427 Unchecked_Convert_To
(Unsigned
,
3428 New_Occurrence_Of
(Desired_Comp
, Loc
)))),
3430 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3432 Else_Statements
=> New_List
(
3433 Make_Goto_Statement
(Loc
,
3435 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3438 -- Start of processing for Process_Node
3441 -- Wrap each return and raise statement that appear inside a
3442 -- procedure. Skip the last return statement which is added by
3443 -- default since it is transformed into an exit statement.
3446 and then ((Nkind
(N
) = N_Simple_Return_Statement
3447 and then N
/= Last
(Stmts
))
3448 or else Nkind
(N
) = N_Extended_Return_Statement
3449 or else (Nkind_In
(N
, N_Raise_Constraint_Error
,
3450 N_Raise_Program_Error
,
3452 N_Raise_Storage_Error
)
3453 and then Comes_From_Source
(N
)))
3461 Set_Analyzed
(N
, False);
3466 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3472 procedure Process_Stmts
(Stmts
: List_Id
) is
3475 Stmt
:= First
(Stmts
);
3476 while Present
(Stmt
) loop
3477 Process_Nodes
(Stmt
);
3482 -- Start of processing for Protected_Component_Ref
3485 -- Get the type size
3487 if Known_Static_Esize
(Comp_Type
) then
3488 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3490 -- If the Esize (Object_Size) is unknown at compile time, look at
3491 -- the RM_Size (Value_Size) since it may have been set by an
3492 -- explicit representation clause.
3494 elsif Known_Static_RM_Size
(Comp_Type
) then
3495 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3497 -- Should not happen since this has already been checked in
3498 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3501 raise Program_Error
;
3504 -- Retrieve all relevant atomic routines and types
3508 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3509 Read
:= RTE
(RE_Lock_Free_Read_8
);
3510 Unsigned
:= RTE
(RE_Uint8
);
3513 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3514 Read
:= RTE
(RE_Lock_Free_Read_16
);
3515 Unsigned
:= RTE
(RE_Uint16
);
3518 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3519 Read
:= RTE
(RE_Lock_Free_Read_32
);
3520 Unsigned
:= RTE
(RE_Uint32
);
3523 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3524 Read
:= RTE
(RE_Lock_Free_Read_64
);
3525 Unsigned
:= RTE
(RE_Uint64
);
3528 raise Program_Error
;
3532 -- Expected_Comp : constant Comp_Type :=
3534 -- (System.Atomic_Primitives.Lock_Free_Read_N
3535 -- (_Object.Comp'Address));
3538 Make_Defining_Identifier
(Loc
,
3539 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3542 Make_Object_Declaration
(Loc
,
3543 Defining_Identifier
=> Expected_Comp
,
3544 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3545 Constant_Present
=> True,
3547 Unchecked_Convert_To
(Comp_Type
,
3548 Make_Function_Call
(Loc
,
3549 Name
=> New_Occurrence_Of
(Read
, Loc
),
3550 Parameter_Associations
=> New_List
(
3551 Make_Attribute_Reference
(Loc
,
3552 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3553 Attribute_Name
=> Name_Address
)))));
3555 -- Protected procedures
3557 if Is_Procedure
then
3558 -- Move the original declarations inside the generated block
3560 Block_Decls
:= Decls
;
3562 -- Reset the declarations list of the protected procedure to
3563 -- contain only Decl.
3565 Decls
:= New_List
(Decl
);
3568 -- Desired_Comp : Comp_Type := Expected_Comp;
3571 Make_Defining_Identifier
(Loc
,
3572 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3574 -- Insert the declarations of Expected_Comp and Desired_Comp in
3575 -- the block declarations right before the renaming of the
3576 -- protected component.
3578 Insert_Before
(Comp_Decl
,
3579 Make_Object_Declaration
(Loc
,
3580 Defining_Identifier
=> Desired_Comp
,
3581 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3583 New_Occurrence_Of
(Expected_Comp
, Loc
)));
3585 -- Protected function
3588 Desired_Comp
:= Expected_Comp
;
3590 -- Insert the declaration of Expected_Comp in the function
3591 -- declarations right before the renaming of the protected
3594 Insert_Before
(Comp_Decl
, Decl
);
3597 -- Rewrite the protected component renaming declaration to be a
3598 -- renaming of Desired_Comp.
3601 -- Comp : Comp_Type renames Desired_Comp;
3604 Make_Object_Renaming_Declaration
(Loc
,
3605 Defining_Identifier
=>
3606 Defining_Identifier
(Comp_Decl
),
3608 New_Occurrence_Of
(Comp_Type
, Loc
),
3610 New_Occurrence_Of
(Desired_Comp
, Loc
)));
3612 -- Wrap any return or raise statements in Stmts in same the manner
3613 -- described in Process_Stmts.
3615 Process_Stmts
(Stmts
);
3618 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3619 -- (_Object.Comp'Address,
3620 -- Interfaces.Unsigned_N (Expected_Comp),
3621 -- Interfaces.Unsigned_N (Desired_Comp))
3623 if Is_Procedure
then
3625 Make_Exit_Statement
(Loc
,
3627 Make_Function_Call
(Loc
,
3629 New_Occurrence_Of
(Try_Write
, Loc
),
3630 Parameter_Associations
=> New_List
(
3631 Make_Attribute_Reference
(Loc
,
3632 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3633 Attribute_Name
=> Name_Address
),
3635 Unchecked_Convert_To
(Unsigned
,
3636 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3638 Unchecked_Convert_To
(Unsigned
,
3639 New_Occurrence_Of
(Desired_Comp
, Loc
)))));
3641 -- Small optimization: transform the default return statement
3642 -- of a procedure into the atomic exit statement.
3644 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3645 Rewrite
(Last
(Stmts
), Stmt
);
3647 Append_To
(Stmts
, Stmt
);
3651 -- Create the declaration of the label used to skip the rest of
3652 -- the source statements when the object state changes.
3654 if Present
(Label_Id
) then
3655 Label
:= Make_Label
(Loc
, Label_Id
);
3657 Make_Implicit_Label_Declaration
(Loc
,
3658 Defining_Identifier
=> Entity
(Label_Id
),
3659 Label_Construct
=> Label
));
3660 Append_To
(Stmts
, Label
);
3672 if Is_Procedure
then
3675 Make_Loop_Statement
(Loc
,
3676 Statements
=> New_List
(
3677 Make_Block_Statement
(Loc
,
3678 Declarations
=> Block_Decls
,
3679 Handled_Statement_Sequence
=>
3680 Make_Handled_Sequence_Of_Statements
(Loc
,
3681 Statements
=> Stmts
))),
3682 End_Label
=> Empty
));
3686 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3687 end Protected_Component_Ref
;
3690 -- Make an unprotected version of the subprogram for use within the same
3691 -- object, with new name and extra parameter representing the object.
3694 Make_Subprogram_Body
(Loc
,
3696 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3697 Declarations
=> Decls
,
3698 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3699 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3701 -------------------------
3702 -- Build_Master_Entity --
3703 -------------------------
3705 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3706 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3708 Context_Id
: Entity_Id
;
3714 if Is_Itype
(Obj_Or_Typ
) then
3715 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3717 Par
:= Parent
(Obj_Or_Typ
);
3720 -- When creating a master for a record component which is either a task
3721 -- or access-to-task, the enclosing record is the master scope and the
3722 -- proper insertion point is the component list.
3724 if Is_Record_Type
(Current_Scope
) then
3726 Context_Id
:= Current_Scope
;
3727 Decls
:= List_Containing
(Context
);
3729 -- Default case for object declarations and access types. Note that the
3730 -- context is updated to the nearest enclosing body, block, package, or
3731 -- return statement.
3734 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3737 -- Do not create a master if one already exists or there is no task
3740 if Has_Master_Entity
(Context_Id
)
3741 or else Restriction_Active
(No_Task_Hierarchy
)
3746 -- Create a master, generate:
3747 -- _Master : constant Master_Id := Current_Master.all;
3750 Make_Object_Declaration
(Loc
,
3751 Defining_Identifier
=>
3752 Make_Defining_Identifier
(Loc
, Name_uMaster
),
3753 Constant_Present
=> True,
3754 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3756 Make_Explicit_Dereference
(Loc
,
3757 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
3759 -- The master is inserted at the start of the declarative list of the
3762 Prepend_To
(Decls
, Decl
);
3764 -- In certain cases where transient scopes are involved, the immediate
3765 -- scope is not always the proper master scope. Ensure that the master
3766 -- declaration and entity appear in the same context.
3768 if Context_Id
/= Current_Scope
then
3769 Push_Scope
(Context_Id
);
3776 -- Mark the enclosing scope and its associated construct as being task
3779 Set_Has_Master_Entity
(Context_Id
);
3781 while Present
(Context
)
3782 and then Nkind
(Context
) /= N_Compilation_Unit
3784 if Nkind_In
(Context
, N_Block_Statement
,
3788 Set_Is_Task_Master
(Context
);
3791 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3792 Context
:= Corresponding_Stub
(Parent
(Context
));
3795 Context
:= Parent
(Context
);
3797 end Build_Master_Entity
;
3799 ---------------------------
3800 -- Build_Master_Renaming --
3801 ---------------------------
3803 procedure Build_Master_Renaming
3804 (Ptr_Typ
: Entity_Id
;
3805 Ins_Nod
: Node_Id
:= Empty
)
3807 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3809 Master_Decl
: Node_Id
;
3810 Master_Id
: Entity_Id
;
3813 -- Nothing to do if there is no task hierarchy
3815 if Restriction_Active
(No_Task_Hierarchy
) then
3819 -- Determine the proper context to insert the master renaming
3821 if Present
(Ins_Nod
) then
3823 elsif Is_Itype
(Ptr_Typ
) then
3824 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3826 Context
:= Parent
(Ptr_Typ
);
3830 -- <Ptr_Typ>M : Master_Id renames _Master;
3833 Make_Defining_Identifier
(Loc
,
3834 New_External_Name
(Chars
(Ptr_Typ
), 'M'));
3837 Make_Object_Renaming_Declaration
(Loc
,
3838 Defining_Identifier
=> Master_Id
,
3839 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3840 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3842 Insert_Action
(Context
, Master_Decl
);
3844 -- The renamed master now services the access type
3846 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3847 end Build_Master_Renaming
;
3849 -----------------------------------------
3850 -- Build_Private_Protected_Declaration --
3851 -----------------------------------------
3853 function Build_Private_Protected_Declaration
3854 (N
: Node_Id
) return Entity_Id
3856 Loc
: constant Source_Ptr
:= Sloc
(N
);
3857 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3862 Spec_Id
: Entity_Id
;
3865 Formal
:= First_Formal
(Body_Id
);
3867 -- The protected operation always has at least one formal, namely the
3868 -- object itself, but it is only placed in the parameter list if
3869 -- expansion is enabled.
3871 if Present
(Formal
) or else Expander_Active
then
3872 Plist
:= Copy_Parameter_List
(Body_Id
);
3877 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
3879 Make_Procedure_Specification
(Loc
,
3880 Defining_Unit_Name
=>
3881 Make_Defining_Identifier
(Sloc
(Body_Id
),
3882 Chars
=> Chars
(Body_Id
)),
3883 Parameter_Specifications
=>
3887 Make_Function_Specification
(Loc
,
3888 Defining_Unit_Name
=>
3889 Make_Defining_Identifier
(Sloc
(Body_Id
),
3890 Chars
=> Chars
(Body_Id
)),
3891 Parameter_Specifications
=> Plist
,
3892 Result_Definition
=>
3893 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
3896 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> New_Spec
);
3897 Insert_Before
(N
, Decl
);
3898 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
3900 -- Indicate that the entity comes from source, to ensure that cross-
3901 -- reference information is properly generated. The body itself is
3902 -- rewritten during expansion, and the body entity will not appear in
3903 -- calls to the operation.
3905 Set_Comes_From_Source
(Spec_Id
, True);
3907 Set_Has_Completion
(Spec_Id
);
3908 Set_Convention
(Spec_Id
, Convention_Protected
);
3910 end Build_Private_Protected_Declaration
;
3912 ---------------------------
3913 -- Build_Protected_Entry --
3914 ---------------------------
3916 function Build_Protected_Entry
3919 Pid
: Node_Id
) return Node_Id
3921 Bod_Decls
: constant List_Id
:= New_List
;
3922 Decls
: constant List_Id
:= Declarations
(N
);
3923 End_Lab
: constant Node_Id
:=
3924 End_Label
(Handled_Statement_Sequence
(N
));
3925 End_Loc
: constant Source_Ptr
:=
3926 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3927 -- Used for the generated call to Complete_Entry_Body
3929 Loc
: constant Source_Ptr
:= Sloc
(N
);
3933 Bod_Stmts
: List_Id
;
3937 EH_Loc
: Source_Ptr
;
3938 -- Used for the exception handler, inserted at end of the body
3941 -- Set the source location on the exception handler only when debugging
3942 -- the expanded code (see Make_Implicit_Exception_Handler).
3944 if Debug_Generated_Code
then
3947 -- Otherwise the inserted code should not be visible to the debugger
3950 EH_Loc
:= No_Location
;
3954 Make_Defining_Identifier
(Loc
,
3955 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3956 Bod_Spec
:= Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Empty
);
3958 -- Add the following declarations:
3960 -- type poVP is access poV;
3961 -- _object : poVP := poVP (_O);
3963 -- where _O is the formal parameter associated with the concurrent
3964 -- object. These declarations are needed for Complete_Entry_Body.
3966 Add_Object_Pointer
(Loc
, Pid
, Bod_Decls
);
3968 -- Add renamings for all formals, the Protection object, discriminals,
3969 -- privals and the entry index constant for use by debugger.
3971 Add_Formal_Renamings
(Bod_Spec
, Bod_Decls
, Ent
, Loc
);
3972 Debug_Private_Data_Declarations
(Decls
);
3974 -- Put the declarations and the statements from the entry
3978 Make_Block_Statement
(Loc
,
3979 Declarations
=> Decls
,
3980 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
)));
3982 case Corresponding_Runtime_Package
(Pid
) is
3983 when System_Tasking_Protected_Objects_Entries
=>
3984 Append_To
(Bod_Stmts
,
3985 Make_Procedure_Call_Statement
(End_Loc
,
3987 New_Occurrence_Of
(RTE
(RE_Complete_Entry_Body
), Loc
),
3988 Parameter_Associations
=> New_List
(
3989 Make_Attribute_Reference
(End_Loc
,
3991 Make_Selected_Component
(End_Loc
,
3993 Make_Identifier
(End_Loc
, Name_uObject
),
3995 Make_Identifier
(End_Loc
, Name_uObject
)),
3996 Attribute_Name
=> Name_Unchecked_Access
))));
3998 when System_Tasking_Protected_Objects_Single_Entry
=>
4000 -- Historically, a call to Complete_Single_Entry_Body was
4001 -- inserted, but it was a null procedure.
4006 raise Program_Error
;
4009 -- When exceptions can not be propagated, we never need to call
4010 -- Exception_Complete_Entry_Body.
4012 if No_Exception_Handlers_Set
then
4014 Make_Subprogram_Body
(Loc
,
4015 Specification
=> Bod_Spec
,
4016 Declarations
=> Bod_Decls
,
4017 Handled_Statement_Sequence
=>
4018 Make_Handled_Sequence_Of_Statements
(Loc
,
4019 Statements
=> Bod_Stmts
,
4020 End_Label
=> End_Lab
));
4023 Ohandle
:= Make_Others_Choice
(Loc
);
4024 Set_All_Others
(Ohandle
);
4026 case Corresponding_Runtime_Package
(Pid
) is
4027 when System_Tasking_Protected_Objects_Entries
=>
4030 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
4032 when System_Tasking_Protected_Objects_Single_Entry
=>
4035 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
4038 raise Program_Error
;
4041 -- Establish link between subprogram body entity and source entry
4043 Set_Corresponding_Protected_Entry
(Bod_Id
, Ent
);
4045 -- Create body of entry procedure. The renaming declarations are
4046 -- placed ahead of the block that contains the actual entry body.
4049 Make_Subprogram_Body
(Loc
,
4050 Specification
=> Bod_Spec
,
4051 Declarations
=> Bod_Decls
,
4052 Handled_Statement_Sequence
=>
4053 Make_Handled_Sequence_Of_Statements
(Loc
,
4054 Statements
=> Bod_Stmts
,
4055 End_Label
=> End_Lab
,
4056 Exception_Handlers
=> New_List
(
4057 Make_Implicit_Exception_Handler
(EH_Loc
,
4058 Exception_Choices
=> New_List
(Ohandle
),
4060 Statements
=> New_List
(
4061 Make_Procedure_Call_Statement
(EH_Loc
,
4063 Parameter_Associations
=> New_List
(
4064 Make_Attribute_Reference
(EH_Loc
,
4066 Make_Selected_Component
(EH_Loc
,
4068 Make_Identifier
(EH_Loc
, Name_uObject
),
4070 Make_Identifier
(EH_Loc
, Name_uObject
)),
4071 Attribute_Name
=> Name_Unchecked_Access
),
4073 Make_Function_Call
(EH_Loc
,
4076 (RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
4078 end Build_Protected_Entry
;
4080 -----------------------------------------
4081 -- Build_Protected_Entry_Specification --
4082 -----------------------------------------
4084 function Build_Protected_Entry_Specification
4087 Ent_Id
: Entity_Id
) return Node_Id
4089 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4092 Set_Debug_Info_Needed
(Def_Id
);
4094 if Present
(Ent_Id
) then
4095 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
4099 Make_Procedure_Specification
(Loc
,
4100 Defining_Unit_Name
=> Def_Id
,
4101 Parameter_Specifications
=> New_List
(
4102 Make_Parameter_Specification
(Loc
,
4103 Defining_Identifier
=>
4104 Make_Defining_Identifier
(Loc
, Name_uO
),
4106 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
4108 Make_Parameter_Specification
(Loc
,
4109 Defining_Identifier
=> P
,
4111 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
4113 Make_Parameter_Specification
(Loc
,
4114 Defining_Identifier
=>
4115 Make_Defining_Identifier
(Loc
, Name_uE
),
4117 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))));
4118 end Build_Protected_Entry_Specification
;
4120 --------------------------
4121 -- Build_Protected_Spec --
4122 --------------------------
4124 function Build_Protected_Spec
4126 Obj_Type
: Entity_Id
;
4128 Unprotected
: Boolean := False) return List_Id
4130 Loc
: constant Source_Ptr
:= Sloc
(N
);
4133 New_Plist
: List_Id
;
4134 New_Param
: Node_Id
;
4137 New_Plist
:= New_List
;
4139 Formal
:= First_Formal
(Ident
);
4140 while Present
(Formal
) loop
4142 Make_Parameter_Specification
(Loc
,
4143 Defining_Identifier
=>
4144 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
4145 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
4146 In_Present
=> In_Present
(Parent
(Formal
)),
4147 Out_Present
=> Out_Present
(Parent
(Formal
)),
4148 Parameter_Type
=> New_Occurrence_Of
(Etype
(Formal
), Loc
));
4151 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
4154 Append
(New_Param
, New_Plist
);
4155 Next_Formal
(Formal
);
4158 -- If the subprogram is a procedure and the context is not an access
4159 -- to protected subprogram, the parameter is in-out. Otherwise it is
4163 Make_Parameter_Specification
(Loc
,
4164 Defining_Identifier
=>
4165 Make_Defining_Identifier
(Loc
, Name_uObject
),
4168 (Etype
(Ident
) = Standard_Void_Type
4169 and then not Is_RTE
(Obj_Type
, RE_Address
)),
4171 New_Occurrence_Of
(Obj_Type
, Loc
));
4172 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
4173 Prepend_To
(New_Plist
, Decl
);
4176 end Build_Protected_Spec
;
4178 ---------------------------------------
4179 -- Build_Protected_Sub_Specification --
4180 ---------------------------------------
4182 function Build_Protected_Sub_Specification
4184 Prot_Typ
: Entity_Id
;
4185 Mode
: Subprogram_Protection_Mode
) return Node_Id
4187 Loc
: constant Source_Ptr
:= Sloc
(N
);
4191 New_Plist
: List_Id
;
4194 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
4195 (Dispatching_Mode
=> ' ',
4196 Protected_Mode
=> 'P',
4197 Unprotected_Mode
=> 'N');
4200 if Ekind
(Defining_Unit_Name
(Specification
(N
))) = E_Subprogram_Body
4202 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
4207 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
4210 Build_Protected_Spec
4211 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
4212 Mode
= Unprotected_Mode
);
4214 Make_Defining_Identifier
(Loc
,
4215 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
4217 -- Reference the original non-dispatching subprogram since the analysis
4218 -- of the object.operation notation may need its original name (see
4219 -- Sem_Ch4.Names_Match).
4221 if Mode
= Dispatching_Mode
then
4222 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
4223 Set_Original_Protected_Subprogram
(New_Id
, Def_Id
);
4226 -- The unprotected operation carries the user code, and debugging
4227 -- information must be generated for it, even though this spec does
4228 -- not come from source. It is also convenient to allow gdb to step
4229 -- into the protected operation, even though it only contains lock/
4232 Set_Debug_Info_Needed
(New_Id
);
4234 -- If a pragma Eliminate applies to the source entity, the internal
4235 -- subprograms will be eliminated as well.
4237 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
4239 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
4241 Make_Procedure_Specification
(Loc
,
4242 Defining_Unit_Name
=> New_Id
,
4243 Parameter_Specifications
=> New_Plist
);
4245 -- Create a new specification for the anonymous subprogram type
4249 Make_Function_Specification
(Loc
,
4250 Defining_Unit_Name
=> New_Id
,
4251 Parameter_Specifications
=> New_Plist
,
4252 Result_Definition
=>
4253 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
4255 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
4259 end Build_Protected_Sub_Specification
;
4261 -------------------------------------
4262 -- Build_Protected_Subprogram_Body --
4263 -------------------------------------
4265 function Build_Protected_Subprogram_Body
4268 N_Op_Spec
: Node_Id
) return Node_Id
4270 Loc
: constant Source_Ptr
:= Sloc
(N
);
4272 P_Op_Spec
: Node_Id
;
4275 Unprot_Call
: Node_Id
;
4277 Lock_Name
: Node_Id
;
4278 Lock_Stmt
: Node_Id
;
4280 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
4281 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
4283 Object_Parm
: Node_Id
;
4288 Op_Spec
:= Specification
(N
);
4289 Exc_Safe
:= Is_Exception_Safe
(N
);
4292 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
4294 -- Build a list of the formal parameters of the protected version of
4295 -- the subprogram to use as the actual parameters of the unprotected
4298 Uactuals
:= New_List
;
4299 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
4300 while Present
(Pformal
) loop
4301 Append_To
(Uactuals
,
4302 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
4306 -- Make a call to the unprotected version of the subprogram built above
4307 -- for use by the protected version built below.
4309 if Nkind
(Op_Spec
) = N_Function_Specification
then
4311 R
:= Make_Temporary
(Loc
, 'R');
4314 Make_Object_Declaration
(Loc
,
4315 Defining_Identifier
=> R
,
4316 Constant_Present
=> True,
4317 Object_Definition
=>
4318 New_Copy
(Result_Definition
(N_Op_Spec
)),
4320 Make_Function_Call
(Loc
,
4322 Make_Identifier
(Loc
,
4323 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4324 Parameter_Associations
=> Uactuals
));
4327 Make_Simple_Return_Statement
(Loc
,
4328 Expression
=> New_Occurrence_Of
(R
, Loc
));
4332 Make_Simple_Return_Statement
(Loc
,
4334 Make_Function_Call
(Loc
,
4336 Make_Identifier
(Loc
,
4337 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4338 Parameter_Associations
=> Uactuals
));
4341 Lock_Kind
:= RE_Lock_Read_Only
;
4345 Make_Procedure_Call_Statement
(Loc
,
4347 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4348 Parameter_Associations
=> Uactuals
);
4350 Lock_Kind
:= RE_Lock
;
4353 -- Wrap call in block that will be covered by an at_end handler
4355 if not Exc_Safe
then
4357 Make_Block_Statement
(Loc
,
4358 Handled_Statement_Sequence
=>
4359 Make_Handled_Sequence_Of_Statements
(Loc
,
4360 Statements
=> New_List
(Unprot_Call
)));
4363 -- Make the protected subprogram body. This locks the protected
4364 -- object and calls the unprotected version of the subprogram.
4366 case Corresponding_Runtime_Package
(Pid
) is
4367 when System_Tasking_Protected_Objects_Entries
=>
4368 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entries
), Loc
);
4370 when System_Tasking_Protected_Objects_Single_Entry
=>
4371 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entry
), Loc
);
4373 when System_Tasking_Protected_Objects
=>
4374 Lock_Name
:= New_Occurrence_Of
(RTE
(Lock_Kind
), Loc
);
4377 raise Program_Error
;
4381 Make_Attribute_Reference
(Loc
,
4383 Make_Selected_Component
(Loc
,
4384 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4385 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4386 Attribute_Name
=> Name_Unchecked_Access
);
4389 Make_Procedure_Call_Statement
(Loc
,
4391 Parameter_Associations
=> New_List
(Object_Parm
));
4393 if Abort_Allowed
then
4395 Build_Runtime_Call
(Loc
, RE_Abort_Defer
),
4399 Stmts
:= New_List
(Lock_Stmt
);
4402 if not Exc_Safe
then
4403 Append
(Unprot_Call
, Stmts
);
4405 if Nkind
(Op_Spec
) = N_Function_Specification
then
4407 Stmts
:= Empty_List
;
4409 Append
(Unprot_Call
, Stmts
);
4412 -- Historical note: Previously, call to the cleanup was inserted
4413 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4414 -- which is also shared by the 'not Exc_Safe' path.
4416 Build_Protected_Subprogram_Call_Cleanup
(Op_Spec
, Pid
, Loc
, Stmts
);
4418 if Nkind
(Op_Spec
) = N_Function_Specification
then
4419 Append_To
(Stmts
, Return_Stmt
);
4420 Append_To
(Pre_Stmts
,
4421 Make_Block_Statement
(Loc
,
4422 Declarations
=> New_List
(Unprot_Call
),
4423 Handled_Statement_Sequence
=>
4424 Make_Handled_Sequence_Of_Statements
(Loc
,
4425 Statements
=> Stmts
)));
4431 Make_Subprogram_Body
(Loc
,
4432 Declarations
=> Empty_List
,
4433 Specification
=> P_Op_Spec
,
4434 Handled_Statement_Sequence
=>
4435 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4437 -- Mark this subprogram as a protected subprogram body so that the
4438 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4439 -- path as otherwise the cleanup has already been inserted.
4441 if not Exc_Safe
then
4442 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4446 end Build_Protected_Subprogram_Body
;
4448 -------------------------------------
4449 -- Build_Protected_Subprogram_Call --
4450 -------------------------------------
4452 procedure Build_Protected_Subprogram_Call
4456 External
: Boolean := True)
4458 Loc
: constant Source_Ptr
:= Sloc
(N
);
4459 Sub
: constant Entity_Id
:= Entity
(Name
);
4465 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4468 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4471 if Present
(Parameter_Associations
(N
)) then
4472 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4477 -- If the type is an untagged derived type, convert to the root type,
4478 -- which is the one on which the operations are defined.
4480 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4481 and then not Is_Tagged_Type
(Etype
(Rec
))
4482 and then Is_Derived_Type
(Etype
(Rec
))
4484 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4485 Set_Subtype_Mark
(Rec
,
4486 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4489 Prepend
(Rec
, Params
);
4491 if Ekind
(Sub
) = E_Procedure
then
4493 Make_Procedure_Call_Statement
(Loc
,
4495 Parameter_Associations
=> Params
));
4498 pragma Assert
(Ekind
(Sub
) = E_Function
);
4500 Make_Function_Call
(Loc
,
4502 Parameter_Associations
=> Params
));
4504 -- Preserve type of call for subsequent processing (required for
4505 -- call to Wrap_Transient_Expression in the case of a shared passive
4508 Set_Etype
(N
, Etype
(New_Sub
));
4512 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
4513 and then Is_Entity_Name
(Expression
(Rec
))
4514 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
4516 Add_Shared_Var_Lock_Procs
(N
);
4518 end Build_Protected_Subprogram_Call
;
4520 ---------------------------------------------
4521 -- Build_Protected_Subprogram_Call_Cleanup --
4522 ---------------------------------------------
4524 procedure Build_Protected_Subprogram_Call_Cleanup
4533 -- If the associated protected object has entries, a protected
4534 -- procedure has to service entry queues. In this case generate:
4536 -- Service_Entries (_object._object'Access);
4538 if Nkind
(Op_Spec
) = N_Procedure_Specification
4539 and then Has_Entries
(Conc_Typ
)
4541 case Corresponding_Runtime_Package
(Conc_Typ
) is
4542 when System_Tasking_Protected_Objects_Entries
=>
4543 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entries
), Loc
);
4545 when System_Tasking_Protected_Objects_Single_Entry
=>
4546 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entry
), Loc
);
4549 raise Program_Error
;
4553 Make_Procedure_Call_Statement
(Loc
,
4555 Parameter_Associations
=> New_List
(
4556 Make_Attribute_Reference
(Loc
,
4558 Make_Selected_Component
(Loc
,
4559 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4560 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4561 Attribute_Name
=> Name_Unchecked_Access
))));
4565 -- Unlock (_object._object'Access);
4567 case Corresponding_Runtime_Package
(Conc_Typ
) is
4568 when System_Tasking_Protected_Objects_Entries
=>
4569 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entries
), Loc
);
4571 when System_Tasking_Protected_Objects_Single_Entry
=>
4572 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entry
), Loc
);
4574 when System_Tasking_Protected_Objects
=>
4575 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock
), Loc
);
4578 raise Program_Error
;
4582 Make_Procedure_Call_Statement
(Loc
,
4584 Parameter_Associations
=> New_List
(
4585 Make_Attribute_Reference
(Loc
,
4587 Make_Selected_Component
(Loc
,
4588 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4589 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4590 Attribute_Name
=> Name_Unchecked_Access
))));
4596 if Abort_Allowed
then
4597 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
4599 end Build_Protected_Subprogram_Call_Cleanup
;
4601 -------------------------
4602 -- Build_Selected_Name --
4603 -------------------------
4605 function Build_Selected_Name
4606 (Prefix
: Entity_Id
;
4607 Selector
: Entity_Id
;
4608 Append_Char
: Character := ' ') return Name_Id
4610 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4611 Select_Len
: Natural;
4614 Get_Name_String
(Chars
(Selector
));
4615 Select_Len
:= Name_Len
;
4616 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4617 Get_Name_String
(Chars
(Prefix
));
4619 -- If scope is anonymous type, discard suffix to recover name of
4620 -- single protected object. Otherwise use protected type name.
4622 if Name_Buffer
(Name_Len
) = 'T' then
4623 Name_Len
:= Name_Len
- 1;
4626 Add_Str_To_Name_Buffer
("__");
4627 for J
in 1 .. Select_Len
loop
4628 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4631 -- Now add the Append_Char if specified. The encoding to follow
4632 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4633 -- then the entity is associated to a protected type subprogram.
4634 -- Otherwise, it is a protected type entry. For each case, the
4635 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4637 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4639 if Append_Char
/= ' ' then
4640 if Append_Char
= 'P' or Append_Char
= 'N' then
4641 Add_Char_To_Name_Buffer
(Append_Char
);
4644 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4645 return New_External_Name
(Name_Find
, ' ', -1);
4650 end Build_Selected_Name
;
4652 -----------------------------
4653 -- Build_Simple_Entry_Call --
4654 -----------------------------
4656 -- A task entry call is converted to a call to Call_Simple
4659 -- P : parms := (parm, parm, parm);
4661 -- Call_Simple (acceptor-task, entry-index, P'Address);
4667 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4668 -- the parameters, and the constructed aggregate value contains either the
4669 -- parameters or, in the case of non-elementary types, references to these
4670 -- parameters. Then the address of this aggregate is passed to the runtime
4671 -- routine, along with the task id value and the task entry index value.
4672 -- Pnn is only required if parameters are present.
4674 -- The assignments after the call are present only in the case of in-out
4675 -- or out parameters for elementary types, and are used to assign back the
4676 -- resulting values of such parameters.
4678 -- Note: the reason that we insert a block here is that in the context
4679 -- of selects, conditional entry calls etc. the entry call statement
4680 -- appears on its own, not as an element of a list.
4682 -- A protected entry call is converted to a Protected_Entry_Call:
4685 -- P : E1_Params := (param, param, param);
4687 -- Bnn : Communications_Block;
4690 -- P : E1_Params := (param, param, param);
4691 -- Bnn : Communications_Block;
4694 -- Protected_Entry_Call (
4695 -- Object => po._object'Access,
4696 -- E => <entry index>;
4697 -- Uninterpreted_Data => P'Address;
4698 -- Mode => Simple_Call;
4705 procedure Build_Simple_Entry_Call
4714 -- If call has been inlined, nothing left to do
4716 if Nkind
(N
) = N_Block_Statement
then
4720 -- Convert entry call to Call_Simple call
4723 Loc
: constant Source_Ptr
:= Sloc
(N
);
4724 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4725 Stats
: constant List_Id
:= New_List
;
4728 Comm_Name
: Entity_Id
;
4732 Ent_Acc
: Entity_Id
;
4734 Iface_Tag
: Entity_Id
;
4735 Iface_Typ
: Entity_Id
;
4748 -- Simple entry and entry family cases merge here
4750 Ent
:= Entity
(Ename
);
4751 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4752 Conctyp
:= Etype
(Concval
);
4754 -- If prefix is an access type, dereference to obtain the task type
4756 if Is_Access_Type
(Conctyp
) then
4757 Conctyp
:= Designated_Type
(Conctyp
);
4760 -- Special case for protected subprogram calls
4762 if Is_Protected_Type
(Conctyp
)
4763 and then Is_Subprogram
(Entity
(Ename
))
4765 if not Is_Eliminated
(Entity
(Ename
)) then
4766 Build_Protected_Subprogram_Call
4767 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4774 -- First parameter is the Task_Id value from the task value or the
4775 -- Object from the protected object value, obtained by selecting
4776 -- the _Task_Id or _Object from the result of doing an unchecked
4777 -- conversion to convert the value to the corresponding record type.
4779 if Nkind
(Concval
) = N_Function_Call
4780 and then Is_Task_Type
(Conctyp
)
4781 and then Ada_Version
>= Ada_2005
4784 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4785 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4790 Make_Object_Declaration
(Loc
,
4791 Defining_Identifier
=> Obj
,
4792 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4793 Expression
=> ExpR
);
4794 Set_Etype
(Obj
, Conctyp
);
4795 Decls
:= New_List
(Decl
);
4796 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4803 Parm1
:= Concurrent_Ref
(Concval
);
4805 -- Second parameter is the entry index, computed by the routine
4806 -- provided for this purpose. The value of this expression is
4807 -- assigned to an intermediate variable to assure that any entry
4808 -- family index expressions are evaluated before the entry
4811 if not Is_Protected_Type
(Conctyp
)
4813 Corresponding_Runtime_Package
(Conctyp
) =
4814 System_Tasking_Protected_Objects_Entries
4816 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4819 Make_Object_Declaration
(Loc
,
4820 Defining_Identifier
=> X
,
4821 Object_Definition
=>
4822 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
4823 Expression
=> Actual_Index_Expression
(
4824 Loc
, Entity
(Ename
), Index
, Concval
));
4826 Append_To
(Decls
, Xdecl
);
4827 Parm2
:= New_Occurrence_Of
(X
, Loc
);
4834 -- The third parameter is the packaged parameters. If there are
4835 -- none, then it is just the null address, since nothing is passed.
4838 Parm3
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
4841 -- Case of parameters present, where third argument is the address
4842 -- of a packaged record containing the required parameter values.
4845 -- First build a list of parameter values, which are references to
4846 -- objects of the parameter types.
4850 Actual
:= First_Actual
(N
);
4851 Formal
:= First_Formal
(Ent
);
4852 while Present
(Actual
) loop
4854 -- If it is a by-copy type, copy it to a new variable. The
4855 -- packaged record has a field that points to this variable.
4857 if Is_By_Copy_Type
(Etype
(Actual
)) then
4859 Make_Object_Declaration
(Loc
,
4860 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4861 Aliased_Present
=> True,
4862 Object_Definition
=>
4863 New_Occurrence_Of
(Etype
(Formal
), Loc
));
4865 -- Mark the object as not needing initialization since the
4866 -- initialization is performed separately, avoiding errors
4867 -- on cases such as formals of null-excluding access types.
4869 Set_No_Initialization
(N_Node
);
4871 -- We must make a separate assignment statement for the
4872 -- case of limited types. We cannot assign it unless the
4873 -- Assignment_OK flag is set first. An out formal of an
4874 -- access type or whose type has a Default_Value must also
4875 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4876 -- but no constraint, predicate, or null-exclusion check is
4877 -- applied before the call.
4879 if Ekind
(Formal
) /= E_Out_Parameter
4880 or else Is_Access_Type
(Etype
(Formal
))
4882 (Is_Scalar_Type
(Etype
(Formal
))
4884 Present
(Default_Aspect_Value
(Etype
(Formal
))))
4887 New_Occurrence_Of
(Defining_Identifier
(N_Node
), Loc
);
4888 Set_Assignment_OK
(N_Var
);
4890 Make_Assignment_Statement
(Loc
,
4892 Expression
=> Relocate_Node
(Actual
)));
4894 -- Mark the object as internal, so we don't later reset
4895 -- No_Initialization flag in Default_Initialize_Object,
4896 -- which would lead to needless default initialization.
4897 -- We don't set this outside the if statement, because
4898 -- out scalar parameters without Default_Value do require
4899 -- default initialization if Initialize_Scalars applies.
4901 Set_Is_Internal
(Defining_Identifier
(N_Node
));
4903 -- If actual is an out parameter of a null-excluding
4904 -- access type, there is access check on entry, so set
4905 -- Suppress_Assignment_Checks on the generated statement
4906 -- that assigns the actual to the parameter block
4908 Set_Suppress_Assignment_Checks
(Last
(Stats
));
4911 Append
(N_Node
, Decls
);
4914 Make_Attribute_Reference
(Loc
,
4915 Attribute_Name
=> Name_Unchecked_Access
,
4918 (Defining_Identifier
(N_Node
), Loc
)));
4921 -- Interface class-wide formal
4923 if Ada_Version
>= Ada_2005
4924 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4925 and then Is_Interface
(Etype
(Formal
))
4927 Iface_Typ
:= Etype
(Etype
(Formal
));
4930 -- formal_iface_type! (actual.iface_tag)'reference
4933 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4934 pragma Assert
(Present
(Iface_Tag
));
4937 Make_Reference
(Loc
,
4938 Unchecked_Convert_To
(Iface_Typ
,
4939 Make_Selected_Component
(Loc
,
4941 Relocate_Node
(Actual
),
4943 New_Occurrence_Of
(Iface_Tag
, Loc
)))));
4949 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4953 Next_Actual
(Actual
);
4954 Next_Formal_With_Extras
(Formal
);
4957 -- Now build the declaration of parameters initialized with the
4958 -- aggregate containing this constructed parameter list.
4960 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4963 Make_Object_Declaration
(Loc
,
4964 Defining_Identifier
=> P
,
4965 Object_Definition
=>
4966 New_Occurrence_Of
(Designated_Type
(Ent_Acc
), Loc
),
4968 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4971 Make_Attribute_Reference
(Loc
,
4972 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4973 Attribute_Name
=> Name_Address
);
4975 Append
(Pdecl
, Decls
);
4978 -- Now we can create the call, case of protected type
4980 if Is_Protected_Type
(Conctyp
) then
4981 case Corresponding_Runtime_Package
(Conctyp
) is
4982 when System_Tasking_Protected_Objects_Entries
=>
4984 -- Change the type of the index declaration
4986 Set_Object_Definition
(Xdecl
,
4987 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
));
4989 -- Some additional declarations for protected entry calls
4995 -- Bnn : Communications_Block;
4997 Comm_Name
:= Make_Temporary
(Loc
, 'B');
5000 Make_Object_Declaration
(Loc
,
5001 Defining_Identifier
=> Comm_Name
,
5002 Object_Definition
=>
5004 (RTE
(RE_Communication_Block
), Loc
)));
5006 -- Some additional statements for protected entry calls
5008 -- Protected_Entry_Call (
5009 -- Object => po._object'Access,
5010 -- E => <entry index>;
5011 -- Uninterpreted_Data => P'Address;
5012 -- Mode => Simple_Call;
5016 Make_Procedure_Call_Statement
(Loc
,
5018 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
5020 Parameter_Associations
=> New_List
(
5021 Make_Attribute_Reference
(Loc
,
5022 Attribute_Name
=> Name_Unchecked_Access
,
5026 New_Occurrence_Of
(RTE
(RE_Simple_Call
), Loc
),
5027 New_Occurrence_Of
(Comm_Name
, Loc
)));
5029 when System_Tasking_Protected_Objects_Single_Entry
=>
5030 -- Protected_Single_Entry_Call (
5031 -- Object => po._object'Access,
5032 -- Uninterpreted_Data => P'Address);
5035 Make_Procedure_Call_Statement
(Loc
,
5038 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
5040 Parameter_Associations
=> New_List
(
5041 Make_Attribute_Reference
(Loc
,
5042 Attribute_Name
=> Name_Unchecked_Access
,
5047 raise Program_Error
;
5050 -- Case of task type
5054 Make_Procedure_Call_Statement
(Loc
,
5056 New_Occurrence_Of
(RTE
(RE_Call_Simple
), Loc
),
5057 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
5061 Append_To
(Stats
, Call
);
5063 -- If there are out or in/out parameters by copy add assignment
5064 -- statements for the result values.
5066 if Present
(Parms
) then
5067 Actual
:= First_Actual
(N
);
5068 Formal
:= First_Formal
(Ent
);
5070 Set_Assignment_OK
(Actual
);
5071 while Present
(Actual
) loop
5072 if Is_By_Copy_Type
(Etype
(Actual
))
5073 and then Ekind
(Formal
) /= E_In_Parameter
5076 Make_Assignment_Statement
(Loc
,
5077 Name
=> New_Copy
(Actual
),
5079 Make_Explicit_Dereference
(Loc
,
5080 Make_Selected_Component
(Loc
,
5081 Prefix
=> New_Occurrence_Of
(P
, Loc
),
5083 Make_Identifier
(Loc
, Chars
(Formal
)))));
5085 -- In all cases (including limited private types) we want
5086 -- the assignment to be valid.
5088 Set_Assignment_OK
(Name
(N_Node
));
5090 -- If the call is the triggering alternative in an
5091 -- asynchronous select, or the entry_call alternative of a
5092 -- conditional entry call, the assignments for in-out
5093 -- parameters are incorporated into the statement list that
5094 -- follows, so that there are executed only if the entry
5097 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
5098 and then N
= Triggering_Statement
(Parent
(N
)))
5100 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
5101 and then N
= Entry_Call_Statement
(Parent
(N
)))
5103 if No
(Statements
(Parent
(N
))) then
5104 Set_Statements
(Parent
(N
), New_List
);
5107 Prepend
(N_Node
, Statements
(Parent
(N
)));
5110 Insert_After
(Call
, N_Node
);
5114 Next_Actual
(Actual
);
5115 Next_Formal_With_Extras
(Formal
);
5119 -- Finally, create block and analyze it
5122 Make_Block_Statement
(Loc
,
5123 Declarations
=> Decls
,
5124 Handled_Statement_Sequence
=>
5125 Make_Handled_Sequence_Of_Statements
(Loc
,
5126 Statements
=> Stats
)));
5130 end Build_Simple_Entry_Call
;
5132 --------------------------------
5133 -- Build_Task_Activation_Call --
5134 --------------------------------
5136 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
5137 Loc
: constant Source_Ptr
:= Sloc
(N
);
5144 -- For sequential elaboration policy, all the tasks will be activated at
5145 -- the end of the elaboration.
5147 if Partition_Elaboration_Policy
= 'S' then
5151 -- Get the activation chain entity. Except in the case of a package
5152 -- body, this is in the node that was passed. For a package body, we
5153 -- have to find the corresponding package declaration node.
5155 if Nkind
(N
) = N_Package_Body
then
5156 P
:= Corresponding_Spec
(N
);
5159 exit when Nkind
(P
) = N_Package_Declaration
;
5162 Chain
:= Activation_Chain_Entity
(P
);
5165 Chain
:= Activation_Chain_Entity
(N
);
5168 if Present
(Chain
) then
5169 if Restricted_Profile
then
5170 Name
:= New_Occurrence_Of
5171 (RTE
(RE_Activate_Restricted_Tasks
), Loc
);
5173 Name
:= New_Occurrence_Of
5174 (RTE
(RE_Activate_Tasks
), Loc
);
5178 Make_Procedure_Call_Statement
(Loc
,
5180 Parameter_Associations
=>
5181 New_List
(Make_Attribute_Reference
(Loc
,
5182 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5183 Attribute_Name
=> Name_Unchecked_Access
)));
5185 if Nkind
(N
) = N_Package_Declaration
then
5186 if Present
(Corresponding_Body
(N
)) then
5189 elsif Present
(Private_Declarations
(Specification
(N
))) then
5190 Append
(Call
, Private_Declarations
(Specification
(N
)));
5193 Append
(Call
, Visible_Declarations
(Specification
(N
)));
5197 if Present
(Handled_Statement_Sequence
(N
)) then
5199 -- The call goes at the start of the statement sequence after
5200 -- the start of exception range label if one is present.
5206 Stm
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
5208 -- A special case, skip exception range label if one is
5209 -- present (from front end zcx processing).
5211 if Nkind
(Stm
) = N_Label
and then Exception_Junk
(Stm
) then
5215 -- Another special case, if the first statement is a block
5216 -- from optimization of a local raise to a goto, then the
5217 -- call goes inside this block.
5219 if Nkind
(Stm
) = N_Block_Statement
5220 and then Exception_Junk
(Stm
)
5223 First
(Statements
(Handled_Statement_Sequence
(Stm
)));
5226 -- Insertion point is after any exception label pushes,
5227 -- since we want it covered by any local handlers.
5229 while Nkind
(Stm
) in N_Push_xxx_Label
loop
5233 -- Now we have the proper insertion point
5235 Insert_Before
(Stm
, Call
);
5239 Set_Handled_Statement_Sequence
(N
,
5240 Make_Handled_Sequence_Of_Statements
(Loc
,
5241 Statements
=> New_List
(Call
)));
5246 Check_Task_Activation
(N
);
5248 end Build_Task_Activation_Call
;
5250 -------------------------------
5251 -- Build_Task_Allocate_Block --
5252 -------------------------------
5254 procedure Build_Task_Allocate_Block
5259 T
: constant Entity_Id
:= Entity
(Expression
(N
));
5260 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
5261 Loc
: constant Source_Ptr
:= Sloc
(N
);
5262 Chain
: constant Entity_Id
:=
5263 Make_Defining_Identifier
(Loc
, Name_uChain
);
5264 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5269 Make_Block_Statement
(Loc
,
5270 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5271 Declarations
=> New_List
(
5273 -- _Chain : Activation_Chain;
5275 Make_Object_Declaration
(Loc
,
5276 Defining_Identifier
=> Chain
,
5277 Aliased_Present
=> True,
5278 Object_Definition
=>
5279 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5281 Handled_Statement_Sequence
=>
5282 Make_Handled_Sequence_Of_Statements
(Loc
,
5284 Statements
=> New_List
(
5288 Make_Procedure_Call_Statement
(Loc
,
5289 Name
=> New_Occurrence_Of
(Init
, Loc
),
5290 Parameter_Associations
=> Args
),
5292 -- Activate_Tasks (_Chain);
5294 Make_Procedure_Call_Statement
(Loc
,
5295 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5296 Parameter_Associations
=> New_List
(
5297 Make_Attribute_Reference
(Loc
,
5298 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5299 Attribute_Name
=> Name_Unchecked_Access
))))),
5301 Has_Created_Identifier
=> True,
5302 Is_Task_Allocation_Block
=> True);
5305 Make_Implicit_Label_Declaration
(Loc
,
5306 Defining_Identifier
=> Blkent
,
5307 Label_Construct
=> Block
));
5309 Append_To
(Actions
, Block
);
5311 Set_Activation_Chain_Entity
(Block
, Chain
);
5312 end Build_Task_Allocate_Block
;
5314 -----------------------------------------------
5315 -- Build_Task_Allocate_Block_With_Init_Stmts --
5316 -----------------------------------------------
5318 procedure Build_Task_Allocate_Block_With_Init_Stmts
5321 Init_Stmts
: List_Id
)
5323 Loc
: constant Source_Ptr
:= Sloc
(N
);
5324 Chain
: constant Entity_Id
:=
5325 Make_Defining_Identifier
(Loc
, Name_uChain
);
5326 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5330 Append_To
(Init_Stmts
,
5331 Make_Procedure_Call_Statement
(Loc
,
5332 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5333 Parameter_Associations
=> New_List
(
5334 Make_Attribute_Reference
(Loc
,
5335 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5336 Attribute_Name
=> Name_Unchecked_Access
))));
5339 Make_Block_Statement
(Loc
,
5340 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5341 Declarations
=> New_List
(
5343 -- _Chain : Activation_Chain;
5345 Make_Object_Declaration
(Loc
,
5346 Defining_Identifier
=> Chain
,
5347 Aliased_Present
=> True,
5348 Object_Definition
=>
5349 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5351 Handled_Statement_Sequence
=>
5352 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5354 Has_Created_Identifier
=> True,
5355 Is_Task_Allocation_Block
=> True);
5358 Make_Implicit_Label_Declaration
(Loc
,
5359 Defining_Identifier
=> Blkent
,
5360 Label_Construct
=> Block
));
5362 Append_To
(Actions
, Block
);
5364 Set_Activation_Chain_Entity
(Block
, Chain
);
5365 end Build_Task_Allocate_Block_With_Init_Stmts
;
5367 -----------------------------------
5368 -- Build_Task_Proc_Specification --
5369 -----------------------------------
5371 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5372 Loc
: constant Source_Ptr
:= Sloc
(T
);
5373 Spec_Id
: Entity_Id
;
5376 -- Case of explicit task type, suffix TB
5378 if Comes_From_Source
(T
) then
5380 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), "TB"));
5382 -- Case of anonymous task type, suffix B
5386 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), 'B'));
5389 Set_Is_Internal
(Spec_Id
);
5391 -- Associate the procedure with the task, if this is the declaration
5392 -- (and not the body) of the procedure.
5394 if No
(Task_Body_Procedure
(T
)) then
5395 Set_Task_Body_Procedure
(T
, Spec_Id
);
5399 Make_Procedure_Specification
(Loc
,
5400 Defining_Unit_Name
=> Spec_Id
,
5401 Parameter_Specifications
=> New_List
(
5402 Make_Parameter_Specification
(Loc
,
5403 Defining_Identifier
=>
5404 Make_Defining_Identifier
(Loc
, Name_uTask
),
5406 Make_Access_Definition
(Loc
,
5408 New_Occurrence_Of
(Corresponding_Record_Type
(T
), Loc
)))));
5409 end Build_Task_Proc_Specification
;
5411 ---------------------------------------
5412 -- Build_Unprotected_Subprogram_Body --
5413 ---------------------------------------
5415 function Build_Unprotected_Subprogram_Body
5417 Pid
: Node_Id
) return Node_Id
5419 Decls
: constant List_Id
:= Declarations
(N
);
5422 -- Add renamings for the Protection object, discriminals, privals, and
5423 -- the entry index constant for use by debugger.
5425 Debug_Private_Data_Declarations
(Decls
);
5427 -- Make an unprotected version of the subprogram for use within the same
5428 -- object, with a new name and an additional parameter representing the
5432 Make_Subprogram_Body
(Sloc
(N
),
5434 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5435 Declarations
=> Decls
,
5436 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5437 end Build_Unprotected_Subprogram_Body
;
5439 ----------------------------
5440 -- Collect_Entry_Families --
5441 ----------------------------
5443 procedure Collect_Entry_Families
5446 Current_Node
: in out Node_Id
;
5447 Conctyp
: Entity_Id
)
5450 Efam_Decl
: Node_Id
;
5451 Efam_Type
: Entity_Id
;
5454 Efam
:= First_Entity
(Conctyp
);
5455 while Present
(Efam
) loop
5456 if Ekind
(Efam
) = E_Entry_Family
then
5457 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5462 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
5464 Bas_Decl
: Node_Id
:= Empty
;
5469 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
5471 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
5472 Bas
:= Make_Temporary
(Loc
, 'B');
5475 Make_Subtype_Declaration
(Loc
,
5476 Defining_Identifier
=> Bas
,
5477 Subtype_Indication
=>
5478 Make_Subtype_Indication
(Loc
,
5480 New_Occurrence_Of
(Standard_Integer
, Loc
),
5482 Make_Range_Constraint
(Loc
,
5483 Range_Expression
=> Make_Range
(Loc
,
5484 Make_Integer_Literal
5485 (Loc
, -Entry_Family_Bound
),
5486 Make_Integer_Literal
5487 (Loc
, Entry_Family_Bound
- 1)))));
5489 Insert_After
(Current_Node
, Bas_Decl
);
5490 Current_Node
:= Bas_Decl
;
5495 Make_Full_Type_Declaration
(Loc
,
5496 Defining_Identifier
=> Efam_Type
,
5498 Make_Unconstrained_Array_Definition
(Loc
,
5500 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
5502 Component_Definition
=>
5503 Make_Component_Definition
(Loc
,
5504 Aliased_Present
=> False,
5505 Subtype_Indication
=>
5506 New_Occurrence_Of
(Standard_Character
, Loc
))));
5509 Insert_After
(Current_Node
, Efam_Decl
);
5510 Current_Node
:= Efam_Decl
;
5511 Analyze
(Efam_Decl
);
5514 Make_Component_Declaration
(Loc
,
5515 Defining_Identifier
=>
5516 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5518 Component_Definition
=>
5519 Make_Component_Definition
(Loc
,
5520 Aliased_Present
=> False,
5521 Subtype_Indication
=>
5522 Make_Subtype_Indication
(Loc
,
5524 New_Occurrence_Of
(Efam_Type
, Loc
),
5527 Make_Index_Or_Discriminant_Constraint
(Loc
,
5528 Constraints
=> New_List
(
5530 (Etype
(Discrete_Subtype_Definition
5531 (Parent
(Efam
))), Loc
)))))));
5537 end Collect_Entry_Families
;
5539 -----------------------
5540 -- Concurrent_Object --
5541 -----------------------
5543 function Concurrent_Object
5544 (Spec_Id
: Entity_Id
;
5545 Conc_Typ
: Entity_Id
) return Entity_Id
5548 -- Parameter _O or _object
5550 if Is_Protected_Type
(Conc_Typ
) then
5551 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5556 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5557 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5559 end Concurrent_Object
;
5561 ----------------------
5562 -- Copy_Result_Type --
5563 ----------------------
5565 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5566 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5571 -- If the result type is an access_to_subprogram, we must create new
5572 -- entities for its spec.
5574 if Nkind
(New_Res
) = N_Access_Definition
5575 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5577 -- Provide new entities for the formals
5579 Par_Spec
:= First
(Parameter_Specifications
5580 (Access_To_Subprogram_Definition
(New_Res
)));
5581 while Present
(Par_Spec
) loop
5582 Formal
:= Defining_Identifier
(Par_Spec
);
5583 Set_Defining_Identifier
(Par_Spec
,
5584 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5590 end Copy_Result_Type
;
5592 --------------------
5593 -- Concurrent_Ref --
5594 --------------------
5596 -- The expression returned for a reference to a concurrent object has the
5599 -- taskV!(name)._Task_Id
5603 -- objectV!(name)._Object
5605 -- for a protected object. For the case of an access to a concurrent
5606 -- object, there is an extra explicit dereference:
5608 -- taskV!(name.all)._Task_Id
5609 -- objectV!(name.all)._Object
5611 -- here taskV and objectV are the types for the associated records, which
5612 -- contain the required _Task_Id and _Object fields for tasks and protected
5613 -- objects, respectively.
5615 -- For the case of a task type name, the expression is
5619 -- i.e. a call to the Self function which returns precisely this Task_Id
5621 -- For the case of a protected type name, the expression is
5625 -- which is a renaming of the _object field of the current object
5626 -- record, passed into protected operations as a parameter.
5628 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5629 Loc
: constant Source_Ptr
:= Sloc
(N
);
5630 Ntyp
: constant Entity_Id
:= Etype
(N
);
5634 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5635 -- Check whether the reference is to the immediately enclosing task
5636 -- type, or to an outer one (rare but legal).
5638 ---------------------
5639 -- Is_Current_Task --
5640 ---------------------
5642 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5646 Scop
:= Current_Scope
;
5647 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
5651 elsif Is_Task_Type
(Scop
) then
5654 -- If this is a procedure nested within the task type, we must
5655 -- assume that it can be called from an inner task, and therefore
5656 -- cannot treat it as a local reference.
5658 elsif Is_Overloadable
(Scop
) and then In_Open_Scopes
(T
) then
5662 Scop
:= Scope
(Scop
);
5666 -- We know that we are within the task body, so should have found it
5669 raise Program_Error
;
5670 end Is_Current_Task
;
5672 -- Start of processing for Concurrent_Ref
5675 if Is_Access_Type
(Ntyp
) then
5676 Dtyp
:= Designated_Type
(Ntyp
);
5678 if Is_Protected_Type
(Dtyp
) then
5679 Sel
:= Name_uObject
;
5681 Sel
:= Name_uTask_Id
;
5685 Make_Selected_Component
(Loc
,
5687 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5688 Make_Explicit_Dereference
(Loc
, N
)),
5689 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5691 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5692 if Is_Task_Type
(Entity
(N
)) then
5694 if Is_Current_Task
(Entity
(N
)) then
5696 Make_Function_Call
(Loc
,
5697 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
));
5702 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5703 T_Body
: constant Node_Id
:=
5704 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5708 Make_Object_Declaration
(Loc
,
5709 Defining_Identifier
=> T_Self
,
5710 Object_Definition
=>
5711 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5713 Make_Function_Call
(Loc
,
5714 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
)));
5715 Prepend
(Decl
, Declarations
(T_Body
));
5717 Set_Scope
(T_Self
, Entity
(N
));
5718 return New_Occurrence_Of
(T_Self
, Loc
);
5723 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5726 New_Occurrence_Of
(Find_Protection_Object
(Current_Scope
), Loc
);
5730 if Is_Protected_Type
(Ntyp
) then
5731 Sel
:= Name_uObject
;
5732 elsif Is_Task_Type
(Ntyp
) then
5733 Sel
:= Name_uTask_Id
;
5735 raise Program_Error
;
5739 Make_Selected_Component
(Loc
,
5741 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5743 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5747 ------------------------
5748 -- Convert_Concurrent --
5749 ------------------------
5751 function Convert_Concurrent
5753 Typ
: Entity_Id
) return Node_Id
5756 if not Is_Concurrent_Type
(Typ
) then
5760 Unchecked_Convert_To
5761 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5763 end Convert_Concurrent
;
5765 -------------------------------------
5766 -- Debug_Private_Data_Declarations --
5767 -------------------------------------
5769 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5770 Debug_Nod
: Node_Id
;
5774 Decl
:= First
(Decls
);
5775 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5777 -- Declaration for concurrent entity _object and its access type,
5778 -- along with the entry index subtype:
5779 -- type prot_typVP is access prot_typV;
5780 -- _object : prot_typVP := prot_typV (_O);
5781 -- subtype Jnn is <Type of Index> range Low .. High;
5783 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
5784 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5786 -- Declaration for the Protection object, discriminals, privals, and
5787 -- entry index constant:
5788 -- conc_typR : protection_typ renames _object._object;
5789 -- discr_nameD : discr_typ renames _object.discr_name;
5790 -- discr_nameD : discr_typ renames _task.discr_name;
5791 -- prival_name : comp_typ renames _object.comp_name;
5792 -- J : constant Jnn :=
5793 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5795 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5796 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5797 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5799 if Present
(Debug_Nod
) then
5800 Insert_After
(Decl
, Debug_Nod
);
5806 end Debug_Private_Data_Declarations
;
5808 ------------------------------
5809 -- Ensure_Statement_Present --
5810 ------------------------------
5812 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5816 if Opt
.Suppress_Control_Flow_Optimizations
5817 and then Is_Empty_List
(Statements
(Alt
))
5819 Stmt
:= Make_Null_Statement
(Loc
);
5821 -- Mark NULL statement as coming from source so that it is not
5822 -- eliminated by GIGI.
5824 -- Another covert channel. If this is a requirement, it must be
5825 -- documented in sinfo/einfo ???
5827 Set_Comes_From_Source
(Stmt
, True);
5829 Set_Statements
(Alt
, New_List
(Stmt
));
5831 end Ensure_Statement_Present
;
5833 ----------------------------
5834 -- Entry_Index_Expression --
5835 ----------------------------
5837 function Entry_Index_Expression
5841 Ttyp
: Entity_Id
) return Node_Id
5851 -- The queues of entries and entry families appear in textual order in
5852 -- the associated record. The entry index is computed as the sum of the
5853 -- number of queues for all entries that precede the designated one, to
5854 -- which is added the index expression, if this expression denotes a
5855 -- member of a family.
5857 -- The following is a place holder for the count of simple entries
5859 Num
:= Make_Integer_Literal
(Sloc
, 1);
5861 -- We construct an expression which is a series of addition operations.
5862 -- The first operand is the number of single entries that precede this
5863 -- one, the second operand is the index value relative to the start of
5864 -- the referenced family, and the remaining operands are the lengths of
5865 -- the entry families that precede this entry, i.e. the constructed
5868 -- number_simple_entries +
5869 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5870 -- family'length + ...
5872 -- where index-value is the given index value, and s is the index
5873 -- subtype (we have to use pos because the subtype might be an
5874 -- enumeration type preventing direct subtraction). Note that the task
5875 -- entry array is one-indexed.
5877 -- The upper bound of the entry family may be a discriminant, so we
5878 -- retrieve the lower bound explicitly to compute offset, rather than
5879 -- using the index subtype which may mention a discriminant.
5881 if Present
(Index
) then
5882 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
5890 Make_Attribute_Reference
(Sloc
,
5891 Attribute_Name
=> Name_Pos
,
5892 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
5893 Expressions
=> New_List
(Relocate_Node
(Index
))),
5901 -- Now add lengths of preceding entries and entry families
5903 Prev
:= First_Entity
(Ttyp
);
5904 while Chars
(Prev
) /= Chars
(Ent
)
5905 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5906 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5908 if Ekind
(Prev
) = E_Entry
then
5909 Set_Intval
(Num
, Intval
(Num
) + 1);
5911 elsif Ekind
(Prev
) = E_Entry_Family
then
5912 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
5913 Lo
:= Type_Low_Bound
(S
);
5914 Hi
:= Type_High_Bound
(S
);
5919 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5921 -- Other components are anonymous types to be ignored
5931 end Entry_Index_Expression
;
5933 ---------------------------
5934 -- Establish_Task_Master --
5935 ---------------------------
5937 procedure Establish_Task_Master
(N
: Node_Id
) is
5941 if Restriction_Active
(No_Task_Hierarchy
) = False then
5942 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5944 -- The block may have no declarations (and nevertheless be a task
5945 -- master) if it contains a call that may return an object that
5948 if No
(Declarations
(N
)) then
5949 Set_Declarations
(N
, New_List
(Call
));
5951 Prepend_To
(Declarations
(N
), Call
);
5956 end Establish_Task_Master
;
5958 --------------------------------
5959 -- Expand_Accept_Declarations --
5960 --------------------------------
5962 -- Part of the expansion of an accept statement involves the creation of
5963 -- a declaration that can be referenced from the statement sequence of
5968 -- This declaration is inserted immediately before the accept statement
5969 -- and it is important that it be inserted before the statements of the
5970 -- statement sequence are analyzed. Thus it would be too late to create
5971 -- this declaration in the Expand_N_Accept_Statement routine, which is
5972 -- why there is a separate procedure to be called directly from Sem_Ch9.
5974 -- Ann is used to hold the address of the record containing the parameters
5975 -- (see Expand_N_Entry_Call for more details on how this record is built).
5976 -- References to the parameters do an unchecked conversion of this address
5977 -- to a pointer to the required record type, and then access the field that
5978 -- holds the value of the required parameter. The entity for the address
5979 -- variable is held as the top stack element (i.e. the last element) of the
5980 -- Accept_Address stack in the corresponding entry entity, and this element
5981 -- must be set in place before the statements are processed.
5983 -- The above description applies to the case of a stand alone accept
5984 -- statement, i.e. one not appearing as part of a select alternative.
5986 -- For the case of an accept that appears as part of a select alternative
5987 -- of a selective accept, we must still create the declaration right away,
5988 -- since Ann is needed immediately, but there is an important difference:
5990 -- The declaration is inserted before the selective accept, not before
5991 -- the accept statement (which is not part of a list anyway, and so would
5992 -- not accommodate inserted declarations)
5994 -- We only need one address variable for the entire selective accept. So
5995 -- the Ann declaration is created only for the first accept alternative,
5996 -- and subsequent accept alternatives reference the same Ann variable.
5998 -- We can distinguish the two cases by seeing whether the accept statement
5999 -- is part of a list. If not, then it must be in an accept alternative.
6001 -- To expand the requeue statement, a label is provided at the end of the
6002 -- accept statement or alternative of which it is a part, so that the
6003 -- statement can be skipped after the requeue is complete. This label is
6004 -- created here rather than during the expansion of the accept statement,
6005 -- because it will be needed by any requeue statements within the accept,
6006 -- which are expanded before the accept.
6008 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
6009 Loc
: constant Source_Ptr
:= Sloc
(N
);
6010 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6011 Ann
: Entity_Id
:= Empty
;
6018 if Expander_Active
then
6020 -- If we have no handled statement sequence, we may need to build
6021 -- a dummy sequence consisting of a null statement. This can be
6022 -- skipped if the trivial accept optimization is permitted.
6024 if not Trivial_Accept_OK
6025 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6027 Set_Handled_Statement_Sequence
(N
,
6028 Make_Handled_Sequence_Of_Statements
(Loc
,
6029 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
6032 -- Create and declare two labels to be placed at the end of the
6033 -- accept statement. The first label is used to allow requeues to
6034 -- skip the remainder of entry processing. The second label is used
6035 -- to skip the remainder of entry processing if the rendezvous
6036 -- completes in the middle of the accept body.
6038 if Present
(Handled_Statement_Sequence
(N
)) then
6043 Ent
:= Make_Temporary
(Loc
, 'L');
6044 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
6046 Make_Implicit_Label_Declaration
(Loc
,
6047 Defining_Identifier
=> Ent
,
6048 Label_Construct
=> Lab
);
6049 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
6051 Ent
:= Make_Temporary
(Loc
, 'L');
6052 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
6054 Make_Implicit_Label_Declaration
(Loc
,
6055 Defining_Identifier
=> Ent
,
6056 Label_Construct
=> Lab
);
6057 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
6065 -- Case of stand alone accept statement
6067 if Is_List_Member
(N
) then
6069 if Present
(Handled_Statement_Sequence
(N
)) then
6070 Ann
:= Make_Temporary
(Loc
, 'A');
6073 Make_Object_Declaration
(Loc
,
6074 Defining_Identifier
=> Ann
,
6075 Object_Definition
=>
6076 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
6078 Insert_Before_And_Analyze
(N
, Adecl
);
6079 Insert_Before_And_Analyze
(N
, Ldecl
);
6080 Insert_Before_And_Analyze
(N
, Ldecl2
);
6083 -- Case of accept statement which is in an accept alternative
6087 Acc_Alt
: constant Node_Id
:= Parent
(N
);
6088 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
6092 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
6093 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
6095 -- ??? Consider a single label for select statements
6097 if Present
(Handled_Statement_Sequence
(N
)) then
6099 Statements
(Handled_Statement_Sequence
(N
)));
6103 Statements
(Handled_Statement_Sequence
(N
)));
6107 -- Find first accept alternative of the selective accept. A
6108 -- valid selective accept must have at least one accept in it.
6110 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
6112 while Nkind
(Alt
) /= N_Accept_Alternative
loop
6116 -- If this is the first accept statement, then we have to
6117 -- create the Ann variable, as for the stand alone case, except
6118 -- that it is inserted before the selective accept. Similarly,
6119 -- a label for requeue expansion must be declared.
6121 if N
= Accept_Statement
(Alt
) then
6122 Ann
:= Make_Temporary
(Loc
, 'A');
6124 Make_Object_Declaration
(Loc
,
6125 Defining_Identifier
=> Ann
,
6126 Object_Definition
=>
6127 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
6129 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
6131 -- If this is not the first accept statement, then find the Ann
6132 -- variable allocated by the first accept and use it.
6136 Node
(Last_Elmt
(Accept_Address
6137 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
6142 -- Merge here with Ann either created or referenced, and Adecl
6143 -- pointing to the corresponding declaration. Remaining processing
6144 -- is the same for the two cases.
6146 if Present
(Ann
) then
6147 Append_Elmt
(Ann
, Accept_Address
(Ent
));
6148 Set_Debug_Info_Needed
(Ann
);
6151 -- Create renaming declarations for the entry formals. Each reference
6152 -- to a formal becomes a dereference of a component of the parameter
6153 -- block, whose address is held in Ann. These declarations are
6154 -- eventually inserted into the accept block, and analyzed there so
6155 -- that they have the proper scope for gdb and do not conflict with
6156 -- other declarations.
6158 if Present
(Parameter_Specifications
(N
))
6159 and then Present
(Handled_Statement_Sequence
(N
))
6166 Renamed_Formal
: Node_Id
;
6170 Formal
:= First_Formal
(Ent
);
6172 while Present
(Formal
) loop
6173 Comp
:= Entry_Component
(Formal
);
6174 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
6176 Set_Etype
(New_F
, Etype
(Formal
));
6177 Set_Scope
(New_F
, Ent
);
6179 -- Now we set debug info needed on New_F even though it does
6180 -- not come from source, so that the debugger will get the
6181 -- right information for these generated names.
6183 Set_Debug_Info_Needed
(New_F
);
6185 if Ekind
(Formal
) = E_In_Parameter
then
6186 Set_Ekind
(New_F
, E_Constant
);
6188 Set_Ekind
(New_F
, E_Variable
);
6189 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
6192 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
6195 Make_Selected_Component
(Loc
,
6197 Unchecked_Convert_To
(
6198 Entry_Parameters_Type
(Ent
),
6199 New_Occurrence_Of
(Ann
, Loc
)),
6201 New_Occurrence_Of
(Comp
, Loc
));
6204 Build_Renamed_Formal_Declaration
6205 (New_F
, Formal
, Comp
, Renamed_Formal
);
6207 if No
(Declarations
(N
)) then
6208 Set_Declarations
(N
, New_List
);
6211 Append
(Decl
, Declarations
(N
));
6212 Set_Renamed_Object
(Formal
, New_F
);
6213 Next_Formal
(Formal
);
6220 end Expand_Accept_Declarations
;
6222 ---------------------------------------------
6223 -- Expand_Access_Protected_Subprogram_Type --
6224 ---------------------------------------------
6226 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
6227 Loc
: constant Source_Ptr
:= Sloc
(N
);
6229 T
: constant Entity_Id
:= Defining_Identifier
(N
);
6230 D_T
: constant Entity_Id
:= Designated_Type
(T
);
6231 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
6232 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
6233 P_List
: constant List_Id
:= Build_Protected_Spec
6234 (N
, RTE
(RE_Address
), D_T
, False);
6240 -- Create access to subprogram with full signature
6242 if Etype
(D_T
) /= Standard_Void_Type
then
6244 Make_Access_Function_Definition
(Loc
,
6245 Parameter_Specifications
=> P_List
,
6246 Result_Definition
=>
6247 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
6251 Make_Access_Procedure_Definition
(Loc
,
6252 Parameter_Specifications
=> P_List
);
6256 Make_Full_Type_Declaration
(Loc
,
6257 Defining_Identifier
=> D_T2
,
6258 Type_Definition
=> Def1
);
6260 Insert_After_And_Analyze
(N
, Decl1
);
6262 -- Associate the access to subprogram with its original access to
6263 -- protected subprogram type. Needed by the backend to know that this
6264 -- type corresponds with an access to protected subprogram type.
6266 Set_Original_Access_Type
(D_T2
, T
);
6268 -- Create Equivalent_Type, a record with two components for an access to
6269 -- object and an access to subprogram.
6272 Make_Component_Declaration
(Loc
,
6273 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
6274 Component_Definition
=>
6275 Make_Component_Definition
(Loc
,
6276 Aliased_Present
=> False,
6277 Subtype_Indication
=>
6278 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
6280 Make_Component_Declaration
(Loc
,
6281 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
6282 Component_Definition
=>
6283 Make_Component_Definition
(Loc
,
6284 Aliased_Present
=> False,
6285 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
6288 Make_Full_Type_Declaration
(Loc
,
6289 Defining_Identifier
=> E_T
,
6291 Make_Record_Definition
(Loc
,
6293 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
6295 Insert_After_And_Analyze
(Decl1
, Decl2
);
6296 Set_Equivalent_Type
(T
, E_T
);
6297 end Expand_Access_Protected_Subprogram_Type
;
6299 --------------------------
6300 -- Expand_Entry_Barrier --
6301 --------------------------
6303 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
6304 Cond
: constant Node_Id
:=
6305 Condition
(Entry_Body_Formal_Part
(N
));
6306 Prot
: constant Entity_Id
:= Scope
(Ent
);
6307 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
6308 Func
: Entity_Id
:= Empty
;
6310 Body_Decl
: Node_Id
;
6312 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
;
6313 -- Check whether entity in Barrier is external to protected type.
6314 -- If so, barrier may not be properly synchronized.
6316 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
;
6317 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6320 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean;
6321 -- Check whether entity name N denotes a component of the protected
6322 -- object. This is used to check the Simple_Barrier restriction.
6324 ----------------------
6325 -- Is_Global_Entity --
6326 ----------------------
6328 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
is
6333 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
6337 if Ekind
(E
) = E_Variable
then
6339 -- If the variable is local to the barrier function generated
6340 -- during expansion, it is ok. If expansion is not performed,
6341 -- then Func is Empty so this test cannot succeed.
6343 if Scope
(E
) = Func
then
6346 -- A protected call from a barrier to another object is ok
6348 elsif Ekind
(Etype
(E
)) = E_Protected_Type
then
6351 -- If the variable is within the package body we consider
6352 -- this safe. This is a common (if dubious) idiom.
6354 elsif S
= Scope
(Prot
)
6355 and then Ekind_In
(S
, E_Package
, E_Generic_Package
)
6356 and then Nkind
(Parent
(E
)) = N_Object_Declaration
6357 and then Nkind
(Parent
(Parent
(E
))) = N_Package_Body
6362 Error_Msg_N
("potentially unsynchronized barrier??", N
);
6363 Error_Msg_N
("\& should be private component of type??", N
);
6369 end Is_Global_Entity
;
6371 procedure Check_Unprotected_Barrier
is
6372 new Traverse_Proc
(Is_Global_Entity
);
6374 ----------------------------
6375 -- Is_Simple_Barrier_Name --
6376 ----------------------------
6378 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean is
6382 -- Check for case of _object.all.field (note that the explicit
6383 -- dereference gets inserted by analyze/expand of _object.field).
6385 if Expander_Active
then
6386 Renamed
:= Renamed_Object
(Entity
(N
));
6390 and then Nkind
(Renamed
) = N_Selected_Component
6391 and then Chars
(Prefix
(Prefix
(Renamed
))) = Name_uObject
;
6393 return Scope
(Entity
(N
)) = Current_Scope
;
6395 end Is_Simple_Barrier_Name
;
6397 ---------------------
6398 -- Is_Pure_Barrier --
6399 ---------------------
6401 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
is
6404 when N_Expanded_Name |
6406 if No
(Entity
(N
)) then
6410 case Ekind
(Entity
(N
)) is
6415 E_Enumeration_Literal
=>
6421 -- A variable in the protected type is expanded as a
6424 if Is_Simple_Barrier_Name
(N
) then
6432 when N_Integer_Literal |
6434 N_Character_Literal
=>
6439 if Ekind
(Entity
(N
)) = E_Operator
then
6443 when N_Short_Circuit
=>
6451 end Is_Pure_Barrier
;
6453 function Check_Pure_Barriers
is new Traverse_Func
(Is_Pure_Barrier
);
6455 -- Start of processing for Expand_Entry_Barrier
6458 if No_Run_Time_Mode
then
6459 Error_Msg_CRT
("entry barrier", N
);
6463 -- The body of the entry barrier must be analyzed in the context of the
6464 -- protected object, but its scope is external to it, just as any other
6465 -- unprotected version of a protected operation. The specification has
6466 -- been produced when the protected type declaration was elaborated. We
6467 -- build the body, insert it in the enclosing scope, but analyze it in
6468 -- the current context. A more uniform approach would be to treat the
6469 -- barrier just as a protected function, and discard the protected
6470 -- version of it because it is never called.
6472 if Expander_Active
then
6473 B_F
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6474 Func
:= Barrier_Function
(Ent
);
6475 Set_Corresponding_Spec
(B_F
, Func
);
6477 Body_Decl
:= Parent
(Corresponding_Body
(Spec_Decl
));
6479 if Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
6480 Body_Decl
:= Corresponding_Stub
(Parent
(Body_Decl
));
6483 Insert_Before_And_Analyze
(Body_Decl
, B_F
);
6485 Set_Discriminals
(Spec_Decl
);
6486 Set_Scope
(Func
, Scope
(Prot
));
6489 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6492 -- Check Pure_Barriers restriction
6494 if Check_Pure_Barriers
(Cond
) = Abandon
then
6495 Check_Restriction
(Pure_Barriers
, Cond
);
6498 -- The Ravenscar profile restricts barriers to simple variables declared
6499 -- within the protected object. We also allow Boolean constants, since
6500 -- these appear in several published examples and are also allowed by
6503 -- Note that after analysis variables in this context will be replaced
6504 -- by the corresponding prival, that is to say a renaming of a selected
6505 -- component of the form _Object.Var. If expansion is disabled, as
6506 -- within a generic, we check that the entity appears in the current
6509 if Is_Entity_Name
(Cond
) then
6511 -- A small optimization of useless renamings. If the scope of the
6512 -- entity of the condition is not the barrier function, then the
6513 -- condition does not reference any of the generated renamings
6514 -- within the function.
6516 if Expander_Active
and then Scope
(Entity
(Cond
)) /= Func
then
6517 Set_Declarations
(B_F
, Empty_List
);
6520 if Entity
(Cond
) = Standard_False
6522 Entity
(Cond
) = Standard_True
6526 elsif Is_Simple_Barrier_Name
(Cond
) then
6531 -- It is not a boolean variable or literal, so check the restriction.
6532 -- Note that it is safe to be calling Check_Restriction from here, even
6533 -- though this is part of the expander, since Expand_Entry_Barrier is
6534 -- called from Sem_Ch9 even in -gnatc mode.
6536 Check_Restriction
(Simple_Barriers
, Cond
);
6538 -- Emit warning if barrier contains global entities and is thus
6539 -- potentially unsynchronized.
6541 Check_Unprotected_Barrier
(Cond
);
6542 end Expand_Entry_Barrier
;
6544 ------------------------------
6545 -- Expand_N_Abort_Statement --
6546 ------------------------------
6548 -- Expand abort T1, T2, .. Tn; into:
6549 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6551 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6552 Loc
: constant Source_Ptr
:= Sloc
(N
);
6553 Tlist
: constant List_Id
:= Names
(N
);
6559 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6562 Tasknm
:= First
(Tlist
);
6564 while Present
(Tasknm
) loop
6567 -- A task interface class-wide type object is being aborted. Retrieve
6568 -- its _task_id by calling a dispatching routine.
6570 if Ada_Version
>= Ada_2005
6571 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6572 and then Is_Interface
(Etype
(Tasknm
))
6573 and then Is_Task_Interface
(Etype
(Tasknm
))
6575 Append_To
(Component_Associations
(Aggr
),
6576 Make_Component_Association
(Loc
,
6577 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6580 -- Task_Id (Tasknm._disp_get_task_id)
6582 Make_Unchecked_Type_Conversion
(Loc
,
6584 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6586 Make_Selected_Component
(Loc
,
6587 Prefix
=> New_Copy_Tree
(Tasknm
),
6589 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6592 Append_To
(Component_Associations
(Aggr
),
6593 Make_Component_Association
(Loc
,
6594 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6595 Expression
=> Concurrent_Ref
(Tasknm
)));
6602 Make_Procedure_Call_Statement
(Loc
,
6603 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Tasks
), Loc
),
6604 Parameter_Associations
=> New_List
(
6605 Make_Qualified_Expression
(Loc
,
6606 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_List
), Loc
),
6607 Expression
=> Aggr
))));
6610 end Expand_N_Abort_Statement
;
6612 -------------------------------
6613 -- Expand_N_Accept_Statement --
6614 -------------------------------
6616 -- This procedure handles expansion of accept statements that stand alone,
6617 -- i.e. they are not part of an accept alternative. The expansion of
6618 -- accept statement in accept alternatives is handled by the routines
6619 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6620 -- following description applies only to stand alone accept statements.
6622 -- If there is no handled statement sequence, or only null statements, then
6623 -- this is called a trivial accept, and the expansion is:
6625 -- Accept_Trivial (entry-index)
6627 -- If there is a handled statement sequence, then the expansion is:
6634 -- Accept_Call (entry-index, Ann);
6635 -- Renaming_Declarations for formals
6636 -- <statement sequence from N_Accept_Statement node>
6637 -- Complete_Rendezvous;
6642 -- <exception handler from N_Accept_Statement node>
6643 -- Complete_Rendezvous;
6645 -- <exception handler from N_Accept_Statement node>
6646 -- Complete_Rendezvous;
6651 -- when all others =>
6652 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6655 -- The first three declarations were already inserted ahead of the accept
6656 -- statement by the Expand_Accept_Declarations procedure, which was called
6657 -- directly from the semantics during analysis of the accept statement,
6658 -- before analyzing its contained statements.
6660 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6661 -- from possible expansion activity (the original source of course does
6662 -- not have any declarations associated with the accept statement, since
6663 -- an accept statement has no declarative part). In particular, if the
6664 -- expander is active, the first such declaration is the declaration of
6665 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6667 -- The two blocks are merged into a single block if the inner block has
6668 -- no exception handlers, but otherwise two blocks are required, since
6669 -- exceptions might be raised in the exception handlers of the inner
6670 -- block, and Exceptional_Complete_Rendezvous must be called.
6672 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6673 Loc
: constant Source_Ptr
:= Sloc
(N
);
6674 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6675 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6676 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6677 Eent
: constant Entity_Id
:= Entity
(Ename
);
6678 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6679 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6680 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6686 -- If the accept statement is not part of a list, then its parent must
6687 -- be an accept alternative, and, as described above, we do not do any
6688 -- expansion for such accept statements at this level.
6690 if not Is_List_Member
(N
) then
6691 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6694 -- Trivial accept case (no statement sequence, or null statements).
6695 -- If the accept statement has declarations, then just insert them
6696 -- before the procedure call.
6698 elsif Trivial_Accept_OK
6699 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6701 -- Remove declarations for renamings, because the parameter block
6702 -- will not be assigned.
6709 D
:= First
(Declarations
(N
));
6710 while Present
(D
) loop
6712 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6720 if Present
(Declarations
(N
)) then
6721 Insert_Actions
(N
, Declarations
(N
));
6725 Make_Procedure_Call_Statement
(Loc
,
6726 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Trivial
), Loc
),
6727 Parameter_Associations
=> New_List
(
6728 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6732 -- Discard Entry_Address that was created for it, so it will not be
6733 -- emitted if this accept statement is in the statement part of a
6734 -- delay alternative.
6736 if Present
(Stats
) then
6737 Remove_Last_Elmt
(Acstack
);
6740 -- Case of statement sequence present
6743 -- Construct the block, using the declarations from the accept
6744 -- statement if any to initialize the declarations of the block.
6746 Blkent
:= Make_Temporary
(Loc
, 'A');
6747 Set_Ekind
(Blkent
, E_Block
);
6748 Set_Etype
(Blkent
, Standard_Void_Type
);
6749 Set_Scope
(Blkent
, Current_Scope
);
6752 Make_Block_Statement
(Loc
,
6753 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
6754 Declarations
=> Declarations
(N
),
6755 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6757 -- For the analysis of the generated declarations, the parent node
6758 -- must be properly set.
6760 Set_Parent
(Block
, Parent
(N
));
6762 -- Prepend call to Accept_Call to main statement sequence If the
6763 -- accept has exception handlers, the statement sequence is wrapped
6764 -- in a block. Insert call and renaming declarations in the
6765 -- declarations of the block, so they are elaborated before the
6769 Make_Procedure_Call_Statement
(Loc
,
6770 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Call
), Loc
),
6771 Parameter_Associations
=> New_List
(
6772 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6773 New_Occurrence_Of
(Ann
, Loc
)));
6775 if Parent
(Stats
) = N
then
6776 Prepend
(Call
, Statements
(Stats
));
6778 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6783 Push_Scope
(Blkent
);
6791 D
:= First
(Declarations
(N
));
6792 while Present
(D
) loop
6795 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6797 -- The renaming declarations for the formals were created
6798 -- during analysis of the accept statement, and attached to
6799 -- the list of declarations. Place them now in the context
6800 -- of the accept block or subprogram.
6803 Typ
:= Entity
(Subtype_Mark
(D
));
6804 Insert_After
(Call
, D
);
6807 -- If the formal is class_wide, it does not have an actual
6808 -- subtype. The analysis of the renaming declaration creates
6809 -- one, but we need to retain the class-wide nature of the
6812 if Is_Class_Wide_Type
(Typ
) then
6813 Set_Etype
(Defining_Identifier
(D
), Typ
);
6824 -- Replace the accept statement by the new block
6829 -- Last step is to unstack the Accept_Address value
6831 Remove_Last_Elmt
(Acstack
);
6833 end Expand_N_Accept_Statement
;
6835 ----------------------------------
6836 -- Expand_N_Asynchronous_Select --
6837 ----------------------------------
6839 -- This procedure assumes that the trigger statement is an entry call or
6840 -- a dispatching procedure call. A delay alternative should already have
6841 -- been expanded into an entry call to the appropriate delay object Wait
6844 -- If the trigger is a task entry call, the select is implemented with
6845 -- a Task_Entry_Call:
6850 -- P : parms := (parm, parm, parm);
6852 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6854 -- procedure _clean is
6857 -- Cancel_Task_Entry_Call (C);
6864 -- (<acceptor-task>, -- Acceptor
6865 -- <entry-index>, -- E
6866 -- P'Address, -- Uninterpreted_Data
6867 -- Asynchronous_Call, -- Mode
6868 -- B); -- Rendezvous_Successful
6875 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6878 -- when Abort_Signal => Abort_Undefer;
6885 -- <triggered-statements>
6889 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6890 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6894 -- P : parms := (parm, parm, parm);
6896 -- Call_Simple (acceptor-task, entry-index, P'Address);
6902 -- so the task at hand is to convert the latter expansion into the former
6904 -- If the trigger is a protected entry call, the select is implemented
6905 -- with Protected_Entry_Call:
6908 -- P : E1_Params := (param, param, param);
6909 -- Bnn : Communications_Block;
6914 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6916 -- procedure _clean is
6919 -- if Enqueued (Bnn) then
6920 -- Cancel_Protected_Entry_Call (Bnn);
6927 -- Protected_Entry_Call
6928 -- (po._object'Access, -- Object
6929 -- <entry index>, -- E
6930 -- P'Address, -- Uninterpreted_Data
6931 -- Asynchronous_Call, -- Mode
6934 -- if Enqueued (Bnn) then
6938 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6941 -- when Abort_Signal => Abort_Undefer;
6944 -- if not Cancelled (Bnn) then
6945 -- <triggered-statements>
6949 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6953 -- P : E1_Params := (param, param, param);
6954 -- Bnn : Communications_Block;
6957 -- Protected_Entry_Call
6958 -- (po._object'Access, -- Object
6959 -- <entry index>, -- E
6960 -- P'Address, -- Uninterpreted_Data
6961 -- Simple_Call, -- Mode
6968 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6972 -- B : Boolean := False;
6973 -- Bnn : Communication_Block;
6974 -- C : Ada.Tags.Prim_Op_Kind;
6975 -- D : System.Storage_Elements.Dummy_Communication_Block;
6976 -- K : Ada.Tags.Tagged_Kind :=
6977 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6978 -- P : Parameters := (Param1 .. ParamN);
6983 -- if K = Ada.Tags.TK_Limited_Tagged
6984 -- or else K = Ada.Tags.TK_Tagged
6986 -- <dispatching-call>;
6987 -- <triggering-statements>;
6991 -- Ada.Tags.Get_Offset_Index
6992 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6994 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6996 -- if C = POK_Protected_Entry then
6998 -- procedure _clean is
7000 -- if Enqueued (Bnn) then
7001 -- Cancel_Protected_Entry_Call (Bnn);
7007 -- _Disp_Asynchronous_Select
7008 -- (<object>, S, P'Address, D, B);
7009 -- Bnn := Communication_Block (D);
7011 -- Param1 := P.Param1;
7013 -- ParamN := P.ParamN;
7015 -- if Enqueued (Bnn) then
7016 -- <abortable-statements>
7019 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7022 -- when Abort_Signal => Abort_Undefer;
7025 -- if not Cancelled (Bnn) then
7026 -- <triggering-statements>
7029 -- elsif C = POK_Task_Entry then
7031 -- procedure _clean is
7033 -- Cancel_Task_Entry_Call (U);
7039 -- _Disp_Asynchronous_Select
7040 -- (<object>, S, P'Address, D, B);
7041 -- Bnn := Communication_Bloc (D);
7043 -- Param1 := P.Param1;
7045 -- ParamN := P.ParamN;
7050 -- <abortable-statements>
7052 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7055 -- when Abort_Signal => Abort_Undefer;
7059 -- <triggering-statements>
7064 -- <dispatching-call>;
7065 -- <triggering-statements>
7070 -- The job is to convert this to the asynchronous form
7072 -- If the trigger is a delay statement, it will have been expanded into
7073 -- a call to one of the GNARL delay procedures. This routine will convert
7074 -- this into a protected entry call on a delay object and then continue
7075 -- processing as for a protected entry call trigger. This requires
7076 -- declaring a Delay_Block object and adding a pointer to this object to
7077 -- the parameter list of the delay procedure to form the parameter list of
7078 -- the entry call. This object is used by the runtime to queue the delay
7081 -- For a description of the use of P and the assignments after the call,
7082 -- see Expand_N_Entry_Call_Statement.
7084 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
7085 Loc
: constant Source_Ptr
:= Sloc
(N
);
7086 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
7087 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
7089 Abort_Block_Ent
: Entity_Id
;
7090 Abortable_Block
: Node_Id
;
7093 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7094 Blk_Typ
: Entity_Id
;
7096 Call_Ent
: Entity_Id
;
7097 Cancel_Param
: Entity_Id
;
7098 Cleanup_Block
: Node_Id
;
7099 Cleanup_Block_Ent
: Entity_Id
;
7100 Cleanup_Stmts
: List_Id
;
7101 Conc_Typ_Stmts
: List_Id
;
7103 Dblock_Ent
: Entity_Id
;
7108 Enqueue_Call
: Node_Id
;
7111 Handler_Stmt
: Node_Id
;
7113 Lim_Typ_Stmts
: List_Id
;
7119 ProtE_Stmts
: List_Id
;
7120 ProtP_Stmts
: List_Id
;
7123 TaskE_Stmts
: List_Id
;
7126 B
: Entity_Id
; -- Call status flag
7127 Bnn
: Entity_Id
; -- Communication block
7128 C
: Entity_Id
; -- Call kind
7129 K
: Entity_Id
; -- Tagged kind
7130 P
: Entity_Id
; -- Parameter block
7131 S
: Entity_Id
; -- Primitive operation slot
7132 T
: Entity_Id
; -- Additional status flag
7134 procedure Rewrite_Abortable_Part
;
7135 -- If the trigger is a dispatching call, the expansion inserts multiple
7136 -- copies of the abortable part. This is both inefficient, and may lead
7137 -- to duplicate definitions that the back-end will reject, when the
7138 -- abortable part includes loops. This procedure rewrites the abortable
7139 -- part into a call to a generated procedure.
7141 ----------------------------
7142 -- Rewrite_Abortable_Part --
7143 ----------------------------
7145 procedure Rewrite_Abortable_Part
is
7146 Proc
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7151 Make_Subprogram_Body
(Loc
,
7153 Make_Procedure_Specification
(Loc
, Defining_Unit_Name
=> Proc
),
7154 Declarations
=> New_List
,
7155 Handled_Statement_Sequence
=>
7156 Make_Handled_Sequence_Of_Statements
(Loc
, Astats
));
7157 Insert_Before
(N
, Decl
);
7160 -- Rewrite abortable part into a call to this procedure.
7164 Make_Procedure_Call_Statement
(Loc
,
7165 Name
=> New_Occurrence_Of
(Proc
, Loc
)));
7166 end Rewrite_Abortable_Part
;
7168 -- Start of processing for Expand_N_Asynchronous_Select
7171 Process_Statements_For_Controlled_Objects
(Trig
);
7172 Process_Statements_For_Controlled_Objects
(Abrt
);
7174 Ecall
:= Triggering_Statement
(Trig
);
7176 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
7178 -- Retrieve Astats and Tstats now because the finalization machinery may
7179 -- wrap them in blocks.
7181 Astats
:= Statements
(Abrt
);
7182 Tstats
:= Statements
(Trig
);
7184 -- The arguments in the call may require dynamic allocation, and the
7185 -- call statement may have been transformed into a block. The block
7186 -- may contain additional declarations for internal entities, and the
7187 -- original call is found by sequential search.
7189 if Nkind
(Ecall
) = N_Block_Statement
then
7190 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
7191 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
7192 N_Entry_Call_Statement
)
7198 -- This is either a dispatching call or a delay statement used as a
7199 -- trigger which was expanded into a procedure call.
7201 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
7202 if Ada_Version
>= Ada_2005
7204 (No
(Original_Node
(Ecall
))
7205 or else not Nkind_In
(Original_Node
(Ecall
),
7206 N_Delay_Relative_Statement
,
7207 N_Delay_Until_Statement
))
7209 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
7211 Rewrite_Abortable_Part
;
7215 -- Call status flag processing, generate:
7216 -- B : Boolean := False;
7218 B
:= Build_B
(Loc
, Decls
);
7220 -- Communication block processing, generate:
7221 -- Bnn : Communication_Block;
7223 Bnn
:= Make_Temporary
(Loc
, 'B');
7225 Make_Object_Declaration
(Loc
,
7226 Defining_Identifier
=> Bnn
,
7227 Object_Definition
=>
7228 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
7230 -- Call kind processing, generate:
7231 -- C : Ada.Tags.Prim_Op_Kind;
7233 C
:= Build_C
(Loc
, Decls
);
7235 -- Tagged kind processing, generate:
7236 -- K : Ada.Tags.Tagged_Kind :=
7237 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7239 -- Dummy communication block, generate:
7240 -- D : Dummy_Communication_Block;
7243 Make_Object_Declaration
(Loc
,
7244 Defining_Identifier
=>
7245 Make_Defining_Identifier
(Loc
, Name_uD
),
7246 Object_Definition
=>
7248 (RTE
(RE_Dummy_Communication_Block
), Loc
)));
7250 K
:= Build_K
(Loc
, Decls
, Obj
);
7252 -- Parameter block processing
7254 Blk_Typ
:= Build_Parameter_Block
7255 (Loc
, Actuals
, Formals
, Decls
);
7256 P
:= Parameter_Block_Pack
7257 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7259 -- Dispatch table slot processing, generate:
7262 S
:= Build_S
(Loc
, Decls
);
7264 -- Additional status flag processing, generate:
7267 T
:= Make_Temporary
(Loc
, 'T');
7269 Make_Object_Declaration
(Loc
,
7270 Defining_Identifier
=> T
,
7271 Object_Definition
=>
7272 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7274 ------------------------------
7275 -- Protected entry handling --
7276 ------------------------------
7279 -- Param1 := P.Param1;
7281 -- ParamN := P.ParamN;
7283 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7286 -- Bnn := Communication_Block (D);
7288 Prepend_To
(Cleanup_Stmts
,
7289 Make_Assignment_Statement
(Loc
,
7290 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
7292 Make_Unchecked_Type_Conversion
(Loc
,
7294 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7295 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7298 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7300 Prepend_To
(Cleanup_Stmts
,
7301 Make_Procedure_Call_Statement
(Loc
,
7305 (Etype
(Etype
(Obj
)), Name_uDisp_Asynchronous_Select
),
7307 Parameter_Associations
=>
7309 New_Copy_Tree
(Obj
), -- <object>
7310 New_Occurrence_Of
(S
, Loc
), -- S
7311 Make_Attribute_Reference
(Loc
, -- P'Address
7312 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7313 Attribute_Name
=> Name_Address
),
7314 Make_Identifier
(Loc
, Name_uD
), -- D
7315 New_Occurrence_Of
(B
, Loc
)))); -- B
7318 -- if Enqueued (Bnn) then
7319 -- <abortable-statements>
7322 Append_To
(Cleanup_Stmts
,
7323 Make_Implicit_If_Statement
(N
,
7325 Make_Function_Call
(Loc
,
7327 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7328 Parameter_Associations
=>
7329 New_List
(New_Occurrence_Of
(Bnn
, Loc
))),
7332 New_Copy_List_Tree
(Astats
)));
7334 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7335 -- will then generate a _clean for the communication block Bnn.
7339 -- procedure _clean is
7341 -- if Enqueued (Bnn) then
7342 -- Cancel_Protected_Entry_Call (Bnn);
7351 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7353 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
7355 -- Wrap the cleanup block in an exception handling block
7361 -- when Abort_Signal => Abort_Undefer;
7364 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7367 Make_Implicit_Label_Declaration
(Loc
,
7368 Defining_Identifier
=> Abort_Block_Ent
),
7371 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7374 -- if not Cancelled (Bnn) then
7375 -- <triggering-statements>
7378 Append_To
(ProtE_Stmts
,
7379 Make_Implicit_If_Statement
(N
,
7383 Make_Function_Call
(Loc
,
7385 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7386 Parameter_Associations
=>
7387 New_List
(New_Occurrence_Of
(Bnn
, Loc
)))),
7390 New_Copy_List_Tree
(Tstats
)));
7392 -------------------------
7393 -- Task entry handling --
7394 -------------------------
7397 -- Param1 := P.Param1;
7399 -- ParamN := P.ParamN;
7401 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7404 -- Bnn := Communication_Block (D);
7406 Append_To
(TaskE_Stmts
,
7407 Make_Assignment_Statement
(Loc
,
7409 New_Occurrence_Of
(Bnn
, Loc
),
7411 Make_Unchecked_Type_Conversion
(Loc
,
7413 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7414 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7417 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7419 Prepend_To
(TaskE_Stmts
,
7420 Make_Procedure_Call_Statement
(Loc
,
7423 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7424 Name_uDisp_Asynchronous_Select
),
7427 Parameter_Associations
=> New_List
(
7428 New_Copy_Tree
(Obj
), -- <object>
7429 New_Occurrence_Of
(S
, Loc
), -- S
7430 Make_Attribute_Reference
(Loc
, -- P'Address
7431 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7432 Attribute_Name
=> Name_Address
),
7433 Make_Identifier
(Loc
, Name_uD
), -- D
7434 New_Occurrence_Of
(B
, Loc
)))); -- B
7439 Prepend_To
(TaskE_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7443 -- <abortable-statements>
7445 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
7448 (Cleanup_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7450 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7451 -- will generate a _clean for the additional status flag.
7455 -- procedure _clean is
7457 -- Cancel_Task_Entry_Call (U);
7465 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7467 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
7469 -- Wrap the cleanup block in an exception handling block
7475 -- when Abort_Signal => Abort_Undefer;
7478 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7480 Append_To
(TaskE_Stmts
,
7481 Make_Implicit_Label_Declaration
(Loc
,
7482 Defining_Identifier
=> Abort_Block_Ent
));
7484 Append_To
(TaskE_Stmts
,
7486 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7490 -- <triggering-statements>
7493 Append_To
(TaskE_Stmts
,
7494 Make_Implicit_If_Statement
(N
,
7496 Make_Op_Not
(Loc
, Right_Opnd
=> New_Occurrence_Of
(T
, Loc
)),
7499 New_Copy_List_Tree
(Tstats
)));
7501 ----------------------------------
7502 -- Protected procedure handling --
7503 ----------------------------------
7506 -- <dispatching-call>;
7507 -- <triggering-statements>
7509 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7510 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7513 -- S := Ada.Tags.Get_Offset_Index
7514 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7517 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7520 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7522 Append_To
(Conc_Typ_Stmts
,
7523 Make_Procedure_Call_Statement
(Loc
,
7526 (Find_Prim_Op
(Etype
(Etype
(Obj
)),
7527 Name_uDisp_Get_Prim_Op_Kind
),
7529 Parameter_Associations
=>
7531 New_Copy_Tree
(Obj
),
7532 New_Occurrence_Of
(S
, Loc
),
7533 New_Occurrence_Of
(C
, Loc
))));
7536 -- if C = POK_Procedure_Entry then
7538 -- elsif C = POK_Task_Entry then
7544 Append_To
(Conc_Typ_Stmts
,
7545 Make_Implicit_If_Statement
(N
,
7549 New_Occurrence_Of
(C
, Loc
),
7551 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7558 Make_Elsif_Part
(Loc
,
7562 New_Occurrence_Of
(C
, Loc
),
7564 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
)),
7573 -- <dispatching-call>;
7574 -- <triggering-statements>
7576 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7577 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7580 -- if K = Ada.Tags.TK_Limited_Tagged
7581 -- or else K = Ada.Tags.TK_Tagged
7589 Make_Implicit_If_Statement
(N
,
7590 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
7591 Then_Statements
=> Lim_Typ_Stmts
,
7592 Else_Statements
=> Conc_Typ_Stmts
));
7595 Make_Block_Statement
(Loc
,
7598 Handled_Statement_Sequence
=>
7599 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7604 -- Delay triggering statement processing
7607 -- Add a Delay_Block object to the parameter list of the delay
7608 -- procedure to form the parameter list of the Wait entry call.
7610 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7612 Pdef
:= Entity
(Name
(Ecall
));
7614 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7616 New_Occurrence_Of
(RTE
(RE_Enqueue_Duration
), Loc
);
7618 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7620 New_Occurrence_Of
(RTE
(RE_Enqueue_Calendar
), Loc
);
7622 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7623 Enqueue_Call
:= New_Occurrence_Of
(RTE
(RE_Enqueue_RT
), Loc
);
7626 Append_To
(Parameter_Associations
(Ecall
),
7627 Make_Attribute_Reference
(Loc
,
7628 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7629 Attribute_Name
=> Name_Unchecked_Access
));
7631 -- Create the inner block to protect the abortable part
7633 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7635 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7638 Make_Block_Statement
(Loc
,
7639 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7640 Handled_Statement_Sequence
=>
7641 Make_Handled_Sequence_Of_Statements
(Loc
,
7642 Statements
=> Astats
),
7643 Has_Created_Identifier
=> True,
7644 Is_Asynchronous_Call_Block
=> True);
7646 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7649 Make_Implicit_If_Statement
(N
,
7651 Make_Function_Call
(Loc
,
7652 Name
=> Enqueue_Call
,
7653 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7655 New_List
(Make_Block_Statement
(Loc
,
7656 Handled_Statement_Sequence
=>
7657 Make_Handled_Sequence_Of_Statements
(Loc
,
7658 Statements
=> New_List
(
7659 Make_Implicit_Label_Declaration
(Loc
,
7660 Defining_Identifier
=> Blk_Ent
,
7661 Label_Construct
=> Abortable_Block
),
7663 Exception_Handlers
=> Hdle
)))));
7665 Stmts
:= New_List
(Ecall
);
7667 -- Construct statement sequence for new block
7670 Make_Implicit_If_Statement
(N
,
7672 Make_Function_Call
(Loc
,
7673 Name
=> New_Occurrence_Of
(
7674 RTE
(RE_Timed_Out
), Loc
),
7675 Parameter_Associations
=> New_List
(
7676 Make_Attribute_Reference
(Loc
,
7677 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7678 Attribute_Name
=> Name_Unchecked_Access
))),
7679 Then_Statements
=> Tstats
));
7681 -- The result is the new block
7683 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7686 Make_Block_Statement
(Loc
,
7687 Declarations
=> New_List
(
7688 Make_Object_Declaration
(Loc
,
7689 Defining_Identifier
=> Dblock_Ent
,
7690 Aliased_Present
=> True,
7691 Object_Definition
=>
7692 New_Occurrence_Of
(RTE
(RE_Delay_Block
), Loc
))),
7694 Handled_Statement_Sequence
=>
7695 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7705 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7706 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7708 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7709 Decls
:= Declarations
(Ecall
);
7711 if Is_Protected_Type
(Etype
(Concval
)) then
7713 -- Get the declarations of the block expanded from the entry call
7715 Decl
:= First
(Decls
);
7716 while Present
(Decl
)
7717 and then (Nkind
(Decl
) /= N_Object_Declaration
7718 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7719 RE_Communication_Block
))
7724 pragma Assert
(Present
(Decl
));
7725 Cancel_Param
:= Defining_Identifier
(Decl
);
7727 -- Change the mode of the Protected_Entry_Call call
7729 -- Protected_Entry_Call (
7730 -- Object => po._object'Access,
7731 -- E => <entry index>;
7732 -- Uninterpreted_Data => P'Address;
7733 -- Mode => Asynchronous_Call;
7736 -- Skip assignments to temporaries created for in-out parameters
7738 -- This makes unwarranted assumptions about the shape of the expanded
7739 -- tree for the call, and should be cleaned up ???
7741 Stmt
:= First
(Stmts
);
7742 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7748 Param
:= First
(Parameter_Associations
(Call
));
7749 while Present
(Param
)
7750 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7755 pragma Assert
(Present
(Param
));
7756 Rewrite
(Param
, New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7759 -- Append an if statement to execute the abortable part
7762 -- if Enqueued (Bnn) then
7765 Make_Implicit_If_Statement
(N
,
7767 Make_Function_Call
(Loc
,
7768 Name
=> New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7769 Parameter_Associations
=> New_List
(
7770 New_Occurrence_Of
(Cancel_Param
, Loc
))),
7771 Then_Statements
=> Astats
));
7774 Make_Block_Statement
(Loc
,
7775 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7776 Handled_Statement_Sequence
=>
7777 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7778 Has_Created_Identifier
=> True,
7779 Is_Asynchronous_Call_Block
=> True);
7781 -- Aborts are not deferred at beginning of exception handlers in
7784 if ZCX_Exceptions
then
7785 Handler_Stmt
:= Make_Null_Statement
(Loc
);
7788 Handler_Stmt
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
7792 Make_Block_Statement
(Loc
,
7793 Handled_Statement_Sequence
=>
7794 Make_Handled_Sequence_Of_Statements
(Loc
,
7795 Statements
=> New_List
(
7796 Make_Implicit_Label_Declaration
(Loc
,
7797 Defining_Identifier
=> Blk_Ent
,
7798 Label_Construct
=> Abortable_Block
),
7803 Exception_Handlers
=> New_List
(
7804 Make_Implicit_Exception_Handler
(Loc
,
7806 -- when Abort_Signal =>
7807 -- Abort_Undefer.all;
7809 Exception_Choices
=>
7810 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
7811 Statements
=> New_List
(Handler_Stmt
))))),
7813 -- if not Cancelled (Bnn) then
7814 -- triggered statements
7817 Make_Implicit_If_Statement
(N
,
7818 Condition
=> Make_Op_Not
(Loc
,
7820 Make_Function_Call
(Loc
,
7821 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7822 Parameter_Associations
=> New_List
(
7823 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7824 Then_Statements
=> Tstats
));
7826 -- Asynchronous task entry call
7833 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7835 -- Insert declaration of B in declarations of existing block
7838 Make_Object_Declaration
(Loc
,
7839 Defining_Identifier
=> B
,
7840 Object_Definition
=>
7841 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7843 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7845 -- Insert declaration of C in declarations of existing block
7848 Make_Object_Declaration
(Loc
,
7849 Defining_Identifier
=> Cancel_Param
,
7850 Object_Definition
=>
7851 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7853 -- Remove and save the call to Call_Simple
7855 Stmt
:= First
(Stmts
);
7857 -- Skip assignments to temporaries created for in-out parameters.
7858 -- This makes unwarranted assumptions about the shape of the expanded
7859 -- tree for the call, and should be cleaned up ???
7861 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7867 -- Create the inner block to protect the abortable part
7869 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7871 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7874 Make_Block_Statement
(Loc
,
7875 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7876 Handled_Statement_Sequence
=>
7877 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7878 Has_Created_Identifier
=> True,
7879 Is_Asynchronous_Call_Block
=> True);
7882 Make_Block_Statement
(Loc
,
7883 Handled_Statement_Sequence
=>
7884 Make_Handled_Sequence_Of_Statements
(Loc
,
7885 Statements
=> New_List
(
7886 Make_Implicit_Label_Declaration
(Loc
,
7887 Defining_Identifier
=> Blk_Ent
,
7888 Label_Construct
=> Abortable_Block
),
7890 Exception_Handlers
=> Hdle
)));
7892 -- Create new call statement
7894 Params
:= Parameter_Associations
(Call
);
7897 New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7898 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
7901 Make_Procedure_Call_Statement
(Loc
,
7902 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
7903 Parameter_Associations
=> Params
));
7905 -- Construct statement sequence for new block
7908 Make_Implicit_If_Statement
(N
,
7910 Make_Op_Not
(Loc
, New_Occurrence_Of
(Cancel_Param
, Loc
)),
7911 Then_Statements
=> Tstats
));
7913 -- Protected the call against abort
7915 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7918 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7920 -- The result is the new block
7923 Make_Block_Statement
(Loc
,
7924 Declarations
=> Decls
,
7925 Handled_Statement_Sequence
=>
7926 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7929 end Expand_N_Asynchronous_Select
;
7931 -------------------------------------
7932 -- Expand_N_Conditional_Entry_Call --
7933 -------------------------------------
7935 -- The conditional task entry call is converted to a call to
7940 -- P : parms := (parm, parm, parm);
7944 -- (<acceptor-task>, -- Acceptor
7945 -- <entry-index>, -- E
7946 -- P'Address, -- Uninterpreted_Data
7947 -- Conditional_Call, -- Mode
7948 -- B); -- Rendezvous_Successful
7953 -- normal-statements
7959 -- For a description of the use of P and the assignments after the call,
7960 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7961 -- conditional entry call has already been expanded (by the Expand_N_Entry
7962 -- _Call_Statement procedure) as follows:
7965 -- P : parms := (parm, parm, parm);
7967 -- ... info for in-out parameters
7968 -- Call_Simple (acceptor-task, entry-index, P'Address);
7974 -- so the task at hand is to convert the latter expansion into the former
7976 -- The conditional protected entry call is converted to a call to
7977 -- Protected_Entry_Call:
7980 -- P : parms := (parm, parm, parm);
7981 -- Bnn : Communications_Block;
7984 -- Protected_Entry_Call
7985 -- (po._object'Access, -- Object
7986 -- <entry index>, -- E
7987 -- P'Address, -- Uninterpreted_Data
7988 -- Conditional_Call, -- Mode
7993 -- if Cancelled (Bnn) then
7996 -- normal-statements
8000 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
8004 -- B : Boolean := False;
8005 -- C : Ada.Tags.Prim_Op_Kind;
8006 -- K : Ada.Tags.Tagged_Kind :=
8007 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8008 -- P : Parameters := (Param1 .. ParamN);
8012 -- if K = Ada.Tags.TK_Limited_Tagged
8013 -- or else K = Ada.Tags.TK_Tagged
8015 -- <dispatching-call>;
8016 -- <triggering-statements>
8020 -- Ada.Tags.Get_Offset_Index
8021 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
8023 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8025 -- if C = POK_Protected_Entry
8026 -- or else C = POK_Task_Entry
8028 -- Param1 := P.Param1;
8030 -- ParamN := P.ParamN;
8034 -- if C = POK_Procedure
8035 -- or else C = POK_Protected_Procedure
8036 -- or else C = POK_Task_Procedure
8038 -- <dispatching-call>;
8041 -- <triggering-statements>
8043 -- <else-statements>
8048 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
8049 Loc
: constant Source_Ptr
:= Sloc
(N
);
8050 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
8051 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
8054 Blk_Typ
: Entity_Id
;
8056 Call_Ent
: Entity_Id
;
8057 Conc_Typ_Stmts
: List_Id
;
8061 Lim_Typ_Stmts
: List_Id
;
8068 Transient_Blk
: Node_Id
;
8071 B
: Entity_Id
; -- Call status flag
8072 C
: Entity_Id
; -- Call kind
8073 K
: Entity_Id
; -- Tagged kind
8074 P
: Entity_Id
; -- Parameter block
8075 S
: Entity_Id
; -- Primitive operation slot
8078 Process_Statements_For_Controlled_Objects
(N
);
8080 if Ada_Version
>= Ada_2005
8081 and then Nkind
(Blk
) = N_Procedure_Call_Statement
8083 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
8088 -- Call status flag processing, generate:
8089 -- B : Boolean := False;
8091 B
:= Build_B
(Loc
, Decls
);
8093 -- Call kind processing, generate:
8094 -- C : Ada.Tags.Prim_Op_Kind;
8096 C
:= Build_C
(Loc
, Decls
);
8098 -- Tagged kind processing, generate:
8099 -- K : Ada.Tags.Tagged_Kind :=
8100 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8102 K
:= Build_K
(Loc
, Decls
, Obj
);
8104 -- Parameter block processing
8106 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
8107 P
:= Parameter_Block_Pack
8108 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
8110 -- Dispatch table slot processing, generate:
8113 S
:= Build_S
(Loc
, Decls
);
8116 -- S := Ada.Tags.Get_Offset_Index
8117 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
8120 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
8123 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8125 Append_To
(Conc_Typ_Stmts
,
8126 Make_Procedure_Call_Statement
(Loc
,
8129 Find_Prim_Op
(Etype
(Etype
(Obj
)),
8130 Name_uDisp_Conditional_Select
),
8132 Parameter_Associations
=>
8134 New_Copy_Tree
(Obj
), -- <object>
8135 New_Occurrence_Of
(S
, Loc
), -- S
8136 Make_Attribute_Reference
(Loc
, -- P'Address
8137 Prefix
=> New_Occurrence_Of
(P
, Loc
),
8138 Attribute_Name
=> Name_Address
),
8139 New_Occurrence_Of
(C
, Loc
), -- C
8140 New_Occurrence_Of
(B
, Loc
)))); -- B
8143 -- if C = POK_Protected_Entry
8144 -- or else C = POK_Task_Entry
8146 -- Param1 := P.Param1;
8148 -- ParamN := P.ParamN;
8151 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
8153 -- Generate the if statement only when the packed parameters need
8154 -- explicit assignments to their corresponding actuals.
8156 if Present
(Unpack
) then
8157 Append_To
(Conc_Typ_Stmts
,
8158 Make_Implicit_If_Statement
(N
,
8164 New_Occurrence_Of
(C
, Loc
),
8166 New_Occurrence_Of
(RTE
(
8167 RE_POK_Protected_Entry
), Loc
)),
8172 New_Occurrence_Of
(C
, Loc
),
8174 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
8176 Then_Statements
=> Unpack
));
8181 -- if C = POK_Procedure
8182 -- or else C = POK_Protected_Procedure
8183 -- or else C = POK_Task_Procedure
8185 -- <dispatching-call>
8187 -- <normal-statements>
8189 -- <else-statements>
8192 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
8194 Prepend_To
(N_Stats
,
8195 Make_Implicit_If_Statement
(N
,
8201 New_Occurrence_Of
(C
, Loc
),
8203 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
8210 New_Occurrence_Of
(C
, Loc
),
8212 New_Occurrence_Of
(RTE
(
8213 RE_POK_Protected_Procedure
), Loc
)),
8218 New_Occurrence_Of
(C
, Loc
),
8220 New_Occurrence_Of
(RTE
(
8221 RE_POK_Task_Procedure
), Loc
)))),
8226 Append_To
(Conc_Typ_Stmts
,
8227 Make_Implicit_If_Statement
(N
,
8228 Condition
=> New_Occurrence_Of
(B
, Loc
),
8229 Then_Statements
=> N_Stats
,
8230 Else_Statements
=> Else_Statements
(N
)));
8233 -- <dispatching-call>;
8234 -- <triggering-statements>
8236 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
8237 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
8240 -- if K = Ada.Tags.TK_Limited_Tagged
8241 -- or else K = Ada.Tags.TK_Tagged
8249 Make_Implicit_If_Statement
(N
,
8250 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
8251 Then_Statements
=> Lim_Typ_Stmts
,
8252 Else_Statements
=> Conc_Typ_Stmts
));
8255 Make_Block_Statement
(Loc
,
8258 Handled_Statement_Sequence
=>
8259 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8261 -- As described above, the entry alternative is transformed into a
8262 -- block that contains the gnulli call, and possibly assignment
8263 -- statements for in-out parameters. The gnulli call may itself be
8264 -- rewritten into a transient block if some unconstrained parameters
8265 -- require it. We need to retrieve the call to complete its parameter
8270 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
8272 if Present
(Transient_Blk
)
8273 and then Nkind
(Transient_Blk
) = N_Block_Statement
8275 Blk
:= Transient_Blk
;
8278 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
8279 Stmt
:= First
(Stmts
);
8280 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
8285 Params
:= Parameter_Associations
(Call
);
8287 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
8289 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8291 Param
:= First
(Params
);
8292 while Present
(Param
)
8293 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
8298 pragma Assert
(Present
(Param
));
8300 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8304 -- Find the Communication_Block parameter for the call to the
8305 -- Cancelled function.
8307 Decl
:= First
(Declarations
(Blk
));
8308 while Present
(Decl
)
8309 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
8310 RE_Communication_Block
)
8315 -- Add an if statement to execute the else part if the call
8316 -- does not succeed (as indicated by the Cancelled predicate).
8319 Make_Implicit_If_Statement
(N
,
8320 Condition
=> Make_Function_Call
(Loc
,
8321 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
8322 Parameter_Associations
=> New_List
(
8323 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))),
8324 Then_Statements
=> Else_Statements
(N
),
8325 Else_Statements
=> Statements
(Alt
)));
8328 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8330 -- Insert declaration of B in declarations of existing block
8332 if No
(Declarations
(Blk
)) then
8333 Set_Declarations
(Blk
, New_List
);
8336 Prepend_To
(Declarations
(Blk
),
8337 Make_Object_Declaration
(Loc
,
8338 Defining_Identifier
=> B
,
8339 Object_Definition
=>
8340 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8342 -- Create new call statement
8345 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8346 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
8349 Make_Procedure_Call_Statement
(Loc
,
8350 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
8351 Parameter_Associations
=> Params
));
8353 -- Construct statement sequence for new block
8356 Make_Implicit_If_Statement
(N
,
8357 Condition
=> New_Occurrence_Of
(B
, Loc
),
8358 Then_Statements
=> Statements
(Alt
),
8359 Else_Statements
=> Else_Statements
(N
)));
8362 -- The result is the new block
8365 Make_Block_Statement
(Loc
,
8366 Declarations
=> Declarations
(Blk
),
8367 Handled_Statement_Sequence
=>
8368 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8372 end Expand_N_Conditional_Entry_Call
;
8374 ---------------------------------------
8375 -- Expand_N_Delay_Relative_Statement --
8376 ---------------------------------------
8378 -- Delay statement is implemented as a procedure call to Delay_For
8379 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8380 -- simple delays imposed by the use of Protected Objects.
8382 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
8383 Loc
: constant Source_Ptr
:= Sloc
(N
);
8386 Make_Procedure_Call_Statement
(Loc
,
8387 Name
=> New_Occurrence_Of
(RTE
(RO_CA_Delay_For
), Loc
),
8388 Parameter_Associations
=> New_List
(Expression
(N
))));
8390 end Expand_N_Delay_Relative_Statement
;
8392 ------------------------------------
8393 -- Expand_N_Delay_Until_Statement --
8394 ------------------------------------
8396 -- Delay Until statement is implemented as a procedure call to
8397 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8399 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
8400 Loc
: constant Source_Ptr
:= Sloc
(N
);
8404 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
8405 Typ
:= RTE
(RO_CA_Delay_Until
);
8407 Typ
:= RTE
(RO_RT_Delay_Until
);
8411 Make_Procedure_Call_Statement
(Loc
,
8412 Name
=> New_Occurrence_Of
(Typ
, Loc
),
8413 Parameter_Associations
=> New_List
(Expression
(N
))));
8416 end Expand_N_Delay_Until_Statement
;
8418 -------------------------
8419 -- Expand_N_Entry_Body --
8420 -------------------------
8422 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
8424 -- Associate discriminals with the next protected operation body to be
8427 if Present
(Next_Protected_Operation
(N
)) then
8428 Set_Discriminals
(Parent
(Current_Scope
));
8430 end Expand_N_Entry_Body
;
8432 -----------------------------------
8433 -- Expand_N_Entry_Call_Statement --
8434 -----------------------------------
8436 -- An entry call is expanded into GNARLI calls to implement a simple entry
8437 -- call (see Build_Simple_Entry_Call).
8439 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
8445 if No_Run_Time_Mode
then
8446 Error_Msg_CRT
("entry call", N
);
8450 -- If this entry call is part of an asynchronous select, don't expand it
8451 -- here; it will be expanded with the select statement. Don't expand
8452 -- timed entry calls either, as they are translated into asynchronous
8455 -- ??? This whole approach is questionable; it may be better to go back
8456 -- to allowing the expansion to take place and then attempting to fix it
8457 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8458 -- whether the expanded call is on a task or protected entry.
8460 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
8461 or else N
/= Triggering_Statement
(Parent
(N
)))
8462 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8463 or else N
/= Entry_Call_Statement
(Parent
(N
))
8464 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8466 Extract_Entry
(N
, Concval
, Ename
, Index
);
8467 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8469 end Expand_N_Entry_Call_Statement
;
8471 --------------------------------
8472 -- Expand_N_Entry_Declaration --
8473 --------------------------------
8475 -- If there are parameters, then first, each of the formals is marked by
8476 -- setting Is_Entry_Formal. Next a record type is built which is used to
8477 -- hold the parameter values. The name of this record type is entryP where
8478 -- entry is the name of the entry, with an additional corresponding access
8479 -- type called entryPA. The record type has matching components for each
8480 -- formal (the component names are the same as the formal names). For
8481 -- elementary types, the component type matches the formal type. For
8482 -- composite types, an access type is declared (with the name formalA)
8483 -- which designates the formal type, and the type of the component is this
8484 -- access type. Finally the Entry_Component of each formal is set to
8485 -- reference the corresponding record component.
8487 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8488 Loc
: constant Source_Ptr
:= Sloc
(N
);
8489 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8490 Components
: List_Id
;
8493 Last_Decl
: Node_Id
;
8494 Component
: Entity_Id
;
8497 Rec_Ent
: Entity_Id
;
8498 Acc_Ent
: Entity_Id
;
8501 Formal
:= First_Formal
(Entry_Ent
);
8504 -- Most processing is done only if parameters are present
8506 if Present
(Formal
) then
8507 Components
:= New_List
;
8509 -- Loop through formals
8511 while Present
(Formal
) loop
8512 Set_Is_Entry_Formal
(Formal
);
8514 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8515 Set_Entry_Component
(Formal
, Component
);
8516 Set_Entry_Formal
(Component
, Formal
);
8517 Ftype
:= Etype
(Formal
);
8519 -- Declare new access type and then append
8521 Ctype
:= Make_Temporary
(Loc
, 'A');
8522 Set_Is_Param_Block_Component_Type
(Ctype
);
8525 Make_Full_Type_Declaration
(Loc
,
8526 Defining_Identifier
=> Ctype
,
8528 Make_Access_To_Object_Definition
(Loc
,
8529 All_Present
=> True,
8530 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8531 Subtype_Indication
=> New_Occurrence_Of
(Ftype
, Loc
)));
8533 Insert_After
(Last_Decl
, Decl
);
8536 Append_To
(Components
,
8537 Make_Component_Declaration
(Loc
,
8538 Defining_Identifier
=> Component
,
8539 Component_Definition
=>
8540 Make_Component_Definition
(Loc
,
8541 Aliased_Present
=> False,
8542 Subtype_Indication
=> New_Occurrence_Of
(Ctype
, Loc
))));
8544 Next_Formal_With_Extras
(Formal
);
8547 -- Create the Entry_Parameter_Record declaration
8549 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8552 Make_Full_Type_Declaration
(Loc
,
8553 Defining_Identifier
=> Rec_Ent
,
8555 Make_Record_Definition
(Loc
,
8557 Make_Component_List
(Loc
,
8558 Component_Items
=> Components
)));
8560 Insert_After
(Last_Decl
, Decl
);
8563 -- Construct and link in the corresponding access type
8565 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8567 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8570 Make_Full_Type_Declaration
(Loc
,
8571 Defining_Identifier
=> Acc_Ent
,
8573 Make_Access_To_Object_Definition
(Loc
,
8574 All_Present
=> True,
8575 Subtype_Indication
=> New_Occurrence_Of
(Rec_Ent
, Loc
)));
8577 Insert_After
(Last_Decl
, Decl
);
8579 end Expand_N_Entry_Declaration
;
8581 -----------------------------
8582 -- Expand_N_Protected_Body --
8583 -----------------------------
8585 -- Protected bodies are expanded to the completion of the subprograms
8586 -- created for the corresponding protected type. These are a protected and
8587 -- unprotected version of each protected subprogram in the object, a
8588 -- function to calculate each entry barrier, and a procedure to execute the
8589 -- sequence of statements of each protected entry body. For example, for
8590 -- protected type ptype:
8593 -- (O : System.Address;
8594 -- E : Protected_Entry_Index)
8597 -- <discriminant renamings>
8598 -- <private object renamings>
8600 -- return <barrier expression>;
8603 -- procedure pprocN (_object : in out poV;...) is
8604 -- <discriminant renamings>
8605 -- <private object renamings>
8607 -- <sequence of statements>
8610 -- procedure pprocP (_object : in out poV;...) is
8611 -- procedure _clean is
8614 -- ptypeS (_object, Pn);
8615 -- Unlock (_object._object'Access);
8616 -- Abort_Undefer.all;
8621 -- Lock (_object._object'Access);
8622 -- pprocN (_object;...);
8627 -- function pfuncN (_object : poV;...) return Return_Type is
8628 -- <discriminant renamings>
8629 -- <private object renamings>
8631 -- <sequence of statements>
8634 -- function pfuncP (_object : poV) return Return_Type is
8635 -- procedure _clean is
8637 -- Unlock (_object._object'Access);
8638 -- Abort_Undefer.all;
8643 -- Lock (_object._object'Access);
8644 -- return pfuncN (_object);
8651 -- (O : System.Address;
8652 -- P : System.Address;
8653 -- E : Protected_Entry_Index)
8655 -- <discriminant renamings>
8656 -- <private object renamings>
8657 -- type poVP is access poV;
8658 -- _Object : ptVP := ptVP!(O);
8662 -- <statement sequence>
8663 -- Complete_Entry_Body (_Object._Object);
8665 -- when all others =>
8666 -- Exceptional_Complete_Entry_Body (
8667 -- _Object._Object, Get_GNAT_Exception);
8671 -- The type poV is the record created for the protected type to hold
8672 -- the state of the protected object.
8674 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8675 Loc
: constant Source_Ptr
:= Sloc
(N
);
8676 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8678 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8679 -- This flag indicates whether the lock free implementation is active
8681 Current_Node
: Node_Id
;
8682 Disp_Op_Body
: Node_Id
;
8683 New_Op_Body
: Node_Id
;
8687 function Build_Dispatching_Subprogram_Body
8690 Prot_Bod
: Node_Id
) return Node_Id
;
8691 -- Build a dispatching version of the protected subprogram body. The
8692 -- newly generated subprogram contains a call to the original protected
8693 -- body. The following code is generated:
8695 -- function <protected-function-name> (Param1 .. ParamN) return
8698 -- return <protected-function-name>P (Param1 .. ParamN);
8699 -- end <protected-function-name>;
8703 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8705 -- <protected-procedure-name>P (Param1 .. ParamN);
8706 -- end <protected-procedure-name>
8708 ---------------------------------------
8709 -- Build_Dispatching_Subprogram_Body --
8710 ---------------------------------------
8712 function Build_Dispatching_Subprogram_Body
8715 Prot_Bod
: Node_Id
) return Node_Id
8717 Loc
: constant Source_Ptr
:= Sloc
(N
);
8724 -- Generate a specification without a letter suffix in order to
8725 -- override an interface function or procedure.
8727 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8729 -- The formal parameters become the actuals of the protected function
8730 -- or procedure call.
8732 Actuals
:= New_List
;
8733 Formal
:= First
(Parameter_Specifications
(Spec
));
8734 while Present
(Formal
) loop
8736 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8740 if Nkind
(Spec
) = N_Procedure_Specification
then
8743 Make_Procedure_Call_Statement
(Loc
,
8745 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8746 Parameter_Associations
=> Actuals
));
8749 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8753 Make_Simple_Return_Statement
(Loc
,
8755 Make_Function_Call
(Loc
,
8757 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8758 Parameter_Associations
=> Actuals
)));
8762 Make_Subprogram_Body
(Loc
,
8763 Declarations
=> Empty_List
,
8764 Specification
=> Spec
,
8765 Handled_Statement_Sequence
=>
8766 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8767 end Build_Dispatching_Subprogram_Body
;
8769 -- Start of processing for Expand_N_Protected_Body
8772 if No_Run_Time_Mode
then
8773 Error_Msg_CRT
("protected body", N
);
8777 -- This is the proper body corresponding to a stub. The declarations
8778 -- must be inserted at the point of the stub, which in turn is in the
8779 -- declarative part of the parent unit.
8781 if Nkind
(Parent
(N
)) = N_Subunit
then
8782 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8787 Op_Body
:= First
(Declarations
(N
));
8789 -- The protected body is replaced with the bodies of its
8790 -- protected operations, and the declarations for internal objects
8791 -- that may have been created for entry family bounds.
8793 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8796 while Present
(Op_Body
) loop
8797 case Nkind
(Op_Body
) is
8798 when N_Subprogram_Declaration
=>
8801 when N_Subprogram_Body
=>
8803 -- Do not create bodies for eliminated operations
8805 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8806 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8808 if Lock_Free_Active
then
8810 Build_Lock_Free_Unprotected_Subprogram_Body
8814 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8817 Insert_After
(Current_Node
, New_Op_Body
);
8818 Current_Node
:= New_Op_Body
;
8819 Analyze
(New_Op_Body
);
8821 -- Build the corresponding protected operation. It may
8822 -- appear that this is needed only if this is a visible
8823 -- operation of the type, or if it is an interrupt handler,
8824 -- and this was the strategy used previously in GNAT.
8826 -- However, the operation may be exported through a 'Access
8827 -- to an external caller. This is the common idiom in code
8828 -- that uses the Ada 2005 Timing_Events package. As a result
8829 -- we need to produce the protected body for both visible
8830 -- and private operations, as well as operations that only
8831 -- have a body in the source, and for which we create a
8832 -- declaration in the protected body itself.
8834 if Present
(Corresponding_Spec
(Op_Body
)) then
8835 if Lock_Free_Active
then
8837 Build_Lock_Free_Protected_Subprogram_Body
8838 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8841 Build_Protected_Subprogram_Body
8842 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8845 Insert_After
(Current_Node
, New_Op_Body
);
8846 Analyze
(New_Op_Body
);
8848 Current_Node
:= New_Op_Body
;
8850 -- Generate an overriding primitive operation body for
8851 -- this subprogram if the protected type implements an
8854 if Ada_Version
>= Ada_2005
8856 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
8859 Build_Dispatching_Subprogram_Body
8860 (Op_Body
, Pid
, New_Op_Body
);
8862 Insert_After
(Current_Node
, Disp_Op_Body
);
8863 Analyze
(Disp_Op_Body
);
8865 Current_Node
:= Disp_Op_Body
;
8870 when N_Entry_Body
=>
8871 Op_Id
:= Defining_Identifier
(Op_Body
);
8872 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8874 Insert_After
(Current_Node
, New_Op_Body
);
8875 Current_Node
:= New_Op_Body
;
8876 Analyze
(New_Op_Body
);
8878 when N_Implicit_Label_Declaration
=>
8881 when N_Itype_Reference
=>
8882 Insert_After
(Current_Node
, New_Copy
(Op_Body
));
8884 when N_Freeze_Entity
=>
8885 New_Op_Body
:= New_Copy
(Op_Body
);
8887 if Present
(Entity
(Op_Body
))
8888 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8890 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8893 Insert_After
(Current_Node
, New_Op_Body
);
8894 Current_Node
:= New_Op_Body
;
8895 Analyze
(New_Op_Body
);
8898 New_Op_Body
:= New_Copy
(Op_Body
);
8899 Insert_After
(Current_Node
, New_Op_Body
);
8900 Current_Node
:= New_Op_Body
;
8901 Analyze
(New_Op_Body
);
8903 when N_Object_Declaration
=>
8904 pragma Assert
(not Comes_From_Source
(Op_Body
));
8905 New_Op_Body
:= New_Copy
(Op_Body
);
8906 Insert_After
(Current_Node
, New_Op_Body
);
8907 Current_Node
:= New_Op_Body
;
8908 Analyze
(New_Op_Body
);
8911 raise Program_Error
;
8918 -- Finally, create the body of the function that maps an entry index
8919 -- into the corresponding body index, except when there is no entry, or
8920 -- in a Ravenscar-like profile.
8922 if Corresponding_Runtime_Package
(Pid
) =
8923 System_Tasking_Protected_Objects_Entries
8925 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8926 Insert_After
(Current_Node
, New_Op_Body
);
8927 Current_Node
:= New_Op_Body
;
8928 Analyze
(New_Op_Body
);
8931 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8932 -- protected body. At this point all wrapper specs have been created,
8933 -- frozen and included in the dispatch table for the protected type.
8935 if Ada_Version
>= Ada_2005
then
8936 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8938 end Expand_N_Protected_Body
;
8940 -----------------------------------------
8941 -- Expand_N_Protected_Type_Declaration --
8942 -----------------------------------------
8944 -- First we create a corresponding record type declaration used to
8945 -- represent values of this protected type.
8946 -- The general form of this type declaration is
8948 -- type poV (discriminants) is record
8949 -- _Object : aliased <kind>Protection
8950 -- [(<entry count> [, <handler count>])];
8951 -- [entry_family : array (bounds) of Void;]
8952 -- <private data fields>
8955 -- The discriminants are present only if the corresponding protected type
8956 -- has discriminants, and they exactly mirror the protected type
8957 -- discriminants. The private data fields similarly mirror the private
8958 -- declarations of the protected type.
8960 -- The Object field is always present. It contains RTS specific data used
8961 -- to control the protected object. It is declared as Aliased so that it
8962 -- can be passed as a pointer to the RTS. This allows the protected record
8963 -- to be referenced within RTS data structures. An appropriate Protection
8964 -- type and discriminant are generated.
8966 -- The Service field is present for protected objects with entries. It
8967 -- contains sufficient information to allow the entry service procedure for
8968 -- this object to be called when the object is not known till runtime.
8970 -- One entry_family component is present for each entry family in the
8971 -- task definition (see Expand_N_Task_Type_Declaration).
8973 -- When a protected object is declared, an instance of the protected type
8974 -- value record is created. The elaboration of this declaration creates the
8975 -- correct bounds for the entry families, and also evaluates the priority
8976 -- expression if needed. The initialization routine for the protected type
8977 -- itself then calls Initialize_Protection with appropriate parameters to
8978 -- initialize the value of the Task_Id field. Install_Handlers may be also
8979 -- called if a pragma Attach_Handler applies.
8981 -- Note: this record is passed to the subprograms created by the expansion
8982 -- of protected subprograms and entries. It is an in parameter to protected
8983 -- functions and an in out parameter to procedures and entry bodies. The
8984 -- Entity_Id for this created record type is placed in the
8985 -- Corresponding_Record_Type field of the associated protected type entity.
8987 -- Next we create a procedure specifications for protected subprograms and
8988 -- entry bodies. For each protected subprograms two subprograms are
8989 -- created, an unprotected and a protected version. The unprotected version
8990 -- is called from within other operations of the same protected object.
8992 -- We also build the call to register the procedure if a pragma
8993 -- Interrupt_Handler applies.
8995 -- A single subprogram is created to service all entry bodies; it has an
8996 -- additional boolean out parameter indicating that the previous entry call
8997 -- made by the current task was serviced immediately, i.e. not by proxy.
8998 -- The O parameter contains a pointer to a record object of the type
8999 -- described above. An untyped interface is used here to allow this
9000 -- procedure to be called in places where the type of the object to be
9001 -- serviced is not known. This must be done, for example, when a call that
9002 -- may have been requeued is cancelled; the corresponding object must be
9003 -- serviced, but which object that is not known till runtime.
9006 -- (O : System.Address; P : out Boolean);
9007 -- procedure pprocN (_object : in out poV);
9008 -- procedure pproc (_object : in out poV);
9009 -- function pfuncN (_object : poV);
9010 -- function pfunc (_object : poV);
9013 -- Note that this must come after the record type declaration, since
9014 -- the specs refer to this type.
9016 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
9017 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
9018 Loc
: constant Source_Ptr
:= Sloc
(N
);
9019 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
9021 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
9022 -- This flag indicates whether the lock free implementation is active
9024 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
9025 -- This contains two lists; one for visible and one for private decls
9028 Body_Id
: Entity_Id
;
9031 Current_Node
: Node_Id
:= N
;
9033 Entries_Aggr
: Node_Id
;
9035 Object_Comp
: Node_Id
;
9039 procedure Check_Inlining
(Subp
: Entity_Id
);
9040 -- If the original operation has a pragma Inline, propagate the flag
9041 -- to the internal body, for possible inlining later on. The source
9042 -- operation is invisible to the back-end and is never actually called.
9044 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean;
9045 -- If a component size is not static then a warning will be emitted
9046 -- in Ravenscar or other restricted contexts. When a component is non-
9047 -- static because of a discriminant constraint we can specialize the
9048 -- warning by mentioning discriminants explicitly.
9050 procedure Expand_Entry_Declaration
(Decl
: Node_Id
);
9051 -- Create the entry barrier and the procedure body for entry declaration
9052 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
9054 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
9055 -- When compiling under the Ravenscar profile, private components must
9056 -- have a static size, or else a protected object will require heap
9057 -- allocation, violating the corresponding restriction. It is preferable
9058 -- to make this check here, because it provides a better error message
9059 -- than the back-end, which refers to the object as a whole.
9061 procedure Register_Handler
;
9062 -- For a protected operation that is an interrupt handler, add the
9063 -- freeze action that will register it as such.
9065 --------------------
9066 -- Check_Inlining --
9067 --------------------
9069 procedure Check_Inlining
(Subp
: Entity_Id
) is
9071 if Is_Inlined
(Subp
) then
9072 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
9073 Set_Is_Inlined
(Subp
, False);
9077 ------------------------
9078 -- Discriminated_Size --
9079 ------------------------
9081 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
9082 Typ
: constant Entity_Id
:= Etype
(Comp
);
9085 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
9086 -- Check whether the bound of an index is non-static and does denote
9087 -- a discriminant, in which case any protected object of the type
9088 -- will have a non-static size.
9090 ----------------------
9091 -- Non_Static_Bound --
9092 ----------------------
9094 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
9096 if Is_OK_Static_Expression
(Bound
) then
9099 elsif Is_Entity_Name
(Bound
)
9100 and then Present
(Discriminal_Link
(Entity
(Bound
)))
9107 end Non_Static_Bound
;
9109 -- Start of processing for Discriminated_Size
9112 if not Is_Array_Type
(Typ
) then
9116 if Ekind
(Typ
) = E_Array_Subtype
then
9117 Index
:= First_Index
(Typ
);
9118 while Present
(Index
) loop
9119 if Non_Static_Bound
(Low_Bound
(Index
))
9120 or else Non_Static_Bound
(High_Bound
(Index
))
9132 end Discriminated_Size
;
9134 ---------------------------
9135 -- Static_Component_Size --
9136 ---------------------------
9138 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
9139 Typ
: constant Entity_Id
:= Etype
(Comp
);
9143 if Is_Scalar_Type
(Typ
) then
9146 elsif Is_Array_Type
(Typ
) then
9147 return Compile_Time_Known_Bounds
(Typ
);
9149 elsif Is_Record_Type
(Typ
) then
9150 C
:= First_Component
(Typ
);
9151 while Present
(C
) loop
9152 if not Static_Component_Size
(C
) then
9161 -- Any other type will be checked by the back-end
9166 end Static_Component_Size
;
9168 ------------------------------
9169 -- Expand_Entry_Declaration --
9170 ------------------------------
9172 procedure Expand_Entry_Declaration
(Decl
: Node_Id
) is
9173 Ent_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
9179 E_Count
:= E_Count
+ 1;
9181 -- Create the protected body subprogram
9184 Make_Defining_Identifier
(Loc
,
9185 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'E'));
9186 Set_Protected_Body_Subprogram
(Ent_Id
, Bod_Id
);
9189 Make_Subprogram_Declaration
(Loc
,
9191 Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Ent_Id
));
9193 Insert_After
(Current_Node
, Subp
);
9194 Current_Node
:= Subp
;
9198 -- Build a wrapper procedure to handle contract cases, preconditions,
9199 -- and postconditions.
9201 Build_Contract_Wrapper
(Ent_Id
, N
);
9203 -- Create the barrier function
9206 Make_Defining_Identifier
(Loc
,
9207 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'B'));
9208 Set_Barrier_Function
(Ent_Id
, Bar_Id
);
9211 Make_Subprogram_Declaration
(Loc
,
9213 Build_Barrier_Function_Specification
(Loc
, Bar_Id
));
9214 Set_Is_Entry_Barrier_Function
(Subp
);
9216 Insert_After
(Current_Node
, Subp
);
9217 Current_Node
:= Subp
;
9221 Set_Protected_Body_Subprogram
(Bar_Id
, Bar_Id
);
9222 Set_Scope
(Bar_Id
, Scope
(Ent_Id
));
9224 -- Collect pointers to the protected subprogram and the barrier
9225 -- of the current entry, for insertion into Entry_Bodies_Array.
9227 Append_To
(Expressions
(Entries_Aggr
),
9228 Make_Aggregate
(Loc
,
9229 Expressions
=> New_List
(
9230 Make_Attribute_Reference
(Loc
,
9231 Prefix
=> New_Occurrence_Of
(Bar_Id
, Loc
),
9232 Attribute_Name
=> Name_Unrestricted_Access
),
9233 Make_Attribute_Reference
(Loc
,
9234 Prefix
=> New_Occurrence_Of
(Bod_Id
, Loc
),
9235 Attribute_Name
=> Name_Unrestricted_Access
))));
9236 end Expand_Entry_Declaration
;
9238 ----------------------
9239 -- Register_Handler --
9240 ----------------------
9242 procedure Register_Handler
is
9244 -- All semantic checks already done in Sem_Prag
9246 Prot_Proc
: constant Entity_Id
:=
9247 Defining_Unit_Name
(Specification
(Current_Node
));
9249 Proc_Address
: constant Node_Id
:=
9250 Make_Attribute_Reference
(Loc
,
9252 New_Occurrence_Of
(Prot_Proc
, Loc
),
9253 Attribute_Name
=> Name_Address
);
9255 RTS_Call
: constant Entity_Id
:=
9256 Make_Procedure_Call_Statement
(Loc
,
9259 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
9260 Parameter_Associations
=> New_List
(Proc_Address
));
9262 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
9263 end Register_Handler
;
9269 -- Start of processing for Expand_N_Protected_Type_Declaration
9272 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
9275 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
9278 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
9280 Qualify_Entity_Names
(N
);
9282 -- If the type has discriminants, their occurrences in the declaration
9283 -- have been replaced by the corresponding discriminals. For components
9284 -- that are constrained by discriminants, their homologues in the
9285 -- corresponding record type must refer to the discriminants of that
9286 -- record, so we must apply a new renaming to subtypes_indications:
9288 -- protected discriminant => discriminal => record discriminant
9290 -- This replacement is not applied to default expressions, for which
9291 -- the discriminal is correct.
9293 if Has_Discriminants
(Prot_Typ
) then
9299 Disc
:= First_Discriminant
(Prot_Typ
);
9300 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
9301 while Present
(Disc
) loop
9302 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
9303 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
9304 Next_Discriminant
(Disc
);
9310 -- Fill in the component declarations
9312 -- Add components for entry families. For each entry family, create an
9313 -- anonymous type declaration with the same size, and analyze the type.
9315 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
9317 pragma Assert
(Present
(Pdef
));
9319 -- Add private field components
9321 if Present
(Private_Declarations
(Pdef
)) then
9322 Priv
:= First
(Private_Declarations
(Pdef
));
9323 while Present
(Priv
) loop
9324 if Nkind
(Priv
) = N_Component_Declaration
then
9325 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
9327 -- When compiling for a restricted profile, the private
9328 -- components must have a static size. If not, this is an
9329 -- error for a single protected declaration, and rates a
9330 -- warning on a protected type declaration.
9332 if not Comes_From_Source
(Prot_Typ
) then
9334 -- It's ok to be checking this restriction at expansion
9335 -- time, because this is only for the restricted profile,
9336 -- which is not subject to strict RM conformance, so it
9337 -- is OK to miss this check in -gnatc mode.
9339 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
9341 (No_Implicit_Protected_Object_Allocations
, Priv
);
9343 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
9344 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9346 -- Any object of the type will be non-static.
9348 Error_Msg_N
("component has non-static size??", Priv
);
9350 ("\creation of protected object of type& will "
9351 & "violate restriction "
9352 & "No_Implicit_Heap_Allocations??", Priv
, Prot_Typ
);
9355 -- Object will be non-static if discriminants are.
9358 ("creation of protected object of type& with "
9359 & "non-static discriminants will violate"
9360 & " restriction No_Implicit_Heap_Allocations??",
9364 -- Likewise for No_Implicit_Protected_Object_Allocations
9366 elsif Restriction_Active
9367 (No_Implicit_Protected_Object_Allocations
)
9369 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9371 -- Any object of the type will be non-static.
9373 Error_Msg_N
("component has non-static size??", Priv
);
9375 ("\creation of protected object of type& will "
9376 & "violate restriction "
9377 & "No_Implicit_Protected_Object_Allocations??",
9380 -- Object will be non-static if discriminants are.
9383 ("creation of protected object of type& with "
9384 & "non-static discriminants will violate "
9386 & "No_Implicit_Protected_Object_Allocations??",
9392 -- The component definition consists of a subtype indication,
9393 -- or (in Ada 2005) an access definition. Make a copy of the
9394 -- proper definition.
9397 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
9398 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
9399 Nent
: constant Entity_Id
:=
9400 Make_Defining_Identifier
(Sloc
(Oent
),
9401 Chars
=> Chars
(Oent
));
9405 if Present
(Subtype_Indication
(Old_Comp
)) then
9407 Make_Component_Definition
(Sloc
(Oent
),
9408 Aliased_Present
=> False,
9409 Subtype_Indication
=>
9411 (Subtype_Indication
(Old_Comp
), Discr_Map
));
9414 Make_Component_Definition
(Sloc
(Oent
),
9415 Aliased_Present
=> False,
9416 Access_Definition
=>
9418 (Access_Definition
(Old_Comp
), Discr_Map
));
9422 Make_Component_Declaration
(Loc
,
9423 Defining_Identifier
=> Nent
,
9424 Component_Definition
=> New_Comp
,
9425 Expression
=> Expression
(Priv
));
9427 Set_Has_Per_Object_Constraint
(Nent
,
9428 Has_Per_Object_Constraint
(Oent
));
9430 Append_To
(Cdecls
, New_Priv
);
9433 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
9435 -- Make the unprotected version of the subprogram available
9436 -- for expansion of intra object calls. There is need for
9437 -- a protected version only if the subprogram is an interrupt
9438 -- handler, otherwise this operation can only be called from
9442 Make_Subprogram_Declaration
(Loc
,
9444 Build_Protected_Sub_Specification
9445 (Priv
, Prot_Typ
, Unprotected_Mode
));
9447 Insert_After
(Current_Node
, Sub
);
9450 Set_Protected_Body_Subprogram
9451 (Defining_Unit_Name
(Specification
(Priv
)),
9452 Defining_Unit_Name
(Specification
(Sub
)));
9453 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
9454 Current_Node
:= Sub
;
9457 Make_Subprogram_Declaration
(Loc
,
9459 Build_Protected_Sub_Specification
9460 (Priv
, Prot_Typ
, Protected_Mode
));
9462 Insert_After
(Current_Node
, Sub
);
9464 Current_Node
:= Sub
;
9466 if Is_Interrupt_Handler
9467 (Defining_Unit_Name
(Specification
(Priv
)))
9469 if not Restricted_Profile
then
9479 -- Except for the lock-free implementation, append the _Object field
9480 -- with the right type to the component list. We need to compute the
9481 -- number of entries, and in some cases the number of Attach_Handler
9484 if not Lock_Free_Active
then
9486 Entry_Count_Expr
: constant Node_Id
:=
9487 Build_Entry_Count_Expression
9488 (Prot_Typ
, Cdecls
, Loc
);
9489 Num_Attach_Handler
: Nat
:= 0;
9490 Protection_Subtype
: Node_Id
;
9494 if Has_Attach_Handler
(Prot_Typ
) then
9495 Ritem
:= First_Rep_Item
(Prot_Typ
);
9496 while Present
(Ritem
) loop
9497 if Nkind
(Ritem
) = N_Pragma
9498 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
9500 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
9503 Next_Rep_Item
(Ritem
);
9507 -- Determine the proper protection type. There are two special
9508 -- cases: 1) when the protected type has dynamic interrupt
9509 -- handlers, and 2) when it has static handlers and we use a
9510 -- restricted profile.
9512 if Has_Attach_Handler
(Prot_Typ
)
9513 and then not Restricted_Profile
9515 Protection_Subtype
:=
9516 Make_Subtype_Indication
(Loc
,
9519 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
9521 Make_Index_Or_Discriminant_Constraint
(Loc
,
9522 Constraints
=> New_List
(
9524 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
9526 elsif Has_Interrupt_Handler
(Prot_Typ
)
9527 and then not Restriction_Active
(No_Dynamic_Attachment
)
9529 Protection_Subtype
:=
9530 Make_Subtype_Indication
(Loc
,
9533 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
9535 Make_Index_Or_Discriminant_Constraint
(Loc
,
9536 Constraints
=> New_List
(Entry_Count_Expr
)));
9539 case Corresponding_Runtime_Package
(Prot_Typ
) is
9540 when System_Tasking_Protected_Objects_Entries
=>
9541 Protection_Subtype
:=
9542 Make_Subtype_Indication
(Loc
,
9545 (RTE
(RE_Protection_Entries
), Loc
),
9547 Make_Index_Or_Discriminant_Constraint
(Loc
,
9548 Constraints
=> New_List
(Entry_Count_Expr
)));
9550 when System_Tasking_Protected_Objects_Single_Entry
=>
9551 Protection_Subtype
:=
9552 New_Occurrence_Of
(RTE
(RE_Protection_Entry
), Loc
);
9554 when System_Tasking_Protected_Objects
=>
9555 Protection_Subtype
:=
9556 New_Occurrence_Of
(RTE
(RE_Protection
), Loc
);
9559 raise Program_Error
;
9564 Make_Component_Declaration
(Loc
,
9565 Defining_Identifier
=>
9566 Make_Defining_Identifier
(Loc
, Name_uObject
),
9567 Component_Definition
=>
9568 Make_Component_Definition
(Loc
,
9569 Aliased_Present
=> True,
9570 Subtype_Indication
=> Protection_Subtype
));
9573 -- Put the _Object component after the private component so that it
9574 -- be finalized early as required by 9.4 (20)
9576 Append_To
(Cdecls
, Object_Comp
);
9579 Insert_After
(Current_Node
, Rec_Decl
);
9580 Current_Node
:= Rec_Decl
;
9582 -- Analyze the record declaration immediately after construction,
9583 -- because the initialization procedure is needed for single object
9584 -- declarations before the next entity is analyzed (the freeze call
9585 -- that generates this initialization procedure is found below).
9587 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
9589 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9590 -- the corresponding record is frozen. If any wrappers are generated,
9591 -- Current_Node is updated accordingly.
9593 if Ada_Version
>= Ada_2005
then
9594 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
9597 -- Collect pointers to entry bodies and their barriers, to be placed
9598 -- in the Entry_Bodies_Array for the type. For each entry/family we
9599 -- add an expression to the aggregate which is the initial value of
9600 -- this array. The array is declared after all protected subprograms.
9602 if Has_Entries
(Prot_Typ
) then
9603 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
9605 Entries_Aggr
:= Empty
;
9608 -- Build two new procedure specifications for each protected subprogram;
9609 -- one to call from outside the object and one to call from inside.
9610 -- Build a barrier function and an entry body action procedure
9611 -- specification for each protected entry. Initialize the entry body
9612 -- array. If subprogram is flagged as eliminated, do not generate any
9613 -- internal operations.
9616 Comp
:= First
(Visible_Declarations
(Pdef
));
9617 while Present
(Comp
) loop
9618 if Nkind
(Comp
) = N_Subprogram_Declaration
then
9620 Make_Subprogram_Declaration
(Loc
,
9622 Build_Protected_Sub_Specification
9623 (Comp
, Prot_Typ
, Unprotected_Mode
));
9625 Insert_After
(Current_Node
, Sub
);
9628 Set_Protected_Body_Subprogram
9629 (Defining_Unit_Name
(Specification
(Comp
)),
9630 Defining_Unit_Name
(Specification
(Sub
)));
9631 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
9633 -- Make the protected version of the subprogram available for
9634 -- expansion of external calls.
9636 Current_Node
:= Sub
;
9639 Make_Subprogram_Declaration
(Loc
,
9641 Build_Protected_Sub_Specification
9642 (Comp
, Prot_Typ
, Protected_Mode
));
9644 Insert_After
(Current_Node
, Sub
);
9647 Current_Node
:= Sub
;
9649 -- Generate an overriding primitive operation specification for
9650 -- this subprogram if the protected type implements an interface
9651 -- and Build_Wrapper_Spec did not not generate its wrapper.
9653 if Ada_Version
>= Ada_2005
9655 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9658 Found
: Boolean := False;
9659 Prim_Elmt
: Elmt_Id
;
9665 (Primitive_Operations
9666 (Corresponding_Record_Type
(Prot_Typ
)));
9668 while Present
(Prim_Elmt
) loop
9669 Prim_Op
:= Node
(Prim_Elmt
);
9671 if Is_Primitive_Wrapper
(Prim_Op
)
9672 and then Wrapped_Entity
(Prim_Op
) =
9673 Defining_Entity
(Specification
(Comp
))
9679 Next_Elmt
(Prim_Elmt
);
9684 Make_Subprogram_Declaration
(Loc
,
9686 Build_Protected_Sub_Specification
9687 (Comp
, Prot_Typ
, Dispatching_Mode
));
9689 Insert_After
(Current_Node
, Sub
);
9692 Current_Node
:= Sub
;
9697 -- If a pragma Interrupt_Handler applies, build and add a call to
9698 -- Register_Interrupt_Handler to the freezing actions of the
9699 -- protected version (Current_Node) of the subprogram:
9701 -- system.interrupts.register_interrupt_handler
9702 -- (prot_procP'address);
9704 if not Restricted_Profile
9705 and then Is_Interrupt_Handler
9706 (Defining_Unit_Name
(Specification
(Comp
)))
9711 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9712 Expand_Entry_Declaration
(Comp
);
9718 -- If there are some private entry declarations, expand it as if they
9719 -- were visible entries.
9721 if Present
(Private_Declarations
(Pdef
)) then
9722 Comp
:= First
(Private_Declarations
(Pdef
));
9723 while Present
(Comp
) loop
9724 if Nkind
(Comp
) = N_Entry_Declaration
then
9725 Expand_Entry_Declaration
(Comp
);
9732 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9733 -- all protected subprograms have been collected.
9735 if Has_Entries
(Prot_Typ
) then
9737 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9738 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9740 case Corresponding_Runtime_Package
(Prot_Typ
) is
9741 when System_Tasking_Protected_Objects_Entries
=>
9743 Make_Object_Declaration
(Loc
,
9744 Defining_Identifier
=> Body_Id
,
9745 Aliased_Present
=> True,
9746 Object_Definition
=>
9747 Make_Subtype_Indication
(Loc
,
9750 (RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9752 Make_Index_Or_Discriminant_Constraint
(Loc
,
9753 Constraints
=> New_List
(
9755 Make_Integer_Literal
(Loc
, 1),
9756 Make_Integer_Literal
(Loc
, E_Count
))))),
9757 Expression
=> Entries_Aggr
);
9759 when System_Tasking_Protected_Objects_Single_Entry
=>
9761 Make_Object_Declaration
(Loc
,
9762 Defining_Identifier
=> Body_Id
,
9763 Aliased_Present
=> True,
9764 Object_Definition
=>
9765 New_Occurrence_Of
(RTE
(RE_Entry_Body
), Loc
),
9767 Remove_Head
(Expressions
(Entries_Aggr
)));
9770 raise Program_Error
;
9773 -- A pointer to this array will be placed in the corresponding record
9774 -- by its initialization procedure so this needs to be analyzed here.
9776 Insert_After
(Current_Node
, Body_Arr
);
9777 Current_Node
:= Body_Arr
;
9780 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9782 -- Finally, build the function that maps an entry index into the
9783 -- corresponding body. A pointer to this function is placed in each
9784 -- object of the type. Except for a ravenscar-like profile (no abort,
9785 -- no entry queue, 1 entry)
9787 if Corresponding_Runtime_Package
(Prot_Typ
) =
9788 System_Tasking_Protected_Objects_Entries
9791 Make_Subprogram_Declaration
(Loc
,
9792 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9793 Insert_After
(Current_Node
, Sub
);
9797 end Expand_N_Protected_Type_Declaration
;
9799 --------------------------------
9800 -- Expand_N_Requeue_Statement --
9801 --------------------------------
9803 -- A non-dispatching requeue statement is expanded into one of four GNARLI
9804 -- operations, depending on the source and destination (task or protected
9805 -- object). A dispatching requeue statement is expanded into a call to the
9806 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9807 -- jump around the remainder of processing for the original entry and, if
9808 -- the destination is (different) protected object, to attempt to service
9809 -- it. The following illustrates the various cases:
9812 -- (O : System.Address;
9813 -- P : System.Address;
9814 -- E : Protected_Entry_Index)
9816 -- <discriminant renamings>
9817 -- <private object renamings>
9818 -- type poVP is access poV;
9819 -- _object : ptVP := ptVP!(O);
9823 -- <start of statement sequence for entry>
9825 -- -- Requeue from one protected entry body to another protected
9828 -- Requeue_Protected_Entry (
9829 -- _object._object'Access,
9830 -- new._object'Access,
9835 -- <some more of the statement sequence for entry>
9837 -- -- Requeue from an entry body to a task entry
9839 -- Requeue_Protected_To_Task_Entry (
9845 -- <rest of statement sequence for entry>
9846 -- Complete_Entry_Body (_object._object);
9849 -- when all others =>
9850 -- Exceptional_Complete_Entry_Body (
9851 -- _object._object, Get_GNAT_Exception);
9855 -- Requeue of a task entry call to a task entry
9857 -- Accept_Call (E, Ann);
9858 -- <start of statement sequence for accept statement>
9859 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9861 -- <rest of statement sequence for accept statement>
9863 -- Complete_Rendezvous;
9866 -- when all others =>
9867 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9869 -- Requeue of a task entry call to a protected entry
9871 -- Accept_Call (E, Ann);
9872 -- <start of statement sequence for accept statement>
9873 -- Requeue_Task_To_Protected_Entry (
9874 -- new._object'Access,
9879 -- <rest of statement sequence for accept statement>
9881 -- Complete_Rendezvous;
9884 -- when all others =>
9885 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9887 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9888 -- marked by pragma Implemented (XXX, By_Entry).
9890 -- The requeue is inside a protected entry:
9893 -- (O : System.Address;
9894 -- P : System.Address;
9895 -- E : Protected_Entry_Index)
9897 -- <discriminant renamings>
9898 -- <private object renamings>
9899 -- type poVP is access poV;
9900 -- _object : ptVP := ptVP!(O);
9904 -- <start of statement sequence for entry>
9907 -- (<interface class-wide object>,
9910 -- Ada.Tags.Get_Offset_Index
9912 -- <interface dispatch table index of target entry>),
9916 -- <rest of statement sequence for entry>
9917 -- Complete_Entry_Body (_object._object);
9920 -- when all others =>
9921 -- Exceptional_Complete_Entry_Body (
9922 -- _object._object, Get_GNAT_Exception);
9926 -- The requeue is inside a task entry:
9928 -- Accept_Call (E, Ann);
9929 -- <start of statement sequence for accept statement>
9931 -- (<interface class-wide object>,
9934 -- Ada.Tags.Get_Offset_Index
9936 -- <interface dispatch table index of target entrt>),
9940 -- <rest of statement sequence for accept statement>
9942 -- Complete_Rendezvous;
9945 -- when all others =>
9946 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9948 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9949 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9950 -- statement is replaced by a dispatching call with actual parameters taken
9951 -- from the inner-most accept statement or entry body.
9953 -- Target.Primitive (Param1, ..., ParamN);
9955 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9956 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9960 -- S : constant Offset_Index :=
9961 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9962 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9965 -- if C = POK_Protected_Entry
9966 -- or else C = POK_Task_Entry
9968 -- <statements for dispatching requeue>
9970 -- elsif C = POK_Protected_Procedure then
9971 -- <dispatching call equivalent>
9974 -- raise Program_Error;
9978 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
9979 Loc
: constant Source_Ptr
:= Sloc
(N
);
9980 Conc_Typ
: Entity_Id
;
9984 Old_Typ
: Entity_Id
;
9986 function Build_Dispatching_Call_Equivalent
return Node_Id
;
9987 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9988 -- the form Concval.Ename. It is statically known that Ename is allowed
9989 -- to be implemented by a protected procedure. Create a dispatching call
9990 -- equivalent of Concval.Ename taking the actual parameters from the
9991 -- inner-most accept statement or entry body.
9993 function Build_Dispatching_Requeue
return Node_Id
;
9994 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9995 -- the form Concval.Ename. It is statically known that Ename is allowed
9996 -- to be implemented by a protected or a task entry. Create a call to
9997 -- primitive _Disp_Requeue which handles the low-level actions.
9999 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
10000 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10001 -- the form Concval.Ename. Ename is either marked by pragma Implemented
10002 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
10003 -- determines at runtime whether Ename denotes an entry or a procedure
10004 -- and perform the appropriate kind of dispatching select.
10006 function Build_Normal_Requeue
return Node_Id
;
10007 -- N denotes a non-dispatching requeue statement to either a task or a
10008 -- protected entry. Build the appropriate runtime call to perform the
10011 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
10012 -- For a protected entry, create a return statement to skip the rest of
10013 -- the entry body. Otherwise, create a goto statement to skip the rest
10014 -- of a task accept statement. The lookup for the enclosing entry body
10015 -- or accept statement starts from Search.
10017 ---------------------------------------
10018 -- Build_Dispatching_Call_Equivalent --
10019 ---------------------------------------
10021 function Build_Dispatching_Call_Equivalent
return Node_Id
is
10022 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10023 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10030 -- Climb the parent chain looking for the inner-most entry body or
10031 -- accept statement.
10034 while Present
(Acc_Ent
)
10035 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
10038 Acc_Ent
:= Parent
(Acc_Ent
);
10041 -- A requeue statement should be housed inside an entry body or an
10042 -- accept statement at some level. If this is not the case, then the
10043 -- tree is malformed.
10045 pragma Assert
(Present
(Acc_Ent
));
10047 -- Recover the list of formal parameters
10049 if Nkind
(Acc_Ent
) = N_Entry_Body
then
10050 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
10053 Formals
:= Parameter_Specifications
(Acc_Ent
);
10055 -- Create the actual parameters for the dispatching call. These are
10056 -- simply copies of the entry body or accept statement formals in the
10057 -- same order as they appear.
10059 Actuals
:= No_List
;
10061 if Present
(Formals
) then
10062 Actuals
:= New_List
;
10063 Formal
:= First
(Formals
);
10064 while Present
(Formal
) loop
10065 Append_To
(Actuals
,
10066 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
10072 -- Obj.Call_Ent (Actuals);
10075 Make_Procedure_Call_Statement
(Loc
,
10077 Make_Selected_Component
(Loc
,
10078 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
10079 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
10081 Parameter_Associations
=> Actuals
);
10082 end Build_Dispatching_Call_Equivalent
;
10084 -------------------------------
10085 -- Build_Dispatching_Requeue --
10086 -------------------------------
10088 function Build_Dispatching_Requeue
return Node_Id
is
10089 Params
: constant List_Id
:= New_List
;
10092 -- Process the "with abort" parameter
10094 Prepend_To
(Params
,
10095 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10097 -- Process the entry wrapper's position in the primary dispatch
10098 -- table parameter. Generate:
10100 -- Ada.Tags.Get_Entry_Index
10101 -- (T => To_Tag_Ptr (Obj'Address).all,
10103 -- Ada.Tags.Get_Offset_Index
10104 -- (Ada.Tags.Tag (Concval),
10105 -- <interface dispatch table position of Ename>));
10107 -- Note that Obj'Address is recursively expanded into a call to
10108 -- Base_Address (Obj).
10110 if Tagged_Type_Expansion
then
10111 Prepend_To
(Params
,
10112 Make_Function_Call
(Loc
,
10113 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10114 Parameter_Associations
=> New_List
(
10116 Make_Explicit_Dereference
(Loc
,
10117 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
10118 Make_Attribute_Reference
(Loc
,
10119 Prefix
=> New_Copy_Tree
(Concval
),
10120 Attribute_Name
=> Name_Address
))),
10122 Make_Function_Call
(Loc
,
10123 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10124 Parameter_Associations
=> New_List
(
10125 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
10126 Make_Integer_Literal
(Loc
,
10127 DT_Position
(Entity
(Ename
))))))));
10132 Prepend_To
(Params
,
10133 Make_Function_Call
(Loc
,
10134 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10135 Parameter_Associations
=> New_List
(
10137 Make_Attribute_Reference
(Loc
,
10139 Attribute_Name
=> Name_Tag
),
10141 Make_Function_Call
(Loc
,
10142 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10144 Parameter_Associations
=> New_List
(
10148 Make_Attribute_Reference
(Loc
,
10150 Attribute_Name
=> Name_Tag
),
10154 Make_Attribute_Reference
(Loc
,
10155 Prefix
=> New_Occurrence_Of
(Etype
(Concval
), Loc
),
10156 Attribute_Name
=> Name_Tag
),
10160 Make_Integer_Literal
(Loc
,
10161 DT_Position
(Entity
(Ename
))))))));
10164 -- Specific actuals for protected to XXX requeue
10166 if Is_Protected_Type
(Old_Typ
) then
10167 Prepend_To
(Params
,
10168 Make_Attribute_Reference
(Loc
, -- _object'Address
10170 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10171 Attribute_Name
=> Name_Address
));
10173 Prepend_To
(Params
, -- True
10174 New_Occurrence_Of
(Standard_True
, Loc
));
10176 -- Specific actuals for task to XXX requeue
10179 pragma Assert
(Is_Task_Type
(Old_Typ
));
10181 Prepend_To
(Params
, -- null
10182 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
10184 Prepend_To
(Params
, -- False
10185 New_Occurrence_Of
(Standard_False
, Loc
));
10188 -- Add the object parameter
10190 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
10193 -- _Disp_Requeue (<Params>);
10195 -- Find entity for Disp_Requeue operation, which belongs to
10196 -- the type and may not be directly visible.
10203 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
10204 while Present
(Elmt
) loop
10206 exit when Chars
(Op
) = Name_uDisp_Requeue
;
10211 Make_Procedure_Call_Statement
(Loc
,
10212 Name
=> New_Occurrence_Of
(Op
, Loc
),
10213 Parameter_Associations
=> Params
);
10215 end Build_Dispatching_Requeue
;
10217 --------------------------------------
10218 -- Build_Dispatching_Requeue_To_Any --
10219 --------------------------------------
10221 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
10222 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10223 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10224 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
10234 -- Dispatch table slot processing, generate:
10237 S
:= Build_S
(Loc
, Decls
);
10239 -- Call kind processing, generate:
10240 -- C : Ada.Tags.Prim_Op_Kind;
10242 C
:= Build_C
(Loc
, Decls
);
10245 -- S := Ada.Tags.Get_Offset_Index
10246 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10248 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10251 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10254 Make_Procedure_Call_Statement
(Loc
,
10256 New_Occurrence_Of
(
10257 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10258 Name_uDisp_Get_Prim_Op_Kind
),
10260 Parameter_Associations
=> New_List
(
10261 New_Copy_Tree
(Obj
),
10262 New_Occurrence_Of
(S
, Loc
),
10263 New_Occurrence_Of
(C
, Loc
))));
10267 -- if C = POK_Protected_Entry
10268 -- or else C = POK_Task_Entry
10271 Make_Implicit_If_Statement
(N
,
10277 New_Occurrence_Of
(C
, Loc
),
10279 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
10284 New_Occurrence_Of
(C
, Loc
),
10286 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
10288 -- Dispatching requeue equivalent
10290 Then_Statements
=> New_List
(
10291 Build_Dispatching_Requeue
,
10294 -- elsif C = POK_Protected_Procedure then
10296 Elsif_Parts
=> New_List
(
10297 Make_Elsif_Part
(Loc
,
10301 New_Occurrence_Of
(C
, Loc
),
10303 New_Occurrence_Of
(
10304 RTE
(RE_POK_Protected_Procedure
), Loc
)),
10306 -- Dispatching call equivalent
10308 Then_Statements
=> New_List
(
10309 Build_Dispatching_Call_Equivalent
))),
10312 -- raise Program_Error;
10315 Else_Statements
=> New_List
(
10316 Make_Raise_Program_Error
(Loc
,
10317 Reason
=> PE_Explicit_Raise
))));
10319 -- Wrap everything into a block
10322 Make_Block_Statement
(Loc
,
10323 Declarations
=> Decls
,
10324 Handled_Statement_Sequence
=>
10325 Make_Handled_Sequence_Of_Statements
(Loc
,
10326 Statements
=> Stmts
));
10327 end Build_Dispatching_Requeue_To_Any
;
10329 --------------------------
10330 -- Build_Normal_Requeue --
10331 --------------------------
10333 function Build_Normal_Requeue
return Node_Id
is
10334 Params
: constant List_Id
:= New_List
;
10339 -- Process the "with abort" parameter
10341 Prepend_To
(Params
,
10342 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10344 -- Add the index expression to the parameters. It is common among all
10347 Prepend_To
(Params
,
10348 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
10350 if Is_Protected_Type
(Old_Typ
) then
10352 Self_Param
: Node_Id
;
10356 Make_Attribute_Reference
(Loc
,
10358 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10360 Name_Unchecked_Access
);
10362 -- Protected to protected requeue
10364 if Is_Protected_Type
(Conc_Typ
) then
10366 New_Occurrence_Of
(
10367 RTE
(RE_Requeue_Protected_Entry
), Loc
);
10370 Make_Attribute_Reference
(Loc
,
10372 Concurrent_Ref
(Concval
),
10374 Name_Unchecked_Access
);
10376 -- Protected to task requeue
10378 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10380 New_Occurrence_Of
(
10381 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
10383 Param
:= Concurrent_Ref
(Concval
);
10386 Prepend_To
(Params
, Param
);
10387 Prepend_To
(Params
, Self_Param
);
10390 else pragma Assert
(Is_Task_Type
(Old_Typ
));
10392 -- Task to protected requeue
10394 if Is_Protected_Type
(Conc_Typ
) then
10396 New_Occurrence_Of
(
10397 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
10400 Make_Attribute_Reference
(Loc
,
10402 Concurrent_Ref
(Concval
),
10404 Name_Unchecked_Access
);
10406 -- Task to task requeue
10408 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10410 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
);
10412 Param
:= Concurrent_Ref
(Concval
);
10415 Prepend_To
(Params
, Param
);
10419 Make_Procedure_Call_Statement
(Loc
,
10421 Parameter_Associations
=> Params
);
10422 end Build_Normal_Requeue
;
10424 --------------------------
10425 -- Build_Skip_Statement --
10426 --------------------------
10428 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
10429 Skip_Stmt
: Node_Id
;
10432 -- Build a return statement to skip the rest of the entire body
10434 if Is_Protected_Type
(Old_Typ
) then
10435 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
10437 -- If the requeue is within a task, find the end label of the
10438 -- enclosing accept statement and create a goto statement to it.
10446 -- Climb the parent chain looking for the enclosing accept
10449 Acc
:= Parent
(Search
);
10450 while Present
(Acc
)
10451 and then Nkind
(Acc
) /= N_Accept_Statement
10453 Acc
:= Parent
(Acc
);
10456 -- The last statement is the second label used for completing
10457 -- the rendezvous the usual way. The label we are looking for
10458 -- is right before it.
10461 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
10463 pragma Assert
(Nkind
(Label
) = N_Label
);
10465 -- Generate a goto statement to skip the rest of the accept
10468 Make_Goto_Statement
(Loc
,
10470 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
10474 Set_Analyzed
(Skip_Stmt
);
10477 end Build_Skip_Statement
;
10479 -- Start of processing for Expand_N_Requeue_Statement
10482 -- Extract the components of the entry call
10484 Extract_Entry
(N
, Concval
, Ename
, Index
);
10485 Conc_Typ
:= Etype
(Concval
);
10487 -- If the prefix is an access to class-wide type, dereference to get
10488 -- object and entry type.
10490 if Is_Access_Type
(Conc_Typ
) then
10491 Conc_Typ
:= Designated_Type
(Conc_Typ
);
10493 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Concval
)));
10494 Analyze_And_Resolve
(Concval
, Conc_Typ
);
10497 -- Examine the scope stack in order to find nearest enclosing protected
10498 -- or task type. This will constitute our invocation source.
10500 Old_Typ
:= Current_Scope
;
10501 while Present
(Old_Typ
)
10502 and then not Is_Protected_Type
(Old_Typ
)
10503 and then not Is_Task_Type
(Old_Typ
)
10505 Old_Typ
:= Scope
(Old_Typ
);
10508 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10509 -- Concval.Ename where the type of Concval is class-wide concurrent
10512 if Ada_Version
>= Ada_2012
10513 and then Present
(Concval
)
10514 and then Is_Class_Wide_Type
(Conc_Typ
)
10515 and then Is_Concurrent_Interface
(Conc_Typ
)
10518 Has_Impl
: Boolean := False;
10519 Impl_Kind
: Name_Id
:= No_Name
;
10522 -- Check whether the Ename is flagged by pragma Implemented
10524 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
10526 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
10529 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10530 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10532 if Has_Impl
and then Impl_Kind
= Name_By_Entry
then
10533 Rewrite
(N
, Build_Dispatching_Requeue
);
10535 Insert_After
(N
, Build_Skip_Statement
(N
));
10537 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10538 -- a protected procedure. In this case the requeue is transformed
10539 -- into a dispatching call.
10542 and then Impl_Kind
= Name_By_Protected_Procedure
10544 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
10547 -- The procedure_or_entry_NAME's implementation kind is either
10548 -- By_Any, Optional, or pragma Implemented was not applied at all.
10549 -- In this case a runtime test determines whether Ename denotes an
10550 -- entry or a protected procedure and performs the appropriate
10554 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
10559 -- Processing for regular (non-dispatching) requeues
10562 Rewrite
(N
, Build_Normal_Requeue
);
10564 Insert_After
(N
, Build_Skip_Statement
(N
));
10566 end Expand_N_Requeue_Statement
;
10568 -------------------------------
10569 -- Expand_N_Selective_Accept --
10570 -------------------------------
10572 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10573 Loc
: constant Source_Ptr
:= Sloc
(N
);
10574 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10576 -- Note: in the below declarations a lot of new lists are allocated
10577 -- unconditionally which may well not end up being used. That's not
10578 -- a good idea since it wastes space gratuitously ???
10580 Accept_Case
: List_Id
;
10581 Accept_List
: constant List_Id
:= New_List
;
10584 Alt_List
: constant List_Id
:= New_List
;
10585 Alt_Stats
: List_Id
;
10586 Ann
: Entity_Id
:= Empty
;
10588 Check_Guard
: Boolean := True;
10590 Decls
: constant List_Id
:= New_List
;
10591 Stats
: constant List_Id
:= New_List
;
10592 Body_List
: constant List_Id
:= New_List
;
10593 Trailing_List
: constant List_Id
:= New_List
;
10596 Else_Present
: Boolean := False;
10597 Terminate_Alt
: Node_Id
:= Empty
;
10598 Select_Mode
: Node_Id
;
10600 Delay_Case
: List_Id
;
10601 Delay_Count
: Integer := 0;
10602 Delay_Val
: Entity_Id
;
10603 Delay_Index
: Entity_Id
;
10604 Delay_Min
: Entity_Id
;
10605 Delay_Num
: Pos
:= 1;
10606 Delay_Alt_List
: List_Id
:= New_List
;
10607 Delay_List
: constant List_Id
:= New_List
;
10611 First_Delay
: Boolean := True;
10612 Guard_Open
: Entity_Id
;
10618 Num_Accept
: Nat
:= 0;
10620 Time_Type
: Entity_Id
;
10621 Select_Call
: Node_Id
;
10623 Qnam
: constant Entity_Id
:=
10624 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10626 Xnam
: constant Entity_Id
:=
10627 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10629 -----------------------
10630 -- Local subprograms --
10631 -----------------------
10633 function Accept_Or_Raise
return List_Id
;
10634 -- For the rare case where delay alternatives all have guards, and
10635 -- all of them are closed, it is still possible that there were open
10636 -- accept alternatives with no callers. We must reexamine the
10637 -- Accept_List, and execute a selective wait with no else if some
10638 -- accept is open. If none, we raise program_error.
10640 procedure Add_Accept
(Alt
: Node_Id
);
10641 -- Process a single accept statement in a select alternative. Build
10642 -- procedure for body of accept, and add entry to dispatch table with
10643 -- expression for guard, in preparation for call to run time select.
10645 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10646 -- Manufacture a label using Num as a serial number and declare it.
10647 -- The declaration is appended to Decls. The label marks the trailing
10648 -- statements of an accept or delay alternative.
10650 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10651 -- Build call to Selective_Wait runtime routine
10653 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10654 -- Add code to compare value of delay with previous values, and
10655 -- generate case entry for trailing statements.
10657 procedure Process_Accept_Alternative
10661 -- Add code to call corresponding procedure, and branch to
10662 -- trailing statements, if any.
10664 ---------------------
10665 -- Accept_Or_Raise --
10666 ---------------------
10668 function Accept_Or_Raise
return List_Id
is
10671 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10674 -- We generate the following:
10676 -- for J in q'range loop
10677 -- if q(J).S /=null_task_entry then
10678 -- selective_wait (simple_mode,...);
10684 -- if no rendez_vous then
10685 -- raise program_error;
10688 -- Note that the code needs to know that the selector name
10689 -- in an Accept_Alternative is named S.
10691 Cond
:= Make_Op_Ne
(Loc
,
10693 Make_Selected_Component
(Loc
,
10695 Make_Indexed_Component
(Loc
,
10696 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10697 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))),
10698 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10700 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Loc
));
10702 Stats
:= New_List
(
10703 Make_Implicit_Loop_Statement
(N
,
10704 Iteration_Scheme
=>
10705 Make_Iteration_Scheme
(Loc
,
10706 Loop_Parameter_Specification
=>
10707 Make_Loop_Parameter_Specification
(Loc
,
10708 Defining_Identifier
=> J
,
10709 Discrete_Subtype_Definition
=>
10710 Make_Attribute_Reference
(Loc
,
10711 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10712 Attribute_Name
=> Name_Range
,
10713 Expressions
=> New_List
(
10714 Make_Integer_Literal
(Loc
, 1))))),
10716 Statements
=> New_List
(
10717 Make_Implicit_If_Statement
(N
,
10719 Then_Statements
=> New_List
(
10721 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)),
10722 Make_Exit_Statement
(Loc
))))));
10725 Make_Raise_Program_Error
(Loc
,
10726 Condition
=> Make_Op_Eq
(Loc
,
10727 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
10729 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
10730 Reason
=> PE_All_Guards_Closed
));
10733 end Accept_Or_Raise
;
10739 procedure Add_Accept
(Alt
: Node_Id
) is
10740 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10741 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10742 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10743 Eent
: constant Entity_Id
:= Entity
(Ename
);
10744 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10745 Null_Body
: Node_Id
;
10746 Proc_Body
: Node_Id
;
10747 PB_Ent
: Entity_Id
;
10753 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10756 if Present
(Condition
(Alt
)) then
10758 Make_If_Expression
(Eloc
, New_List
(
10760 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10761 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10764 Entry_Index_Expression
10765 (Eloc
, Eent
, Index
, Scope
(Eent
));
10768 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10769 Null_Body
:= New_Occurrence_Of
(Standard_False
, Eloc
);
10771 -- Always add call to Abort_Undefer when generating code, since
10772 -- this is what the runtime expects (abort deferred in
10773 -- Selective_Wait). In CodePeer mode this only confuses the
10774 -- analysis with unknown calls, so don't do it.
10776 if not CodePeer_Mode
then
10777 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10779 (First
(Statements
(Handled_Statement_Sequence
10780 (Accept_Statement
(Alt
)))),
10786 Make_Defining_Identifier
(Eloc
,
10787 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10789 if Comes_From_Source
(Alt
) then
10790 Set_Debug_Info_Needed
(PB_Ent
);
10794 Make_Subprogram_Body
(Eloc
,
10796 Make_Procedure_Specification
(Eloc
,
10797 Defining_Unit_Name
=> PB_Ent
),
10798 Declarations
=> Declarations
(Acc_Stm
),
10799 Handled_Statement_Sequence
=>
10800 Build_Accept_Body
(Accept_Statement
(Alt
)));
10802 -- During the analysis of the body of the accept statement, any
10803 -- zero cost exception handler records were collected in the
10804 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10805 -- This is where we move them to where they belong, namely the
10806 -- newly created procedure.
10808 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10809 Append
(Proc_Body
, Body_List
);
10812 Null_Body
:= New_Occurrence_Of
(Standard_True
, Eloc
);
10814 -- if accept statement has declarations, insert above, given that
10815 -- we are not creating a body for the accept.
10817 if Present
(Declarations
(Acc_Stm
)) then
10818 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10822 Append_To
(Accept_List
,
10823 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10825 Num_Accept
:= Num_Accept
+ 1;
10828 ----------------------------
10829 -- Make_And_Declare_Label --
10830 ----------------------------
10832 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10836 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10838 Make_Label
(Loc
, Lab_Id
);
10841 Make_Implicit_Label_Declaration
(Loc
,
10842 Defining_Identifier
=>
10843 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10844 Label_Construct
=> Lab
));
10847 end Make_And_Declare_Label
;
10849 ----------------------
10850 -- Make_Select_Call --
10851 ----------------------
10853 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10854 Params
: constant List_Id
:= New_List
;
10858 Make_Attribute_Reference
(Loc
,
10859 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10860 Attribute_Name
=> Name_Unchecked_Access
));
10861 Append_To
(Params
, Select_Mode
);
10862 Append_To
(Params
, New_Occurrence_Of
(Ann
, Loc
));
10863 Append_To
(Params
, New_Occurrence_Of
(Xnam
, Loc
));
10866 Make_Procedure_Call_Statement
(Loc
,
10867 Name
=> New_Occurrence_Of
(RTE
(RE_Selective_Wait
), Loc
),
10868 Parameter_Associations
=> Params
);
10869 end Make_Select_Call
;
10871 --------------------------------
10872 -- Process_Accept_Alternative --
10873 --------------------------------
10875 procedure Process_Accept_Alternative
10880 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10881 Alt_Stats
: List_Id
;
10884 Adjust_Condition
(Condition
(Alt
));
10886 -- Accept with body
10888 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10891 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10894 (Defining_Unit_Name
(Specification
(Proc
)),
10897 -- Accept with no body (followed by trailing statements)
10900 Alt_Stats
:= Empty_List
;
10903 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
10905 -- After the call, if any, branch to trailing statements, if any.
10906 -- We create a label for each, as well as the corresponding label
10909 if not Is_Empty_List
(Statements
(Alt
)) then
10910 Lab
:= Make_And_Declare_Label
(Index
);
10911 Append
(Lab
, Trailing_List
);
10912 Append_List
(Statements
(Alt
), Trailing_List
);
10913 Append_To
(Trailing_List
,
10914 Make_Goto_Statement
(Loc
,
10915 Name
=> New_Copy
(Identifier
(End_Lab
))));
10921 Append_To
(Alt_Stats
,
10922 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
10924 Append_To
(Alt_List
,
10925 Make_Case_Statement_Alternative
(Loc
,
10926 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
10927 Statements
=> Alt_Stats
));
10928 end Process_Accept_Alternative
;
10930 -------------------------------
10931 -- Process_Delay_Alternative --
10932 -------------------------------
10934 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
10935 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
10937 Delay_Alt
: List_Id
;
10940 -- Deal with C/Fortran boolean as delay condition
10942 Adjust_Condition
(Condition
(Alt
));
10944 -- Determine the smallest specified delay
10946 -- for each delay alternative generate:
10948 -- if guard-expression then
10949 -- Delay_Val := delay-expression;
10950 -- Guard_Open := True;
10951 -- if Delay_Val < Delay_Min then
10952 -- Delay_Min := Delay_Val;
10953 -- Delay_Index := Index;
10957 -- The enclosing if-statement is omitted if there is no guard
10959 if Delay_Count
= 1 or else First_Delay
then
10960 First_Delay
:= False;
10962 Delay_Alt
:= New_List
(
10963 Make_Assignment_Statement
(Loc
,
10964 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10965 Expression
=> Expression
(Delay_Statement
(Alt
))));
10967 if Delay_Count
> 1 then
10968 Append_To
(Delay_Alt
,
10969 Make_Assignment_Statement
(Loc
,
10970 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10971 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
10975 Delay_Alt
:= New_List
(
10976 Make_Assignment_Statement
(Loc
,
10977 Name
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10978 Expression
=> Expression
(Delay_Statement
(Alt
))));
10980 if Time_Type
= Standard_Duration
then
10983 Left_Opnd
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10984 Right_Opnd
=> New_Occurrence_Of
(Delay_Min
, Loc
));
10987 -- The scope of the time type must define a comparison
10988 -- operator. The scope itself may not be visible, so we
10989 -- construct a node with entity information to insure that
10990 -- semantic analysis can find the proper operator.
10993 Make_Function_Call
(Loc
,
10994 Name
=> Make_Selected_Component
(Loc
,
10996 New_Occurrence_Of
(Scope
(Time_Type
), Loc
),
10998 Make_Operator_Symbol
(Loc
,
10999 Chars
=> Name_Op_Lt
,
11000 Strval
=> No_String
)),
11001 Parameter_Associations
=>
11003 New_Occurrence_Of
(Delay_Val
, Loc
),
11004 New_Occurrence_Of
(Delay_Min
, Loc
)));
11006 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
11009 Append_To
(Delay_Alt
,
11010 Make_Implicit_If_Statement
(N
,
11012 Then_Statements
=> New_List
(
11013 Make_Assignment_Statement
(Loc
,
11014 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
11015 Expression
=> New_Occurrence_Of
(Delay_Val
, Loc
)),
11017 Make_Assignment_Statement
(Loc
,
11018 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11019 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
11022 if Check_Guard
then
11023 Append_To
(Delay_Alt
,
11024 Make_Assignment_Statement
(Loc
,
11025 Name
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11026 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11029 if Present
(Condition
(Alt
)) then
11030 Delay_Alt
:= New_List
(
11031 Make_Implicit_If_Statement
(N
,
11032 Condition
=> Condition
(Alt
),
11033 Then_Statements
=> Delay_Alt
));
11036 Append_List
(Delay_Alt
, Delay_List
);
11038 Ensure_Statement_Present
(Dloc
, Alt
);
11040 -- If the delay alternative has a statement part, add choice to the
11041 -- case statements for delays.
11043 if not Is_Empty_List
(Statements
(Alt
)) then
11045 if Delay_Count
= 1 then
11046 Append_List
(Statements
(Alt
), Delay_Alt_List
);
11049 Append_To
(Delay_Alt_List
,
11050 Make_Case_Statement_Alternative
(Loc
,
11051 Discrete_Choices
=> New_List
(
11052 Make_Integer_Literal
(Loc
, Index
)),
11053 Statements
=> Statements
(Alt
)));
11056 elsif Delay_Count
= 1 then
11058 -- If the single delay has no trailing statements, add a branch
11059 -- to the exit label to the selective wait.
11061 Delay_Alt_List
:= New_List
(
11062 Make_Goto_Statement
(Loc
,
11063 Name
=> New_Copy
(Identifier
(End_Lab
))));
11066 end Process_Delay_Alternative
;
11068 -- Start of processing for Expand_N_Selective_Accept
11071 Process_Statements_For_Controlled_Objects
(N
);
11073 -- First insert some declarations before the select. The first is:
11077 -- This variable holds the parameters passed to the accept body. This
11078 -- declaration has already been inserted by the time we get here by
11079 -- a call to Expand_Accept_Declarations made from the semantics when
11080 -- processing the first accept statement contained in the select. We
11081 -- can find this entity as Accept_Address (E), where E is any of the
11082 -- entries references by contained accept statements.
11084 -- The first step is to scan the list of Selective_Accept_Statements
11085 -- to find this entity, and also count the number of accepts, and
11086 -- determine if terminated, delay or else is present:
11090 Alt
:= First
(Alts
);
11091 while Present
(Alt
) loop
11092 Process_Statements_For_Controlled_Objects
(Alt
);
11094 if Nkind
(Alt
) = N_Accept_Alternative
then
11097 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11098 Delay_Count
:= Delay_Count
+ 1;
11100 -- If the delays are relative delays, the delay expressions have
11101 -- type Standard_Duration. Otherwise they must have some time type
11102 -- recognized by GNAT.
11104 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
11105 Time_Type
:= Standard_Duration
;
11107 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
11109 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
11110 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
11115 "& is not a time type (RM 9.6(6))",
11116 Expression
(Delay_Statement
(Alt
)), Time_Type
);
11117 Time_Type
:= Standard_Duration
;
11118 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
11122 if No
(Condition
(Alt
)) then
11124 -- This guard will always be open
11126 Check_Guard
:= False;
11129 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
11130 Adjust_Condition
(Condition
(Alt
));
11131 Terminate_Alt
:= Alt
;
11134 Num_Alts
:= Num_Alts
+ 1;
11138 Else_Present
:= Present
(Else_Statements
(N
));
11140 -- At the same time (see procedure Add_Accept) we build the accept list:
11142 -- Qnn : Accept_List (1 .. num-select) := (
11143 -- (null-body, entry-index),
11144 -- (null-body, entry-index),
11146 -- (null_body, entry-index));
11148 -- In the above declaration, null-body is True if the corresponding
11149 -- accept has no body, and false otherwise. The entry is either the
11150 -- entry index expression if there is no guard, or if a guard is
11151 -- present, then an if expression of the form:
11153 -- (if guard then entry-index else Null_Task_Entry)
11155 -- If a guard is statically known to be false, the entry can simply
11156 -- be omitted from the accept list.
11159 Make_Object_Declaration
(Loc
,
11160 Defining_Identifier
=> Qnam
,
11161 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11162 Aliased_Present
=> True,
11164 Make_Qualified_Expression
(Loc
,
11166 New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11168 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
11170 -- Then we declare the variable that holds the index for the accept
11171 -- that will be selected for service:
11173 -- Xnn : Select_Index;
11176 Make_Object_Declaration
(Loc
,
11177 Defining_Identifier
=> Xnam
,
11178 Object_Definition
=>
11179 New_Occurrence_Of
(RTE
(RE_Select_Index
), Loc
),
11181 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)));
11183 -- After this follow procedure declarations for each accept body
11185 -- procedure Pnn is
11190 -- where the ... are statements from the corresponding procedure body.
11191 -- No parameters are involved, since the parameters are passed via Ann
11192 -- and the parameter references have already been expanded to be direct
11193 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11194 -- any embedded tasking statements (which would normally be illegal in
11195 -- procedures), have been converted to calls to the tasking runtime so
11196 -- there is no problem in putting them into procedures.
11198 -- The original accept statement has been expanded into a block in
11199 -- the same fashion as for simple accepts (see Build_Accept_Body).
11201 -- Note: we don't really need to build these procedures for the case
11202 -- where no delay statement is present, but it is just as easy to
11203 -- build them unconditionally, and not significantly inefficient,
11204 -- since if they are short they will be inlined anyway.
11206 -- The procedure declarations have been assembled in Body_List
11208 -- If delays are present, we must compute the required delay.
11209 -- We first generate the declarations:
11211 -- Delay_Index : Boolean := 0;
11212 -- Delay_Min : Some_Time_Type.Time;
11213 -- Delay_Val : Some_Time_Type.Time;
11215 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11216 -- active delay that is actually chosen as the basis for the possible
11217 -- delay if an immediate rendez-vous is not possible.
11219 -- In the most common case there is a single delay statement, and this
11220 -- is handled specially.
11222 if Delay_Count
> 0 then
11224 -- Generate the required declarations
11227 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
11229 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
11231 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
11234 Make_Object_Declaration
(Loc
,
11235 Defining_Identifier
=> Delay_Val
,
11236 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
)));
11239 Make_Object_Declaration
(Loc
,
11240 Defining_Identifier
=> Delay_Index
,
11241 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11242 Expression
=> Make_Integer_Literal
(Loc
, 0)));
11245 Make_Object_Declaration
(Loc
,
11246 Defining_Identifier
=> Delay_Min
,
11247 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
),
11249 Unchecked_Convert_To
(Time_Type
,
11250 Make_Attribute_Reference
(Loc
,
11252 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
11253 Attribute_Name
=> Name_Last
))));
11255 -- Create Duration and Delay_Mode objects used for passing a delay
11258 D
:= Make_Temporary
(Loc
, 'D');
11259 M
:= Make_Temporary
(Loc
, 'M');
11265 -- Note that these values are defined in s-osprim.ads and must
11266 -- be kept in sync:
11268 -- Relative : constant := 0;
11269 -- Absolute_Calendar : constant := 1;
11270 -- Absolute_RT : constant := 2;
11272 if Time_Type
= Standard_Duration
then
11273 Discr
:= Make_Integer_Literal
(Loc
, 0);
11275 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11276 Discr
:= Make_Integer_Literal
(Loc
, 1);
11280 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11281 Discr
:= Make_Integer_Literal
(Loc
, 2);
11285 Make_Object_Declaration
(Loc
,
11286 Defining_Identifier
=> D
,
11287 Object_Definition
=>
11288 New_Occurrence_Of
(Standard_Duration
, Loc
)));
11291 Make_Object_Declaration
(Loc
,
11292 Defining_Identifier
=> M
,
11293 Object_Definition
=>
11294 New_Occurrence_Of
(Standard_Integer
, Loc
),
11295 Expression
=> Discr
));
11298 if Check_Guard
then
11300 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
11303 Make_Object_Declaration
(Loc
,
11304 Defining_Identifier
=> Guard_Open
,
11305 Object_Definition
=>
11306 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11308 New_Occurrence_Of
(Standard_False
, Loc
)));
11311 -- Delay_Count is zero, don't need M and D set (suppress warning)
11318 if Present
(Terminate_Alt
) then
11320 -- If the terminate alternative guard is False, use
11321 -- Simple_Mode; otherwise use Terminate_Mode.
11323 if Present
(Condition
(Terminate_Alt
)) then
11324 Select_Mode
:= Make_If_Expression
(Loc
,
11325 New_List
(Condition
(Terminate_Alt
),
11326 New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
),
11327 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)));
11329 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
);
11332 elsif Else_Present
or Delay_Count
> 0 then
11333 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Else_Mode
), Loc
);
11336 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
);
11339 Select_Call
:= Make_Select_Call
(Select_Mode
);
11340 Append
(Select_Call
, Stats
);
11342 -- Now generate code to act on the result. There is an entry
11343 -- in this case for each accept statement with a non-null body,
11344 -- followed by a branch to the statements that follow the Accept.
11345 -- In the absence of delay alternatives, we generate:
11348 -- when No_Rendezvous => -- omitted if simple mode
11363 -- Lab0: Else_Statements;
11366 -- Lab1: Trailing_Statements1;
11369 -- Lab2: Trailing_Statements2;
11374 -- Generate label for common exit
11376 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
11378 -- First entry is the default case, when no rendezvous is possible
11380 Choices
:= New_List
(New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
));
11382 if Else_Present
then
11384 -- If no rendezvous is possible, the else part is executed
11386 Lab
:= Make_And_Declare_Label
(0);
11387 Alt_Stats
:= New_List
(
11388 Make_Goto_Statement
(Loc
,
11389 Name
=> New_Copy
(Identifier
(Lab
))));
11391 Append
(Lab
, Trailing_List
);
11392 Append_List
(Else_Statements
(N
), Trailing_List
);
11393 Append_To
(Trailing_List
,
11394 Make_Goto_Statement
(Loc
,
11395 Name
=> New_Copy
(Identifier
(End_Lab
))));
11397 Alt_Stats
:= New_List
(
11398 Make_Goto_Statement
(Loc
,
11399 Name
=> New_Copy
(Identifier
(End_Lab
))));
11402 Append_To
(Alt_List
,
11403 Make_Case_Statement_Alternative
(Loc
,
11404 Discrete_Choices
=> Choices
,
11405 Statements
=> Alt_Stats
));
11407 -- We make use of the fact that Accept_Index is an integer type, and
11408 -- generate successive literals for entries for each accept. Only those
11409 -- for which there is a body or trailing statements get a case entry.
11411 Alt
:= First
(Select_Alternatives
(N
));
11412 Proc
:= First
(Body_List
);
11413 while Present
(Alt
) loop
11415 if Nkind
(Alt
) = N_Accept_Alternative
then
11416 Process_Accept_Alternative
(Alt
, Index
, Proc
);
11417 Index
:= Index
+ 1;
11420 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
11425 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11426 Process_Delay_Alternative
(Alt
, Delay_Num
);
11427 Delay_Num
:= Delay_Num
+ 1;
11433 -- An others choice is always added to the main case, as well
11434 -- as the delay case (to satisfy the compiler).
11436 Append_To
(Alt_List
,
11437 Make_Case_Statement_Alternative
(Loc
,
11438 Discrete_Choices
=>
11439 New_List
(Make_Others_Choice
(Loc
)),
11441 New_List
(Make_Goto_Statement
(Loc
,
11442 Name
=> New_Copy
(Identifier
(End_Lab
))))));
11444 Accept_Case
:= New_List
(
11445 Make_Case_Statement
(Loc
,
11446 Expression
=> New_Occurrence_Of
(Xnam
, Loc
),
11447 Alternatives
=> Alt_List
));
11449 Append_List
(Trailing_List
, Accept_Case
);
11450 Append_List
(Body_List
, Decls
);
11452 -- Construct case statement for trailing statements of delay
11453 -- alternatives, if there are several of them.
11455 if Delay_Count
> 1 then
11456 Append_To
(Delay_Alt_List
,
11457 Make_Case_Statement_Alternative
(Loc
,
11458 Discrete_Choices
=>
11459 New_List
(Make_Others_Choice
(Loc
)),
11461 New_List
(Make_Null_Statement
(Loc
))));
11463 Delay_Case
:= New_List
(
11464 Make_Case_Statement
(Loc
,
11465 Expression
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11466 Alternatives
=> Delay_Alt_List
));
11468 Delay_Case
:= Delay_Alt_List
;
11471 -- If there are no delay alternatives, we append the case statement
11472 -- to the statement list.
11474 if Delay_Count
= 0 then
11475 Append_List
(Accept_Case
, Stats
);
11477 -- Delay alternatives present
11480 -- If delay alternatives are present we generate:
11482 -- find minimum delay.
11483 -- DX := minimum delay;
11484 -- M := <delay mode>;
11485 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11488 -- if X = No_Rendezvous then
11489 -- case statement for delay statements.
11491 -- case statement for accept alternatives.
11502 -- The type of the delay expression is known to be legal
11504 if Time_Type
= Standard_Duration
then
11505 Conv
:= New_Occurrence_Of
(Delay_Min
, Loc
);
11507 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11508 Conv
:= Make_Function_Call
(Loc
,
11509 New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
11510 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11514 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11516 Conv
:= Make_Function_Call
(Loc
,
11517 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
11518 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11521 Stmt
:= Make_Assignment_Statement
(Loc
,
11522 Name
=> New_Occurrence_Of
(D
, Loc
),
11523 Expression
=> Conv
);
11525 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11527 Parms
:= Parameter_Associations
(Select_Call
);
11529 Parm
:= First
(Parms
);
11530 while Present
(Parm
) and then Parm
/= Select_Mode
loop
11534 pragma Assert
(Present
(Parm
));
11535 Rewrite
(Parm
, New_Occurrence_Of
(RTE
(RE_Delay_Mode
), Loc
));
11538 -- Prepare two new parameters of Duration and Delay_Mode type
11539 -- which represent the value and the mode of the minimum delay.
11542 Insert_After
(Parm
, New_Occurrence_Of
(M
, Loc
));
11543 Insert_After
(Parm
, New_Occurrence_Of
(D
, Loc
));
11545 -- Create a call to RTS
11547 Rewrite
(Select_Call
,
11548 Make_Procedure_Call_Statement
(Loc
,
11549 Name
=> New_Occurrence_Of
(RTE
(RE_Timed_Selective_Wait
), Loc
),
11550 Parameter_Associations
=> Parms
));
11552 -- This new call should follow the calculation of the minimum
11555 Insert_List_Before
(Select_Call
, Delay_List
);
11557 if Check_Guard
then
11559 Make_Implicit_If_Statement
(N
,
11560 Condition
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11561 Then_Statements
=> New_List
(
11562 New_Copy_Tree
(Stmt
),
11563 New_Copy_Tree
(Select_Call
)),
11564 Else_Statements
=> Accept_Or_Raise
);
11565 Rewrite
(Select_Call
, Stmt
);
11567 Insert_Before
(Select_Call
, Stmt
);
11571 Make_Implicit_If_Statement
(N
,
11572 Condition
=> Make_Op_Eq
(Loc
,
11573 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
11575 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
11577 Then_Statements
=> Delay_Case
,
11578 Else_Statements
=> Accept_Case
);
11580 Append
(Cases
, Stats
);
11584 Append
(End_Lab
, Stats
);
11586 -- Replace accept statement with appropriate block
11589 Make_Block_Statement
(Loc
,
11590 Declarations
=> Decls
,
11591 Handled_Statement_Sequence
=>
11592 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11595 -- Note: have to worry more about abort deferral in above code ???
11597 -- Final step is to unstack the Accept_Address entries for all accept
11598 -- statements appearing in accept alternatives in the select statement
11600 Alt
:= First
(Alts
);
11601 while Present
(Alt
) loop
11602 if Nkind
(Alt
) = N_Accept_Alternative
then
11603 Remove_Last_Elmt
(Accept_Address
11604 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11609 end Expand_N_Selective_Accept
;
11611 -------------------------------------------
11612 -- Expand_N_Single_Protected_Declaration --
11613 -------------------------------------------
11615 -- A single protected declaration should never be present after semantic
11616 -- analysis because it is transformed into a protected type declaration
11617 -- and an accompanying anonymous object. This routine ensures that the
11618 -- transformation takes place.
11620 procedure Expand_N_Single_Protected_Declaration
(N
: Node_Id
) is
11622 raise Program_Error
;
11623 end Expand_N_Single_Protected_Declaration
;
11625 --------------------------------------
11626 -- Expand_N_Single_Task_Declaration --
11627 --------------------------------------
11629 -- A single task declaration should never be present after semantic
11630 -- analysis because it is transformed into a task type declaration and
11631 -- an accompanying anonymous object. This routine ensures that the
11632 -- transformation takes place.
11634 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11636 raise Program_Error
;
11637 end Expand_N_Single_Task_Declaration
;
11639 ------------------------
11640 -- Expand_N_Task_Body --
11641 ------------------------
11643 -- Given a task body
11645 -- task body tname is
11651 -- This expansion routine converts it into a procedure and sets the
11652 -- elaboration flag for the procedure to true, to represent the fact
11653 -- that the task body is now elaborated:
11655 -- procedure tnameB (_Task : access tnameV) is
11656 -- discriminal : dtype renames _Task.discriminant;
11658 -- procedure _clean is
11660 -- Abort_Defer.all;
11662 -- Abort_Undefer.all;
11667 -- Abort_Undefer.all;
11669 -- System.Task_Stages.Complete_Activation;
11677 -- In addition, if the task body is an activator, then a call to activate
11678 -- tasks is added at the start of the statements, before the call to
11679 -- Complete_Activation, and if in addition the task is a master then it
11680 -- must be established as a master. These calls are inserted and analyzed
11681 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11684 -- There is one discriminal declaration line generated for each
11685 -- discriminant that is present to provide an easy reference point for
11686 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11688 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11689 -- task body procedures have a profile (Arg : System.Address). That is
11690 -- needed because GNARLI has to use the same access-to-subprogram type
11691 -- for all task types. We depend here on knowing that in GNAT, passing
11692 -- an address argument by value is identical to passing a record value
11693 -- by access (in either case a single pointer is passed), so even though
11694 -- this procedure has the wrong profile. In fact it's all OK, since the
11695 -- callings sequence is identical.
11697 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11698 Loc
: constant Source_Ptr
:= Sloc
(N
);
11699 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11703 Insert_Nod
: Node_Id
;
11704 -- Used to determine the proper location of wrapper body insertions
11707 -- if no task body procedure, means we had an error in configurable
11708 -- run-time mode, and there is no point in proceeding further.
11710 if No
(Task_Body_Procedure
(Ttyp
)) then
11714 -- Add renaming declarations for discriminals and a declaration for the
11715 -- entry family index (if applicable).
11717 Install_Private_Data_Declarations
11718 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11720 -- Add a call to Abort_Undefer at the very beginning of the task
11721 -- body since this body is called with abort still deferred.
11723 if Abort_Allowed
then
11724 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11726 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11730 -- The statement part has already been protected with an at_end and
11731 -- cleanup actions. The call to Complete_Activation must be placed
11732 -- at the head of the sequence of statements of that block. The
11733 -- declarations have been merged in this sequence of statements but
11734 -- the first real statement is accessible from the First_Real_Statement
11735 -- field (which was set for exactly this purpose).
11737 if Restricted_Profile
then
11738 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11740 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11744 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11748 Make_Subprogram_Body
(Loc
,
11749 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11750 Declarations
=> Declarations
(N
),
11751 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11752 Set_Is_Task_Body_Procedure
(New_N
);
11754 -- If the task contains generic instantiations, cleanup actions are
11755 -- delayed until after instantiation. Transfer the activation chain to
11756 -- the subprogram, to insure that the activation call is properly
11757 -- generated. It the task body contains inner tasks, indicate that the
11758 -- subprogram is a task master.
11760 if Delay_Cleanups
(Ttyp
) then
11761 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11762 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11765 Rewrite
(N
, New_N
);
11768 -- Set elaboration flag immediately after task body. If the body is a
11769 -- subunit, the flag is set in the declarative part containing the stub.
11771 if Nkind
(Parent
(N
)) /= N_Subunit
then
11773 Make_Assignment_Statement
(Loc
,
11775 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11776 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11779 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11780 -- the task body. At this point all wrapper specs have been created,
11781 -- frozen and included in the dispatch table for the task type.
11783 if Ada_Version
>= Ada_2005
then
11784 if Nkind
(Parent
(N
)) = N_Subunit
then
11785 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11790 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11792 end Expand_N_Task_Body
;
11794 ------------------------------------
11795 -- Expand_N_Task_Type_Declaration --
11796 ------------------------------------
11798 -- We have several things to do. First we must create a Boolean flag used
11799 -- to mark if the body is elaborated yet. This variable gets set to True
11800 -- when the body of the task is elaborated (we can't rely on the normal
11801 -- ABE mechanism for the task body, since we need to pass an access to
11802 -- this elaboration boolean to the runtime routines).
11804 -- taskE : aliased Boolean := False;
11806 -- Next a variable is declared to hold the task stack size (either the
11807 -- default : Unspecified_Size, or a value that is set by a pragma
11808 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11809 -- the variable is initialized with this value:
11811 -- taskZ : Size_Type := Unspecified_Size;
11813 -- taskZ : Size_Type := Size_Type (size_expression);
11815 -- Note: No variable is needed to hold the task relative deadline since
11816 -- its value would never be static because the parameter is of a private
11817 -- type (Ada.Real_Time.Time_Span).
11819 -- Next we create a corresponding record type declaration used to represent
11820 -- values of this task. The general form of this type declaration is
11822 -- type taskV (discriminants) is record
11823 -- _Task_Id : Task_Id;
11824 -- entry_family : array (bounds) of Void;
11825 -- _Priority : Integer := priority_expression;
11826 -- _Size : Size_Type := size_expression;
11827 -- _Task_Info : Task_Info_Type := task_info_expression;
11828 -- _CPU : Integer := cpu_range_expression;
11829 -- _Relative_Deadline : Time_Span := time_span_expression;
11830 -- _Domain : Dispatching_Domain := dd_expression;
11833 -- The discriminants are present only if the corresponding task type has
11834 -- discriminants, and they exactly mirror the task type discriminants.
11836 -- The Id field is always present. It contains the Task_Id value, as set by
11837 -- the call to Create_Task. Note that although the task is limited, the
11838 -- task value record type is not limited, so there is no problem in passing
11839 -- this field as an out parameter to Create_Task.
11841 -- One entry_family component is present for each entry family in the task
11842 -- definition. The bounds correspond to the bounds of the entry family
11843 -- (which may depend on discriminants). The element type is void, since we
11844 -- only need the bounds information for determining the entry index. Note
11845 -- that the use of an anonymous array would normally be illegal in this
11846 -- context, but this is a parser check, and the semantics is quite prepared
11847 -- to handle such a case.
11849 -- The _Size field is present only if a Storage_Size pragma appears in the
11850 -- task definition. The expression captures the argument that was present
11851 -- in the pragma, and is used to override the task stack size otherwise
11852 -- associated with the task type.
11854 -- The _Priority field is present only if the task entity has a Priority or
11855 -- Interrupt_Priority 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 -- The _Task_Info field is present only if a Task_Info pragma appears in
11862 -- the task definition. The expression captures the argument that was
11863 -- present in the pragma, and is used to provide the Task_Image parameter
11864 -- to the call to Create_Task.
11866 -- The _CPU field is present only if the task entity has a CPU rep item
11867 -- (pragma, aspect specification or attribute definition clause). It will
11868 -- be filled at the freeze point, when the record init proc is built, to
11869 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11870 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11871 -- are delayed till the freeze point.
11873 -- The _Relative_Deadline field is present only if a Relative_Deadline
11874 -- pragma appears in the task definition. The expression captures the
11875 -- argument that was present in the pragma, and is used to provide the
11876 -- Relative_Deadline parameter to the call to Create_Task.
11878 -- The _Domain field is present only if the task entity has a
11879 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11880 -- definition clause). It will be filled at the freeze point, when the
11881 -- record init proc is built, to capture the expression of the rep item
11882 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11883 -- here since aspect evaluations are delayed till the freeze point.
11885 -- When a task is declared, an instance of the task value record is
11886 -- created. The elaboration of this declaration creates the correct bounds
11887 -- for the entry families, and also evaluates the size, priority, and
11888 -- task_Info expressions if needed. The initialization routine for the task
11889 -- type itself then calls Create_Task with appropriate parameters to
11890 -- initialize the value of the Task_Id field.
11892 -- Note: the address of this record is passed as the "Discriminants"
11893 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11894 -- body procedure, it does not matter that it does not quite match the
11895 -- GNARLI model of what is being passed (the record contains more than just
11896 -- the discriminants, but the discriminants can be found from the record
11899 -- The Entity_Id for this created record type is placed in the
11900 -- Corresponding_Record_Type field of the associated task type entity.
11902 -- Next we create a procedure specification for the task body procedure:
11904 -- procedure taskB (_Task : access taskV);
11906 -- Note that this must come after the record type declaration, since
11907 -- the spec refers to this type. It turns out that the initialization
11908 -- procedure for the value type references the task body spec, but that's
11909 -- fine, since it won't be generated till the freeze point for the type,
11910 -- which is certainly after the task body spec declaration.
11912 -- Finally, we set the task index value field of the entry attribute in
11913 -- the case of a simple entry.
11915 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
11916 Loc
: constant Source_Ptr
:= Sloc
(N
);
11917 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
11918 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
11919 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
11920 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
11922 Body_Decl
: Node_Id
;
11924 Decl_Stack
: Node_Id
;
11925 Elab_Decl
: Node_Id
;
11926 Ent_Stack
: Entity_Id
;
11927 Proc_Spec
: Node_Id
;
11928 Rec_Decl
: Node_Id
;
11929 Rec_Ent
: Entity_Id
;
11930 Size_Decl
: Entity_Id
;
11931 Task_Size
: Node_Id
;
11933 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
11934 -- Searches the task definition T for the first occurrence of the pragma
11935 -- Relative Deadline. The caller has ensured that the pragma is present
11936 -- in the task definition. Note that this routine cannot be implemented
11937 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11938 -- not chained because their expansion into a procedure call statement
11939 -- would cause a break in the chain.
11941 ----------------------------------
11942 -- Get_Relative_Deadline_Pragma --
11943 ----------------------------------
11945 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
11949 N
:= First
(Visible_Declarations
(T
));
11950 while Present
(N
) loop
11951 if Nkind
(N
) = N_Pragma
11952 and then Pragma_Name
(N
) = Name_Relative_Deadline
11960 N
:= First
(Private_Declarations
(T
));
11961 while Present
(N
) loop
11962 if Nkind
(N
) = N_Pragma
11963 and then Pragma_Name
(N
) = Name_Relative_Deadline
11971 raise Program_Error
;
11972 end Get_Relative_Deadline_Pragma
;
11974 -- Start of processing for Expand_N_Task_Type_Declaration
11977 -- If already expanded, nothing to do
11979 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
11983 -- Here we will do the expansion
11985 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
11987 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
11988 Cdecls
:= Component_Items
(Component_List
11989 (Type_Definition
(Rec_Decl
)));
11991 Qualify_Entity_Names
(N
);
11993 -- First create the elaboration variable
11996 Make_Object_Declaration
(Loc
,
11997 Defining_Identifier
=>
11998 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11999 Chars
=> New_External_Name
(Tasknm
, 'E')),
12000 Aliased_Present
=> True,
12001 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
12002 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
12004 Insert_After
(N
, Elab_Decl
);
12006 -- Next create the declaration of the size variable (tasknmZ)
12008 Set_Storage_Size_Variable
(Tasktyp
,
12009 Make_Defining_Identifier
(Sloc
(Tasktyp
),
12010 Chars
=> New_External_Name
(Tasknm
, 'Z')));
12012 if Present
(Taskdef
)
12013 and then Has_Storage_Size_Pragma
(Taskdef
)
12015 Is_OK_Static_Expression
12017 (First
(Pragma_Argument_Associations
12018 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
12021 Make_Object_Declaration
(Loc
,
12022 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
12023 Object_Definition
=>
12024 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12026 Convert_To
(RTE
(RE_Size_Type
),
12028 (Expression
(First
(Pragma_Argument_Associations
12030 (TaskId
, Name_Storage_Size
)))))));
12034 Make_Object_Declaration
(Loc
,
12035 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
12036 Object_Definition
=>
12037 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12039 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
12042 Insert_After
(Elab_Decl
, Size_Decl
);
12044 -- Next build the rest of the corresponding record declaration. This is
12045 -- done last, since the corresponding record initialization procedure
12046 -- will reference the previously created entities.
12048 -- Fill in the component declarations -- first the _Task_Id field
12051 Make_Component_Declaration
(Loc
,
12052 Defining_Identifier
=>
12053 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
12054 Component_Definition
=>
12055 Make_Component_Definition
(Loc
,
12056 Aliased_Present
=> False,
12057 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RO_ST_Task_Id
),
12060 -- Declare static ATCB (that is, created by the expander) if we are
12061 -- using the Restricted run time.
12063 if Restricted_Profile
then
12065 Make_Component_Declaration
(Loc
,
12066 Defining_Identifier
=>
12067 Make_Defining_Identifier
(Loc
, Name_uATCB
),
12069 Component_Definition
=>
12070 Make_Component_Definition
(Loc
,
12071 Aliased_Present
=> True,
12072 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12074 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
12077 Make_Index_Or_Discriminant_Constraint
(Loc
,
12079 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
12083 -- Declare static stack (that is, created by the expander) if we are
12084 -- using the Restricted run time on a bare board configuration.
12086 if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
12088 -- First we need to extract the appropriate stack size
12090 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
12092 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12094 Expr_N
: constant Node_Id
:=
12095 Expression
(First
(
12096 Pragma_Argument_Associations
(
12097 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
12098 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
12099 P
: constant Node_Id
:= Parent
(Expr_N
);
12102 -- The stack is defined inside the corresponding record.
12103 -- Therefore if the size of the stack is set by means of
12104 -- a discriminant, we must reference the discriminant of the
12105 -- corresponding record type.
12107 if Nkind
(Expr_N
) in N_Has_Entity
12108 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
12112 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
12114 Set_Parent
(Task_Size
, P
);
12115 Set_Etype
(Task_Size
, Etyp
);
12116 Set_Analyzed
(Task_Size
);
12119 Task_Size
:= Relocate_Node
(Expr_N
);
12125 New_Occurrence_Of
(RTE
(RE_Default_Stack_Size
), Loc
);
12128 Decl_Stack
:= Make_Component_Declaration
(Loc
,
12129 Defining_Identifier
=> Ent_Stack
,
12131 Component_Definition
=>
12132 Make_Component_Definition
(Loc
,
12133 Aliased_Present
=> True,
12134 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12136 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
12139 Make_Index_Or_Discriminant_Constraint
(Loc
,
12140 Constraints
=> New_List
(Make_Range
(Loc
,
12141 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
12142 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
12145 Append_To
(Cdecls
, Decl_Stack
);
12147 -- The appropriate alignment for the stack is ensured by the run-time
12148 -- code in charge of task creation.
12152 -- Add components for entry families
12154 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
12156 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12157 -- item is present.
12159 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
12161 Make_Component_Declaration
(Loc
,
12162 Defining_Identifier
=>
12163 Make_Defining_Identifier
(Loc
, Name_uPriority
),
12164 Component_Definition
=>
12165 Make_Component_Definition
(Loc
,
12166 Aliased_Present
=> False,
12167 Subtype_Indication
=>
12168 New_Occurrence_Of
(Standard_Integer
, Loc
))));
12171 -- Add the _Size component if a Storage_Size pragma is present
12173 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12175 Make_Component_Declaration
(Loc
,
12176 Defining_Identifier
=>
12177 Make_Defining_Identifier
(Loc
, Name_uSize
),
12179 Component_Definition
=>
12180 Make_Component_Definition
(Loc
,
12181 Aliased_Present
=> False,
12182 Subtype_Indication
=>
12183 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
)),
12186 Convert_To
(RTE
(RE_Size_Type
),
12188 Expression
(First
(
12189 Pragma_Argument_Associations
(
12190 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
12193 -- Add the _Task_Info component if a Task_Info pragma is present
12195 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
12197 Make_Component_Declaration
(Loc
,
12198 Defining_Identifier
=>
12199 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
12201 Component_Definition
=>
12202 Make_Component_Definition
(Loc
,
12203 Aliased_Present
=> False,
12204 Subtype_Indication
=>
12205 New_Occurrence_Of
(RTE
(RE_Task_Info_Type
), Loc
)),
12207 Expression
=> New_Copy
(
12208 Expression
(First
(
12209 Pragma_Argument_Associations
(
12211 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
12214 -- Add the _CPU component if a CPU rep item is present
12216 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
12218 Make_Component_Declaration
(Loc
,
12219 Defining_Identifier
=>
12220 Make_Defining_Identifier
(Loc
, Name_uCPU
),
12222 Component_Definition
=>
12223 Make_Component_Definition
(Loc
,
12224 Aliased_Present
=> False,
12225 Subtype_Indication
=>
12226 New_Occurrence_Of
(RTE
(RE_CPU_Range
), Loc
))));
12229 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12230 -- present. If we are using a restricted run time this component will
12231 -- not be added (deadlines are not allowed by the Ravenscar profile).
12233 if not Restricted_Profile
12234 and then Present
(Taskdef
)
12235 and then Has_Relative_Deadline_Pragma
(Taskdef
)
12238 Make_Component_Declaration
(Loc
,
12239 Defining_Identifier
=>
12240 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
12242 Component_Definition
=>
12243 Make_Component_Definition
(Loc
,
12244 Aliased_Present
=> False,
12245 Subtype_Indication
=>
12246 New_Occurrence_Of
(RTE
(RE_Time_Span
), Loc
)),
12249 Convert_To
(RTE
(RE_Time_Span
),
12251 Expression
(First
(
12252 Pragma_Argument_Associations
(
12253 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
12256 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12257 -- item is present. If we are using a restricted run time this component
12258 -- will not be added (dispatching domains are not allowed by the
12259 -- Ravenscar profile).
12261 if not Restricted_Profile
12264 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
12267 Make_Component_Declaration
(Loc
,
12268 Defining_Identifier
=>
12269 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
12271 Component_Definition
=>
12272 Make_Component_Definition
(Loc
,
12273 Aliased_Present
=> False,
12274 Subtype_Indication
=>
12276 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
12279 Insert_After
(Size_Decl
, Rec_Decl
);
12281 -- Analyze the record declaration immediately after construction,
12282 -- because the initialization procedure is needed for single task
12283 -- declarations before the next entity is analyzed.
12285 Analyze
(Rec_Decl
);
12287 -- Create the declaration of the task body procedure
12289 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
12291 Make_Subprogram_Declaration
(Loc
,
12292 Specification
=> Proc_Spec
);
12293 Set_Is_Task_Body_Procedure
(Body_Decl
);
12295 Insert_After
(Rec_Decl
, Body_Decl
);
12297 -- The subprogram does not comes from source, so we have to indicate the
12298 -- need for debugging information explicitly.
12300 if Comes_From_Source
(Original_Node
(N
)) then
12301 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
12304 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12305 -- the corresponding record has been frozen.
12307 if Ada_Version
>= Ada_2005
then
12308 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
12311 -- Ada 2005 (AI-345): We must defer freezing to allow further
12312 -- declaration of primitive subprograms covering task interfaces
12314 if Ada_Version
<= Ada_95
then
12316 -- Now we can freeze the corresponding record. This needs manually
12317 -- freezing, since it is really part of the task type, and the task
12318 -- type is frozen at this stage. We of course need the initialization
12319 -- procedure for this corresponding record type and we won't get it
12320 -- in time if we don't freeze now.
12323 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
12325 if Is_Non_Empty_List
(L
) then
12326 Insert_List_After
(Body_Decl
, L
);
12331 -- Complete the expansion of access types to the current task type, if
12332 -- any were declared.
12334 Expand_Previous_Access_Type
(Tasktyp
);
12336 -- Create wrappers for entries that have contract cases, preconditions
12337 -- and postconditions.
12343 Ent
:= First_Entity
(Tasktyp
);
12344 while Present
(Ent
) loop
12345 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
) then
12346 Build_Contract_Wrapper
(Ent
, N
);
12352 end Expand_N_Task_Type_Declaration
;
12354 -------------------------------
12355 -- Expand_N_Timed_Entry_Call --
12356 -------------------------------
12358 -- A timed entry call in normal case is not implemented using ATC mechanism
12359 -- anymore for efficiency reason.
12369 -- is expanded as follows:
12371 -- 1) When T.E is a task entry_call;
12375 -- X : Task_Entry_Index := <entry index>;
12376 -- DX : Duration := To_Duration (D);
12377 -- M : Delay_Mode := <discriminant>;
12378 -- P : parms := (parm, parm, parm);
12381 -- Timed_Protected_Entry_Call
12382 -- (<acceptor-task>, X, P'Address, DX, M, B);
12390 -- 2) When T.E is a protected entry_call;
12394 -- X : Protected_Entry_Index := <entry index>;
12395 -- DX : Duration := To_Duration (D);
12396 -- M : Delay_Mode := <discriminant>;
12397 -- P : parms := (parm, parm, parm);
12400 -- Timed_Protected_Entry_Call
12401 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12409 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12410 -- is no delay and the triggering statements are executed. We first
12411 -- determine the kind of the triggering call and then execute a
12412 -- synchronized operation or a direct call.
12415 -- B : Boolean := False;
12416 -- C : Ada.Tags.Prim_Op_Kind;
12417 -- DX : Duration := To_Duration (D)
12418 -- K : Ada.Tags.Tagged_Kind :=
12419 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12420 -- M : Integer :=...;
12421 -- P : Parameters := (Param1 .. ParamN);
12425 -- if K = Ada.Tags.TK_Limited_Tagged
12426 -- or else K = Ada.Tags.TK_Tagged
12428 -- <dispatching-call>;
12433 -- Ada.Tags.Get_Offset_Index
12434 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12436 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12438 -- if C = POK_Protected_Entry
12439 -- or else C = POK_Task_Entry
12441 -- Param1 := P.Param1;
12443 -- ParamN := P.ParamN;
12447 -- if C = POK_Procedure
12448 -- or else C = POK_Protected_Procedure
12449 -- or else C = POK_Task_Procedure
12451 -- <dispatching-call>;
12457 -- <triggering-statements>
12459 -- <timed-statements>
12463 -- The triggering statement and the sequence of timed statements have not
12464 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12465 -- global references if within an instantiation.
12467 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
12468 Loc
: constant Source_Ptr
:= Sloc
(N
);
12471 Blk_Typ
: Entity_Id
;
12473 Call_Ent
: Entity_Id
;
12474 Conc_Typ_Stmts
: List_Id
;
12476 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
12479 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
12481 D_Type
: Entity_Id
;
12484 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
12485 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
12490 Is_Disp_Select
: Boolean;
12491 Lim_Typ_Stmts
: List_Id
;
12500 B
: Entity_Id
; -- Call status flag
12501 C
: Entity_Id
; -- Call kind
12502 D
: Entity_Id
; -- Delay
12503 K
: Entity_Id
; -- Tagged kind
12504 M
: Entity_Id
; -- Delay mode
12505 P
: Entity_Id
; -- Parameter block
12506 S
: Entity_Id
; -- Primitive operation slot
12508 -- Start of processing for Expand_N_Timed_Entry_Call
12511 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12512 -- was already reported on spec, so do not attempt to expand the call.
12514 if Restriction_Active
(No_Select_Statements
) then
12518 Process_Statements_For_Controlled_Objects
(E_Alt
);
12519 Process_Statements_For_Controlled_Objects
(D_Alt
);
12521 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
12523 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12524 -- may wrap them in blocks.
12526 E_Stats
:= Statements
(E_Alt
);
12527 D_Stats
:= Statements
(D_Alt
);
12529 -- The arguments in the call may require dynamic allocation, and the
12530 -- call statement may have been transformed into a block. The block
12531 -- may contain additional declarations for internal entities, and the
12532 -- original call is found by sequential search.
12534 if Nkind
(E_Call
) = N_Block_Statement
then
12535 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
12536 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
12537 N_Entry_Call_Statement
)
12544 Ada_Version
>= Ada_2005
12545 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
12547 if Is_Disp_Select
then
12548 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
12554 -- B : Boolean := False;
12556 B
:= Build_B
(Loc
, Decls
);
12559 -- C : Ada.Tags.Prim_Op_Kind;
12561 C
:= Build_C
(Loc
, Decls
);
12563 -- Because the analysis of all statements was disabled, manually
12564 -- analyze the delay statement.
12567 D_Stat
:= Original_Node
(D_Stat
);
12570 -- Build an entry call using Simple_Entry_Call
12572 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
12573 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
12575 Decls
:= Declarations
(E_Call
);
12576 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
12585 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12588 Make_Object_Declaration
(Loc
,
12589 Defining_Identifier
=> B
,
12590 Object_Definition
=>
12591 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
12594 -- Duration and mode processing
12596 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12598 -- Use the type of the delay expression (Calendar or Real_Time) to
12599 -- generate the appropriate conversion.
12601 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12602 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12603 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12605 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12606 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12608 Make_Function_Call
(Loc
,
12609 Name
=> New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
12610 Parameter_Associations
=>
12611 New_List
(New_Copy
(Expression
(D_Stat
))));
12613 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12614 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12616 Make_Function_Call
(Loc
,
12617 Name
=> New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
12618 Parameter_Associations
=>
12619 New_List
(New_Copy
(Expression
(D_Stat
))));
12622 D
:= Make_Temporary
(Loc
, 'D');
12628 Make_Object_Declaration
(Loc
,
12629 Defining_Identifier
=> D
,
12630 Object_Definition
=> New_Occurrence_Of
(Standard_Duration
, Loc
)));
12632 M
:= Make_Temporary
(Loc
, 'M');
12635 -- M : Integer := (0 | 1 | 2);
12638 Make_Object_Declaration
(Loc
,
12639 Defining_Identifier
=> M
,
12640 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
12641 Expression
=> D_Disc
));
12643 -- Do the assignment at this stage only because the evaluation of the
12644 -- expression must not occur before (see ACVC C97302A).
12647 Make_Assignment_Statement
(Loc
,
12648 Name
=> New_Occurrence_Of
(D
, Loc
),
12649 Expression
=> D_Conv
));
12651 -- Parameter block processing
12653 -- Manually create the parameter block for dispatching calls. In the
12654 -- case of entries, the block has already been created during the call
12655 -- to Build_Simple_Entry_Call.
12657 if Is_Disp_Select
then
12659 -- Tagged kind processing, generate:
12660 -- K : Ada.Tags.Tagged_Kind :=
12661 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12663 K
:= Build_K
(Loc
, Decls
, Obj
);
12665 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12667 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12669 -- Dispatch table slot processing, generate:
12672 S
:= Build_S
(Loc
, Decls
);
12675 -- S := Ada.Tags.Get_Offset_Index
12676 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12679 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12682 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12684 -- where Obj is the controlling formal parameter, S is the dispatch
12685 -- table slot number of the dispatching operation, P is the wrapped
12686 -- parameter block, D is the duration, M is the duration mode, C is
12687 -- the call kind and B is the call status.
12689 Params
:= New_List
;
12691 Append_To
(Params
, New_Copy_Tree
(Obj
));
12692 Append_To
(Params
, New_Occurrence_Of
(S
, Loc
));
12694 Make_Attribute_Reference
(Loc
,
12695 Prefix
=> New_Occurrence_Of
(P
, Loc
),
12696 Attribute_Name
=> Name_Address
));
12697 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12698 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12699 Append_To
(Params
, New_Occurrence_Of
(C
, Loc
));
12700 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12702 Append_To
(Conc_Typ_Stmts
,
12703 Make_Procedure_Call_Statement
(Loc
,
12707 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12708 Parameter_Associations
=> Params
));
12711 -- if C = POK_Protected_Entry
12712 -- or else C = POK_Task_Entry
12714 -- Param1 := P.Param1;
12716 -- ParamN := P.ParamN;
12719 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12721 -- Generate the if statement only when the packed parameters need
12722 -- explicit assignments to their corresponding actuals.
12724 if Present
(Unpack
) then
12725 Append_To
(Conc_Typ_Stmts
,
12726 Make_Implicit_If_Statement
(N
,
12732 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12735 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12739 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12741 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
12743 Then_Statements
=> Unpack
));
12749 -- if C = POK_Procedure
12750 -- or else C = POK_Protected_Procedure
12751 -- or else C = POK_Task_Procedure
12753 -- <dispatching-call>
12757 N_Stats
:= New_List
(
12758 Make_Implicit_If_Statement
(N
,
12763 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12765 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
12771 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12773 New_Occurrence_Of
(RTE
(
12774 RE_POK_Protected_Procedure
), Loc
)),
12777 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12780 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12782 Then_Statements
=> New_List
(E_Call
)));
12784 Append_To
(Conc_Typ_Stmts
,
12785 Make_Implicit_If_Statement
(N
,
12786 Condition
=> New_Occurrence_Of
(B
, Loc
),
12787 Then_Statements
=> N_Stats
));
12790 -- <dispatching-call>;
12794 New_List
(New_Copy_Tree
(E_Call
),
12795 Make_Assignment_Statement
(Loc
,
12796 Name
=> New_Occurrence_Of
(B
, Loc
),
12797 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12800 -- if K = Ada.Tags.TK_Limited_Tagged
12801 -- or else K = Ada.Tags.TK_Tagged
12809 Make_Implicit_If_Statement
(N
,
12810 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
12811 Then_Statements
=> Lim_Typ_Stmts
,
12812 Else_Statements
=> Conc_Typ_Stmts
));
12817 -- <triggering-statements>
12819 -- <timed-statements>
12823 Make_Implicit_If_Statement
(N
,
12824 Condition
=> New_Occurrence_Of
(B
, Loc
),
12825 Then_Statements
=> E_Stats
,
12826 Else_Statements
=> D_Stats
));
12829 -- Simple case of a non-dispatching trigger. Skip assignments to
12830 -- temporaries created for in-out parameters.
12832 -- This makes unwarranted assumptions about the shape of the expanded
12833 -- tree for the call, and should be cleaned up ???
12835 Stmt
:= First
(Stmts
);
12836 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
12840 -- Do the assignment at this stage only because the evaluation
12841 -- of the expression must not occur before (see ACVC C97302A).
12843 Insert_Before
(Stmt
,
12844 Make_Assignment_Statement
(Loc
,
12845 Name
=> New_Occurrence_Of
(D
, Loc
),
12846 Expression
=> D_Conv
));
12849 Params
:= Parameter_Associations
(Call
);
12851 -- For a protected type, we build a Timed_Protected_Entry_Call
12853 if Is_Protected_Type
(Etype
(Concval
)) then
12855 -- Create a new call statement
12857 Param
:= First
(Params
);
12858 while Present
(Param
)
12859 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
12864 Dummy
:= Remove_Next
(Next
(Param
));
12866 -- Remove garbage is following the Cancel_Param if present
12868 Dummy
:= Next
(Param
);
12870 -- Remove the mode of the Protected_Entry_Call call, then remove
12871 -- the Communication_Block of the Protected_Entry_Call call, and
12872 -- finally add Duration and a Delay_Mode parameter
12874 pragma Assert
(Present
(Param
));
12875 Rewrite
(Param
, New_Occurrence_Of
(D
, Loc
));
12877 Rewrite
(Dummy
, New_Occurrence_Of
(M
, Loc
));
12879 -- Add a Boolean flag for successful entry call
12881 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12883 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
12884 when System_Tasking_Protected_Objects_Entries
=>
12886 Make_Procedure_Call_Statement
(Loc
,
12889 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
12890 Parameter_Associations
=> Params
));
12893 raise Program_Error
;
12896 -- For the task case, build a Timed_Task_Entry_Call
12899 -- Create a new call statement
12901 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12902 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12903 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12906 Make_Procedure_Call_Statement
(Loc
,
12908 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
12909 Parameter_Associations
=> Params
));
12913 Make_Implicit_If_Statement
(N
,
12914 Condition
=> New_Occurrence_Of
(B
, Loc
),
12915 Then_Statements
=> E_Stats
,
12916 Else_Statements
=> D_Stats
));
12920 Make_Block_Statement
(Loc
,
12921 Declarations
=> Decls
,
12922 Handled_Statement_Sequence
=>
12923 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
12926 end Expand_N_Timed_Entry_Call
;
12928 ----------------------------------------
12929 -- Expand_Protected_Body_Declarations --
12930 ----------------------------------------
12932 procedure Expand_Protected_Body_Declarations
12934 Spec_Id
: Entity_Id
)
12937 if No_Run_Time_Mode
then
12938 Error_Msg_CRT
("protected body", N
);
12941 elsif Expander_Active
then
12943 -- Associate discriminals with the first subprogram or entry body to
12946 if Present
(First_Protected_Operation
(Declarations
(N
))) then
12947 Set_Discriminals
(Parent
(Spec_Id
));
12950 end Expand_Protected_Body_Declarations
;
12952 -------------------------
12953 -- External_Subprogram --
12954 -------------------------
12956 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
12957 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
12960 -- The internal and external subprograms follow each other on the entity
12961 -- chain. Note that previously private operations had no separate
12962 -- external subprogram. We now create one in all cases, because a
12963 -- private operation may actually appear in an external call, through
12964 -- a 'Access reference used for a callback.
12966 -- If the operation is a function that returns an anonymous access type,
12967 -- the corresponding itype appears before the operation, and must be
12970 -- This mechanism is fragile, there should be a real link between the
12971 -- two versions of the operation, but there is no place to put it ???
12973 if Is_Access_Type
(Next_Entity
(Subp
)) then
12974 return Next_Entity
(Next_Entity
(Subp
));
12976 return Next_Entity
(Subp
);
12978 end External_Subprogram
;
12980 ------------------------------
12981 -- Extract_Dispatching_Call --
12982 ------------------------------
12984 procedure Extract_Dispatching_Call
12986 Call_Ent
: out Entity_Id
;
12987 Object
: out Entity_Id
;
12988 Actuals
: out List_Id
;
12989 Formals
: out List_Id
)
12991 Call_Nam
: Node_Id
;
12994 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
12996 if Present
(Original_Node
(N
)) then
12997 Call_Nam
:= Name
(Original_Node
(N
));
12999 Call_Nam
:= Name
(N
);
13002 -- Retrieve the name of the dispatching procedure. It contains the
13003 -- dispatch table slot number.
13006 case Nkind
(Call_Nam
) is
13007 when N_Identifier
=>
13010 when N_Selected_Component
=>
13011 Call_Nam
:= Selector_Name
(Call_Nam
);
13014 raise Program_Error
;
13019 Actuals
:= Parameter_Associations
(N
);
13020 Call_Ent
:= Entity
(Call_Nam
);
13021 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
13022 Object
:= First
(Actuals
);
13024 if Present
(Original_Node
(Object
)) then
13025 Object
:= Original_Node
(Object
);
13028 -- If the type of the dispatching object is an access type then return
13029 -- an explicit dereference.
13031 if Is_Access_Type
(Etype
(Object
)) then
13032 Object
:= Make_Explicit_Dereference
(Sloc
(N
), Object
);
13035 end Extract_Dispatching_Call
;
13037 -------------------
13038 -- Extract_Entry --
13039 -------------------
13041 procedure Extract_Entry
13043 Concval
: out Node_Id
;
13044 Ename
: out Node_Id
;
13045 Index
: out Node_Id
)
13047 Nam
: constant Node_Id
:= Name
(N
);
13050 -- For a simple entry, the name is a selected component, with the
13051 -- prefix being the task value, and the selector being the entry.
13053 if Nkind
(Nam
) = N_Selected_Component
then
13054 Concval
:= Prefix
(Nam
);
13055 Ename
:= Selector_Name
(Nam
);
13058 -- For a member of an entry family, the name is an indexed component
13059 -- where the prefix is a selected component, whose prefix in turn is
13060 -- the task value, and whose selector is the entry family. The single
13061 -- expression in the expressions list of the indexed component is the
13062 -- subscript for the family.
13064 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
13065 Concval
:= Prefix
(Prefix
(Nam
));
13066 Ename
:= Selector_Name
(Prefix
(Nam
));
13067 Index
:= First
(Expressions
(Nam
));
13070 -- Through indirection, the type may actually be a limited view of a
13071 -- concurrent type. When compiling a call, the non-limited view of the
13072 -- type is visible.
13074 if From_Limited_With
(Etype
(Concval
)) then
13075 Set_Etype
(Concval
, Non_Limited_View
(Etype
(Concval
)));
13079 -------------------
13080 -- Family_Offset --
13081 -------------------
13083 function Family_Offset
13088 Cap
: Boolean) return Node_Id
13094 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
13095 -- If one of the bounds is a reference to a discriminant, replace with
13096 -- corresponding discriminal of type. Within the body of a task retrieve
13097 -- the renamed discriminant by simple visibility, using its generated
13098 -- name. Within a protected object, find the original discriminant and
13099 -- replace it with the discriminal of the current protected operation.
13101 ------------------------------
13102 -- Convert_Discriminant_Ref --
13103 ------------------------------
13105 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
13106 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
13111 if Is_Entity_Name
(Bound
)
13112 and then Ekind
(Entity
(Bound
)) = E_Discriminant
13114 if Is_Task_Type
(Ttyp
) and then Has_Completion
(Ttyp
) then
13115 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13116 Find_Direct_Name
(B
);
13118 elsif Is_Protected_Type
(Ttyp
) then
13119 D
:= First_Discriminant
(Ttyp
);
13120 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
13121 Next_Discriminant
(D
);
13124 B
:= New_Occurrence_Of
(Discriminal
(D
), Loc
);
13127 B
:= New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
13130 elsif Nkind
(Bound
) = N_Attribute_Reference
then
13134 B
:= New_Copy_Tree
(Bound
);
13138 Make_Attribute_Reference
(Loc
,
13139 Attribute_Name
=> Name_Pos
,
13140 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
13141 Expressions
=> New_List
(B
));
13142 end Convert_Discriminant_Ref
;
13144 -- Start of processing for Family_Offset
13147 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
13148 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
13151 if Is_Task_Type
(Ttyp
) then
13152 Ityp
:= RTE
(RE_Task_Entry_Index
);
13154 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13158 Make_Attribute_Reference
(Loc
,
13159 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13160 Attribute_Name
=> Name_Min
,
13161 Expressions
=> New_List
(
13163 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
13166 Make_Attribute_Reference
(Loc
,
13167 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13168 Attribute_Name
=> Name_Max
,
13169 Expressions
=> New_List
(
13171 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
13174 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
13181 function Family_Size
13186 Cap
: Boolean) return Node_Id
13191 if Is_Task_Type
(Ttyp
) then
13192 Ityp
:= RTE
(RE_Task_Entry_Index
);
13194 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13198 Make_Attribute_Reference
(Loc
,
13199 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13200 Attribute_Name
=> Name_Max
,
13201 Expressions
=> New_List
(
13203 Left_Opnd
=> Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
13204 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
13205 Make_Integer_Literal
(Loc
, 0)));
13208 ----------------------------
13209 -- Find_Enclosing_Context --
13210 ----------------------------
13212 procedure Find_Enclosing_Context
13214 Context
: out Node_Id
;
13215 Context_Id
: out Entity_Id
;
13216 Context_Decls
: out List_Id
)
13219 -- Traverse the parent chain looking for an enclosing body, block,
13220 -- package or return statement.
13222 Context
:= Parent
(N
);
13223 while not Nkind_In
(Context
, N_Block_Statement
,
13225 N_Extended_Return_Statement
,
13227 N_Package_Declaration
,
13231 Context
:= Parent
(Context
);
13234 -- Extract the constituents of the context
13236 if Nkind
(Context
) = N_Extended_Return_Statement
then
13237 Context_Decls
:= Return_Object_Declarations
(Context
);
13238 Context_Id
:= Return_Statement_Entity
(Context
);
13240 -- Package declarations and bodies use a common library-level activation
13241 -- chain or task master, therefore return the package declaration as the
13242 -- proper carrier for the appropriate flag.
13244 elsif Nkind
(Context
) = N_Package_Body
then
13245 Context_Decls
:= Declarations
(Context
);
13246 Context_Id
:= Corresponding_Spec
(Context
);
13247 Context
:= Parent
(Context_Id
);
13249 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
13250 Context
:= Parent
(Parent
(Context
));
13252 Context
:= Parent
(Context
);
13255 elsif Nkind
(Context
) = N_Package_Declaration
then
13256 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
13257 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13259 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13260 Context_Id
:= Defining_Identifier
(Context_Id
);
13264 Context_Decls
:= Declarations
(Context
);
13266 if Nkind
(Context
) = N_Block_Statement
then
13267 Context_Id
:= Entity
(Identifier
(Context
));
13269 elsif Nkind
(Context
) = N_Entry_Body
then
13270 Context_Id
:= Defining_Identifier
(Context
);
13272 elsif Nkind
(Context
) = N_Subprogram_Body
then
13273 if Present
(Corresponding_Spec
(Context
)) then
13274 Context_Id
:= Corresponding_Spec
(Context
);
13276 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13278 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13279 Context_Id
:= Defining_Identifier
(Context_Id
);
13283 elsif Nkind
(Context
) = N_Task_Body
then
13284 Context_Id
:= Corresponding_Spec
(Context
);
13287 raise Program_Error
;
13291 pragma Assert
(Present
(Context
));
13292 pragma Assert
(Present
(Context_Id
));
13293 pragma Assert
(Present
(Context_Decls
));
13294 end Find_Enclosing_Context
;
13296 -----------------------
13297 -- Find_Master_Scope --
13298 -----------------------
13300 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
13304 -- In Ada 2005, the master is the innermost enclosing scope that is not
13305 -- transient. If the enclosing block is the rewriting of a call or the
13306 -- scope is an extended return statement this is valid master. The
13307 -- master in an extended return is only used within the return, and is
13308 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13309 -- now before that overwriting occurs.
13313 if Ada_Version
>= Ada_2005
then
13314 while Is_Internal
(S
) loop
13315 if Nkind
(Parent
(S
)) = N_Block_Statement
13317 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
13321 elsif Ekind
(S
) = E_Return_Statement
then
13331 end Find_Master_Scope
;
13333 -------------------------------
13334 -- First_Protected_Operation --
13335 -------------------------------
13337 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
13338 First_Op
: Node_Id
;
13341 First_Op
:= First
(D
);
13342 while Present
(First_Op
)
13343 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
13349 end First_Protected_Operation
;
13351 ---------------------------------------
13352 -- Install_Private_Data_Declarations --
13353 ---------------------------------------
13355 procedure Install_Private_Data_Declarations
13357 Spec_Id
: Entity_Id
;
13358 Conc_Typ
: Entity_Id
;
13359 Body_Nod
: Node_Id
;
13361 Barrier
: Boolean := False;
13362 Family
: Boolean := False)
13364 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
13367 Insert_Node
: Node_Id
:= Empty
;
13368 Obj_Ent
: Entity_Id
;
13370 procedure Add
(Decl
: Node_Id
);
13371 -- Add a single declaration after Insert_Node. If this is the first
13372 -- addition, Decl is added to the front of Decls and it becomes the
13375 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
13376 -- The bounds of an entry index may depend on discriminants, create a
13377 -- reference to the corresponding prival. Otherwise return a duplicate
13378 -- of the original bound.
13384 procedure Add
(Decl
: Node_Id
) is
13386 if No
(Insert_Node
) then
13387 Prepend_To
(Decls
, Decl
);
13389 Insert_After
(Insert_Node
, Decl
);
13392 Insert_Node
:= Decl
;
13395 --------------------------
13396 -- Replace_Discriminant --
13397 --------------------------
13399 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
13401 if Nkind
(Bound
) = N_Identifier
13402 and then Is_Discriminal
(Entity
(Bound
))
13404 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13406 return Duplicate_Subexpr
(Bound
);
13410 -- Start of processing for Install_Private_Data_Declarations
13413 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13414 -- formal parameter _O, _object or _task depending on the context.
13416 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
13418 -- Special processing of _O for barrier functions, protected entries
13425 (Ekind
(Spec_Id
) = E_Entry
13426 or else Ekind
(Spec_Id
) = E_Entry_Family
))
13429 Conc_Rec
: constant Entity_Id
:=
13430 Corresponding_Record_Type
(Conc_Typ
);
13431 Typ_Id
: constant Entity_Id
:=
13432 Make_Defining_Identifier
(Loc
,
13433 New_External_Name
(Chars
(Conc_Rec
), 'P'));
13436 -- type prot_typVP is access prot_typV;
13439 Make_Full_Type_Declaration
(Loc
,
13440 Defining_Identifier
=> Typ_Id
,
13442 Make_Access_To_Object_Definition
(Loc
,
13443 Subtype_Indication
=>
13444 New_Occurrence_Of
(Conc_Rec
, Loc
)));
13448 -- _object : prot_typVP := prot_typV (_O);
13451 Make_Object_Declaration
(Loc
,
13452 Defining_Identifier
=>
13453 Make_Defining_Identifier
(Loc
, Name_uObject
),
13454 Object_Definition
=> New_Occurrence_Of
(Typ_Id
, Loc
),
13456 Unchecked_Convert_To
(Typ_Id
,
13457 New_Occurrence_Of
(Obj_Ent
, Loc
)));
13460 -- Set the reference to the concurrent object
13462 Obj_Ent
:= Defining_Identifier
(Decl
);
13466 -- Step 2: Create the Protection object and build its declaration for
13467 -- any protected entry (family) of subprogram. Note for the lock-free
13468 -- implementation, the Protection object is not needed anymore.
13470 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
13472 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
13476 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
13478 -- Determine the proper protection type
13480 if Has_Attach_Handler
(Conc_Typ
)
13481 and then not Restricted_Profile
13483 Prot_Typ
:= RE_Static_Interrupt_Protection
;
13485 elsif Has_Interrupt_Handler
(Conc_Typ
)
13486 and then not Restriction_Active
(No_Dynamic_Attachment
)
13488 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
13491 case Corresponding_Runtime_Package
(Conc_Typ
) is
13492 when System_Tasking_Protected_Objects_Entries
=>
13493 Prot_Typ
:= RE_Protection_Entries
;
13495 when System_Tasking_Protected_Objects_Single_Entry
=>
13496 Prot_Typ
:= RE_Protection_Entry
;
13498 when System_Tasking_Protected_Objects
=>
13499 Prot_Typ
:= RE_Protection
;
13502 raise Program_Error
;
13507 -- conc_typR : protection_typ renames _object._object;
13510 Make_Object_Renaming_Declaration
(Loc
,
13511 Defining_Identifier
=> Prot_Ent
,
13513 New_Occurrence_Of
(RTE
(Prot_Typ
), Loc
),
13515 Make_Selected_Component
(Loc
,
13516 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13517 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
13522 -- Step 3: Add discriminant renamings (if any)
13524 if Has_Discriminants
(Conc_Typ
) then
13529 D
:= First_Discriminant
(Conc_Typ
);
13530 while Present
(D
) loop
13532 -- Adjust the source location
13534 Set_Sloc
(Discriminal
(D
), Loc
);
13537 -- discr_name : discr_typ renames _object.discr_name;
13539 -- discr_name : discr_typ renames _task.discr_name;
13542 Make_Object_Renaming_Declaration
(Loc
,
13543 Defining_Identifier
=> Discriminal
(D
),
13544 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
13546 Make_Selected_Component
(Loc
,
13547 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13548 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
13551 Next_Discriminant
(D
);
13556 -- Step 4: Add private component renamings (if any)
13558 if Is_Protected
then
13559 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
13561 if Present
(Private_Declarations
(Def
)) then
13564 Comp_Id
: Entity_Id
;
13565 Decl_Id
: Entity_Id
;
13568 Comp
:= First
(Private_Declarations
(Def
));
13569 while Present
(Comp
) loop
13570 if Nkind
(Comp
) = N_Component_Declaration
then
13571 Comp_Id
:= Defining_Identifier
(Comp
);
13573 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
13575 -- Minimal decoration
13577 if Ekind
(Spec_Id
) = E_Function
then
13578 Set_Ekind
(Decl_Id
, E_Constant
);
13580 Set_Ekind
(Decl_Id
, E_Variable
);
13583 Set_Prival
(Comp_Id
, Decl_Id
);
13584 Set_Prival_Link
(Decl_Id
, Comp_Id
);
13585 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13588 -- comp_name : comp_typ renames _object.comp_name;
13591 Make_Object_Renaming_Declaration
(Loc
,
13592 Defining_Identifier
=> Decl_Id
,
13594 New_Occurrence_Of
(Etype
(Comp_Id
), Loc
),
13596 Make_Selected_Component
(Loc
,
13598 New_Occurrence_Of
(Obj_Ent
, Loc
),
13600 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
13610 -- Step 5: Add the declaration of the entry index and the associated
13611 -- type for barrier functions and entry families.
13613 if (Barrier
and Family
) or else Ekind
(Spec_Id
) = E_Entry_Family
then
13615 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13616 Index
: constant Entity_Id
:=
13617 Defining_Identifier
13618 (Entry_Index_Specification
13619 (Entry_Body_Formal_Part
(Body_Nod
)));
13620 Index_Con
: constant Entity_Id
:=
13621 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13623 Index_Typ
: Entity_Id
;
13627 -- Minimal decoration
13629 Set_Ekind
(Index_Con
, E_Constant
);
13630 Set_Entry_Index_Constant
(Index
, Index_Con
);
13631 Set_Discriminal_Link
(Index_Con
, Index
);
13633 -- Retrieve the bounds of the entry family
13635 High
:= Type_High_Bound
(Etype
(Index
));
13636 Low
:= Type_Low_Bound
(Etype
(Index
));
13638 -- In the simple case the entry family is given by a subtype
13639 -- mark and the index constant has the same type.
13641 if Is_Entity_Name
(Original_Node
(
13642 Discrete_Subtype_Definition
(Parent
(Index
))))
13644 Index_Typ
:= Etype
(Index
);
13646 -- Otherwise a new subtype declaration is required
13649 High
:= Replace_Bound
(High
);
13650 Low
:= Replace_Bound
(Low
);
13652 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13655 -- subtype Jnn is <Etype of Index> range Low .. High;
13658 Make_Subtype_Declaration
(Loc
,
13659 Defining_Identifier
=> Index_Typ
,
13660 Subtype_Indication
=>
13661 Make_Subtype_Indication
(Loc
,
13663 New_Occurrence_Of
(Base_Type
(Etype
(Index
)), Loc
),
13665 Make_Range_Constraint
(Loc
,
13666 Range_Expression
=>
13667 Make_Range
(Loc
, Low
, High
))));
13671 Set_Etype
(Index_Con
, Index_Typ
);
13673 -- Create the object which designates the index:
13674 -- J : constant Jnn :=
13675 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13677 -- where Jnn is the subtype created above or the original type of
13678 -- the index, _E is a formal of the protected body subprogram and
13679 -- <index expr> is the index of the first family member.
13682 Make_Object_Declaration
(Loc
,
13683 Defining_Identifier
=> Index_Con
,
13684 Constant_Present
=> True,
13685 Object_Definition
=>
13686 New_Occurrence_Of
(Index_Typ
, Loc
),
13689 Make_Attribute_Reference
(Loc
,
13691 New_Occurrence_Of
(Index_Typ
, Loc
),
13692 Attribute_Name
=> Name_Val
,
13694 Expressions
=> New_List
(
13698 Make_Op_Subtract
(Loc
,
13699 Left_Opnd
=> New_Occurrence_Of
(E
, Loc
),
13701 Entry_Index_Expression
(Loc
,
13702 Defining_Identifier
(Body_Nod
),
13706 Make_Attribute_Reference
(Loc
,
13708 New_Occurrence_Of
(Index_Typ
, Loc
),
13709 Attribute_Name
=> Name_Pos
,
13710 Expressions
=> New_List
(
13711 Make_Attribute_Reference
(Loc
,
13713 New_Occurrence_Of
(Index_Typ
, Loc
),
13714 Attribute_Name
=> Name_First
)))))));
13718 end Install_Private_Data_Declarations
;
13720 -----------------------
13721 -- Is_Exception_Safe --
13722 -----------------------
13724 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean is
13726 function Has_Side_Effect
(N
: Node_Id
) return Boolean;
13727 -- Return True whenever encountering a subprogram call or raise
13728 -- statement of any kind in the sequence of statements
13730 ---------------------
13731 -- Has_Side_Effect --
13732 ---------------------
13734 -- What is this doing buried two levels down in exp_ch9. It seems like a
13735 -- generally useful function, and indeed there may be code duplication
13736 -- going on here ???
13738 function Has_Side_Effect
(N
: Node_Id
) return Boolean is
13742 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean;
13743 -- Indicate whether N is a subprogram call or a raise statement
13745 ----------------------
13746 -- Is_Call_Or_Raise --
13747 ----------------------
13749 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean is
13751 return Nkind_In
(N
, N_Procedure_Call_Statement
,
13754 N_Raise_Constraint_Error
,
13755 N_Raise_Program_Error
,
13756 N_Raise_Storage_Error
);
13757 end Is_Call_Or_Raise
;
13759 -- Start of processing for Has_Side_Effect
13763 while Present
(Stmt
) loop
13764 if Is_Call_Or_Raise
(Stmt
) then
13768 -- An object declaration can also contain a function call or a
13769 -- raise statement.
13771 if Nkind
(Stmt
) = N_Object_Declaration
then
13772 Expr
:= Expression
(Stmt
);
13774 if Present
(Expr
) and then Is_Call_Or_Raise
(Expr
) then
13783 end Has_Side_Effect
;
13785 -- Start of processing for Is_Exception_Safe
13788 -- When exceptions can't be propagated, the subprogram returns normally
13790 if No_Exception_Handlers_Set
then
13794 -- If the checks handled by the back end are not disabled, we cannot
13795 -- ensure that no exception will be raised.
13797 if not Access_Checks_Suppressed
(Empty
)
13798 or else not Discriminant_Checks_Suppressed
(Empty
)
13799 or else not Range_Checks_Suppressed
(Empty
)
13800 or else not Index_Checks_Suppressed
(Empty
)
13801 or else Opt
.Stack_Checking_Enabled
13806 if Has_Side_Effect
(First
(Declarations
(Subprogram
)))
13809 (First
(Statements
(Handled_Statement_Sequence
(Subprogram
))))
13815 end Is_Exception_Safe
;
13817 ---------------------------------
13818 -- Is_Potentially_Large_Family --
13819 ---------------------------------
13821 function Is_Potentially_Large_Family
13822 (Base_Index
: Entity_Id
;
13823 Conctyp
: Entity_Id
;
13825 Hi
: Node_Id
) return Boolean
13828 return Scope
(Base_Index
) = Standard_Standard
13829 and then Base_Index
= Base_Type
(Standard_Integer
)
13830 and then Has_Discriminants
(Conctyp
)
13832 Present
(Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
13834 (Denotes_Discriminant
(Lo
, True)
13836 Denotes_Discriminant
(Hi
, True));
13837 end Is_Potentially_Large_Family
;
13839 -------------------------------------
13840 -- Is_Private_Primitive_Subprogram --
13841 -------------------------------------
13843 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13846 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13847 and then Is_Private_Primitive
(Id
);
13848 end Is_Private_Primitive_Subprogram
;
13854 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13855 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13856 Formal
: Entity_Id
;
13859 Formal
:= First_Formal
(Bod_Subp
);
13860 while Present
(Formal
) loop
13862 -- Look for formal parameter _E
13864 if Chars
(Formal
) = Name_uE
then
13868 Next_Formal
(Formal
);
13871 -- A protected body subprogram should always have the parameter in
13874 raise Program_Error
;
13877 --------------------------------
13878 -- Make_Initialize_Protection --
13879 --------------------------------
13881 function Make_Initialize_Protection
13882 (Protect_Rec
: Entity_Id
) return List_Id
13884 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
13887 Ptyp
: constant Node_Id
:=
13888 Corresponding_Concurrent_Type
(Protect_Rec
);
13890 L
: constant List_Id
:= New_List
;
13891 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
13892 Prio_Type
: Entity_Id
;
13893 Prio_Var
: Entity_Id
:= Empty
;
13894 Restricted
: constant Boolean := Restricted_Profile
;
13897 -- We may need two calls to properly initialize the object, one to
13898 -- Initialize_Protection, and possibly one to Install_Handlers if we
13899 -- have a pragma Attach_Handler.
13901 -- Get protected declaration. In the case of a task type declaration,
13902 -- this is simply the parent of the protected type entity. In the single
13903 -- protected object declaration, this parent will be the implicit type,
13904 -- and we can find the corresponding single protected object declaration
13905 -- by searching forward in the declaration list in the tree.
13907 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13908 -- of this type should have been removed during semantic analysis.
13910 Pdec
:= Parent
(Ptyp
);
13911 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
13912 N_Single_Protected_Declaration
)
13917 -- Build the parameter list for the call. Note that _Init is the name
13918 -- of the formal for the object to be initialized, which is the task
13919 -- value record itself.
13923 -- For lock-free implementation, skip initializations of the Protection
13926 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13928 -- Object parameter. This is a pointer to the object of type
13929 -- Protection used by the GNARL to control the protected object.
13932 Make_Attribute_Reference
(Loc
,
13934 Make_Selected_Component
(Loc
,
13935 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13936 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
13937 Attribute_Name
=> Name_Unchecked_Access
));
13939 -- Priority parameter. Set to Unspecified_Priority unless there is a
13940 -- Priority rep item, in which case we take the value from the pragma
13941 -- or attribute definition clause, or there is an Interrupt_Priority
13942 -- rep item and no Priority rep item, and we set the ceiling to
13943 -- Interrupt_Priority'Last, an implementation-defined value, see
13946 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
13948 Prio_Clause
: constant Node_Id
:=
13950 (Ptyp
, Name_Priority
, Check_Parents
=> False);
13957 if Nkind
(Prio_Clause
) = N_Pragma
then
13960 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
13962 -- Get_Rep_Item returns either priority pragma.
13964 if Pragma_Name
(Prio_Clause
) = Name_Priority
then
13965 Prio_Type
:= RTE
(RE_Any_Priority
);
13967 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13970 -- Attribute definition clause Priority
13973 if Chars
(Prio_Clause
) = Name_Priority
then
13974 Prio_Type
:= RTE
(RE_Any_Priority
);
13976 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13979 Prio
:= Expression
(Prio_Clause
);
13982 -- Always create a locale variable to capture the priority.
13983 -- The priority is also passed to Install_Restriced_Handlers.
13984 -- Note that it is really necessary to create this variable
13985 -- explicitly. It might be thought that removing side effects
13986 -- would the appropriate approach, but that could generate
13987 -- declarations improperly placed in the enclosing scope.
13989 Prio_Var
:= Make_Temporary
(Loc
, 'R', Prio
);
13991 Make_Object_Declaration
(Loc
,
13992 Defining_Identifier
=> Prio_Var
,
13993 Object_Definition
=> New_Occurrence_Of
(Prio_Type
, Loc
),
13994 Expression
=> Relocate_Node
(Prio
)));
13996 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
13999 -- When no priority is specified but an xx_Handler pragma is, we
14000 -- default to System.Interrupts.Default_Interrupt_Priority, see
14003 elsif Has_Attach_Handler
(Ptyp
)
14004 or else Has_Interrupt_Handler
(Ptyp
)
14007 New_Occurrence_Of
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
14009 -- Normal case, no priority or xx_Handler specified, default priority
14013 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14016 -- Test for Compiler_Info parameter. This parameter allows entry body
14017 -- procedures and barrier functions to be called from the runtime. It
14018 -- is a pointer to the record generated by the compiler to represent
14019 -- the protected object.
14021 -- A protected type without entries that covers an interface and
14022 -- overrides the abstract routines with protected procedures is
14023 -- considered equivalent to a protected type with entries in the
14024 -- context of dispatching select statements.
14026 -- Protected types with interrupt handlers (when not using a
14027 -- restricted profile) are also considered equivalent to protected
14028 -- types with entries.
14030 -- The types which are used (Static_Interrupt_Protection and
14031 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14034 Pkg_Id
: constant RTU_Id
:= Corresponding_Runtime_Package
(Ptyp
);
14036 Called_Subp
: RE_Id
;
14040 when System_Tasking_Protected_Objects_Entries
=>
14041 Called_Subp
:= RE_Initialize_Protection_Entries
;
14043 -- Argument Compiler_Info
14046 Make_Attribute_Reference
(Loc
,
14047 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14048 Attribute_Name
=> Name_Address
));
14050 when System_Tasking_Protected_Objects_Single_Entry
=>
14051 Called_Subp
:= RE_Initialize_Protection_Entry
;
14053 -- Argument Compiler_Info
14056 Make_Attribute_Reference
(Loc
,
14057 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14058 Attribute_Name
=> Name_Address
));
14060 when System_Tasking_Protected_Objects
=>
14061 Called_Subp
:= RE_Initialize_Protection
;
14064 raise Program_Error
;
14067 -- Entry_Bodies parameter. This is a pointer to an array of
14068 -- pointers to the entry body procedures and barrier functions of
14069 -- the object. If the protected type has no entries this object
14070 -- will not exist, in this case, pass a null (it can happen when
14071 -- there are protected interrupt handlers or interfaces).
14074 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
14076 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14077 -- multiple entries).
14080 Make_Attribute_Reference
(Loc
,
14081 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14082 Attribute_Name
=> Name_Unrestricted_Access
));
14084 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14086 -- Find index mapping function (clumsy but ok for now)
14088 while Ekind
(P_Arr
) /= E_Function
loop
14089 Next_Entity
(P_Arr
);
14093 Make_Attribute_Reference
(Loc
,
14094 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14095 Attribute_Name
=> Name_Unrestricted_Access
));
14098 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
14100 -- This is the case where we have a protected object with
14101 -- interfaces and no entries, and the single entry restriction
14102 -- is in effect. We pass a null pointer for the entry
14103 -- parameter because there is no actual entry.
14105 Append_To
(Args
, Make_Null
(Loc
));
14107 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14109 -- This is the case where we have a protected object with no
14111 -- - either interrupt handlers with non restricted profile,
14113 -- Note that the types which are used for interrupt handlers
14114 -- (Static/Dynamic_Interrupt_Protection) are derived from
14115 -- Protection_Entries. We pass two null pointers because there
14116 -- is no actual entry, and the initialization procedure needs
14117 -- both Entry_Bodies and Find_Body_Index.
14119 Append_To
(Args
, Make_Null
(Loc
));
14120 Append_To
(Args
, Make_Null
(Loc
));
14124 Make_Procedure_Call_Statement
(Loc
,
14126 New_Occurrence_Of
(RTE
(Called_Subp
), Loc
),
14127 Parameter_Associations
=> Args
));
14131 if Has_Attach_Handler
(Ptyp
) then
14133 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14134 -- make the following call:
14136 -- Install_Handlers (_object,
14137 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14139 -- or, in the case of Ravenscar:
14141 -- Install_Restricted_Handlers
14142 -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14145 Args
: constant List_Id
:= New_List
;
14146 Table
: constant List_Id
:= New_List
;
14147 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
14150 -- Build the Priority parameter (only for ravenscar)
14154 -- Priority comes from a pragma
14156 if Present
(Prio_Var
) then
14157 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14159 -- Priority is the default one
14164 (RTE
(RE_Default_Interrupt_Priority
), Loc
));
14168 -- Build the Attach_Handler table argument
14170 while Present
(Ritem
) loop
14171 if Nkind
(Ritem
) = N_Pragma
14172 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
14175 Handler
: constant Node_Id
:=
14176 First
(Pragma_Argument_Associations
(Ritem
));
14178 Interrupt
: constant Node_Id
:= Next
(Handler
);
14179 Expr
: constant Node_Id
:= Expression
(Interrupt
);
14183 Make_Aggregate
(Loc
, Expressions
=> New_List
(
14184 Unchecked_Convert_To
14185 (RTE
(RE_System_Interrupt_Id
), Expr
),
14186 Make_Attribute_Reference
(Loc
,
14188 Make_Selected_Component
(Loc
,
14190 Make_Identifier
(Loc
, Name_uInit
),
14192 Duplicate_Subexpr_No_Checks
14193 (Expression
(Handler
))),
14194 Attribute_Name
=> Name_Access
))));
14198 Next_Rep_Item
(Ritem
);
14201 -- Append the table argument we just built
14203 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
14205 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14206 -- call to the statements.
14209 -- Call a simplified version of Install_Handlers to be used
14210 -- when the Ravenscar restrictions are in effect
14211 -- (Install_Restricted_Handlers).
14214 Make_Procedure_Call_Statement
(Loc
,
14217 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
14218 Parameter_Associations
=> Args
));
14221 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14223 -- First, prepends the _object argument
14226 Make_Attribute_Reference
(Loc
,
14228 Make_Selected_Component
(Loc
,
14229 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14231 Make_Identifier
(Loc
, Name_uObject
)),
14232 Attribute_Name
=> Name_Unchecked_Access
));
14235 -- Then, insert call to Install_Handlers
14238 Make_Procedure_Call_Statement
(Loc
,
14240 New_Occurrence_Of
(RTE
(RE_Install_Handlers
), Loc
),
14241 Parameter_Associations
=> Args
));
14247 end Make_Initialize_Protection
;
14249 ---------------------------
14250 -- Make_Task_Create_Call --
14251 ---------------------------
14253 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
14254 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
14264 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
14265 Tnam
:= Chars
(Ttyp
);
14267 -- Get task declaration. In the case of a task type declaration, this is
14268 -- simply the parent of the task type entity. In the single task
14269 -- declaration, this parent will be the implicit type, and we can find
14270 -- the corresponding single task declaration by searching forward in the
14271 -- declaration list in the tree.
14273 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14274 -- this type should have been removed during semantic analysis.
14276 Tdec
:= Parent
(Ttyp
);
14277 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
14278 N_Single_Task_Declaration
)
14283 -- Now we can find the task definition from this declaration
14285 Tdef
:= Task_Definition
(Tdec
);
14287 -- Build the parameter list for the call. Note that _Init is the name
14288 -- of the formal for the object to be initialized, which is the task
14289 -- value record itself.
14293 -- Priority parameter. Set to Unspecified_Priority unless there is a
14294 -- Priority rep item, in which case we take the value from the rep item.
14296 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
14298 Make_Selected_Component
(Loc
,
14299 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14300 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
14303 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14306 -- Optional Stack parameter
14308 if Restricted_Profile
then
14310 -- If the stack has been preallocated by the expander then
14311 -- pass its address. Otherwise, pass a null address.
14313 if Preallocated_Stacks_On_Target
then
14315 Make_Attribute_Reference
(Loc
,
14317 Make_Selected_Component
(Loc
,
14318 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14319 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
14320 Attribute_Name
=> Name_Address
));
14324 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
14328 -- Size parameter. If no Storage_Size pragma is present, then
14329 -- the size is taken from the taskZ variable for the type, which
14330 -- is either Unspecified_Size, or has been reset by the use of
14331 -- a Storage_Size attribute definition clause. If a pragma is
14332 -- present, then the size is taken from the _Size field of the
14333 -- task value record, which was set from the pragma value.
14335 if Present
(Tdef
) and then Has_Storage_Size_Pragma
(Tdef
) then
14337 Make_Selected_Component
(Loc
,
14338 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14339 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
14343 New_Occurrence_Of
(Storage_Size_Variable
(Ttyp
), Loc
));
14346 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14347 -- Task_Info pragma, in which case we take the value from the pragma.
14349 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
14351 Make_Selected_Component
(Loc
,
14352 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14353 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
14357 New_Occurrence_Of
(RTE
(RE_Unspecified_Task_Info
), Loc
));
14360 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14361 -- in which case we take the value from the rep item. The parameter is
14362 -- passed as an Integer because in the case of unspecified CPU the
14363 -- value is not in the range of CPU_Range.
14365 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
14367 Convert_To
(Standard_Integer
,
14368 Make_Selected_Component
(Loc
,
14369 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14370 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
14373 New_Occurrence_Of
(RTE
(RE_Unspecified_CPU
), Loc
));
14376 if not Restricted_Profile
then
14378 -- Deadline parameter. If no Relative_Deadline pragma is present,
14379 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14380 -- the deadline is taken from the _Relative_Deadline field of the
14381 -- task value record, which was set from the pragma value. Note that
14382 -- this parameter must not be generated for the restricted profiles
14383 -- since Ravenscar does not allow deadlines.
14385 -- Case where pragma Relative_Deadline applies: use given value
14387 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
14389 Make_Selected_Component
(Loc
,
14390 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14392 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
14394 -- No pragma Relative_Deadline apply to the task
14398 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14401 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14402 -- present, then the dispatching domain is null. If a rep item is
14403 -- present, then the dispatching domain is taken from the
14404 -- _Dispatching_Domain field of the task value record, which was set
14405 -- from the rep item value.
14407 -- Case where Dispatching_Domain rep item applies: use given value
14410 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
14413 Make_Selected_Component
(Loc
,
14415 Make_Identifier
(Loc
, Name_uInit
),
14417 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
14419 -- No pragma or aspect Dispatching_Domain applies to the task
14422 Append_To
(Args
, Make_Null
(Loc
));
14425 -- Number of entries. This is an expression of the form:
14427 -- n + _Init.a'Length + _Init.a'B'Length + ...
14429 -- where a,b... are the entry family names for the task definition
14432 Build_Entry_Count_Expression
14437 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
14439 Append_To
(Args
, Ecount
);
14441 -- Master parameter. This is a reference to the _Master parameter of
14442 -- the initialization procedure, except in the case of the pragma
14443 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14444 -- System.Tasking.Library_Task_Level.
14446 if Restriction_Active
(No_Task_Hierarchy
) = False then
14447 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
14450 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
14454 -- State parameter. This is a pointer to the task body procedure. The
14455 -- required value is obtained by taking 'Unrestricted_Access of the task
14456 -- body procedure and converting it (with an unchecked conversion) to
14457 -- the type required by the task kernel. For further details, see the
14458 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14459 -- than 'Address in order to avoid creating trampolines.
14462 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
14463 Subp_Ptr_Typ
: constant Node_Id
:=
14464 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
14465 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
14468 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
14469 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
14471 -- Be sure to freeze a reference to the access-to-subprogram type,
14472 -- otherwise gigi will complain that it's in the wrong scope, because
14473 -- it's actually inside the init procedure for the record type that
14474 -- corresponds to the task type.
14476 Set_Itype
(Ref
, Subp_Ptr_Typ
);
14477 Append_Freeze_Action
(Task_Rec
, Ref
);
14480 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
14481 Make_Qualified_Expression
(Loc
,
14482 Subtype_Mark
=> New_Occurrence_Of
(Subp_Ptr_Typ
, Loc
),
14484 Make_Attribute_Reference
(Loc
,
14485 Prefix
=> New_Occurrence_Of
(Body_Proc
, Loc
),
14486 Attribute_Name
=> Name_Unrestricted_Access
))));
14489 -- Discriminants parameter. This is just the address of the task
14490 -- value record itself (which contains the discriminant values
14493 Make_Attribute_Reference
(Loc
,
14494 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14495 Attribute_Name
=> Name_Address
));
14497 -- Elaborated parameter. This is an access to the elaboration Boolean
14500 Make_Attribute_Reference
(Loc
,
14501 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
14502 Attribute_Name
=> Name_Unchecked_Access
));
14504 -- Add Chain parameter (not done for sequential elaboration policy, see
14505 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14507 if Partition_Elaboration_Policy
/= 'S' then
14508 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
14511 -- Task name parameter. Take this from the _Task_Id parameter to the
14512 -- init call unless there is a Task_Name pragma, in which case we take
14513 -- the value from the pragma.
14515 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
14516 -- Copy expression in full, because it may be dynamic and have
14523 (Pragma_Argument_Associations
14525 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
14528 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
14531 -- Created_Task parameter. This is the _Task_Id field of the task
14535 Make_Selected_Component
(Loc
,
14536 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14537 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
14543 if Restricted_Profile
then
14544 if Partition_Elaboration_Policy
= 'S' then
14545 Create_RE
:= RE_Create_Restricted_Task_Sequential
;
14547 Create_RE
:= RE_Create_Restricted_Task
;
14550 Create_RE
:= RE_Create_Task
;
14553 Name
:= New_Occurrence_Of
(RTE
(Create_RE
), Loc
);
14557 Make_Procedure_Call_Statement
(Loc
,
14559 Parameter_Associations
=> Args
);
14560 end Make_Task_Create_Call
;
14562 ------------------------------
14563 -- Next_Protected_Operation --
14564 ------------------------------
14566 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
14570 -- Check whether there is a subsequent body for a protected operation
14571 -- in the current protected body. In Ada2012 that includes expression
14572 -- functions that are completions.
14574 Next_Op
:= Next
(N
);
14575 while Present
(Next_Op
)
14576 and then not Nkind_In
(Next_Op
,
14577 N_Subprogram_Body
, N_Entry_Body
, N_Expression_Function
)
14583 end Next_Protected_Operation
;
14585 ---------------------
14586 -- Null_Statements --
14587 ---------------------
14589 function Null_Statements
(Stats
: List_Id
) return Boolean is
14593 Stmt
:= First
(Stats
);
14594 while Nkind
(Stmt
) /= N_Empty
14595 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
14597 (Nkind
(Stmt
) = N_Pragma
14599 Nam_In
(Pragma_Name
(Stmt
), Name_Unreferenced
,
14606 return Nkind
(Stmt
) = N_Empty
;
14607 end Null_Statements
;
14609 --------------------------
14610 -- Parameter_Block_Pack --
14611 --------------------------
14613 function Parameter_Block_Pack
14615 Blk_Typ
: Entity_Id
;
14619 Stmts
: List_Id
) return Node_Id
14621 Actual
: Entity_Id
;
14622 Expr
: Node_Id
:= Empty
;
14623 Formal
: Entity_Id
;
14624 Has_Param
: Boolean := False;
14627 Temp_Asn
: Node_Id
;
14628 Temp_Nam
: Node_Id
;
14631 Actual
:= First
(Actuals
);
14632 Formal
:= Defining_Identifier
(First
(Formals
));
14633 Params
:= New_List
;
14634 while Present
(Actual
) loop
14635 if Is_By_Copy_Type
(Etype
(Actual
)) then
14637 -- Jnn : aliased <formal-type>
14639 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14642 Make_Object_Declaration
(Loc
,
14643 Aliased_Present
=> True,
14644 Defining_Identifier
=> Temp_Nam
,
14645 Object_Definition
=>
14646 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
14648 if Ekind
(Formal
) /= E_Out_Parameter
then
14654 New_Occurrence_Of
(Temp_Nam
, Loc
);
14656 Set_Assignment_OK
(Temp_Asn
);
14659 Make_Assignment_Statement
(Loc
,
14661 Expression
=> New_Copy_Tree
(Actual
)));
14665 -- Jnn'unchecked_access
14668 Make_Attribute_Reference
(Loc
,
14669 Attribute_Name
=> Name_Unchecked_Access
,
14670 Prefix
=> New_Occurrence_Of
(Temp_Nam
, Loc
)));
14674 -- The controlling parameter is omitted
14677 if not Is_Controlling_Actual
(Actual
) then
14679 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14685 Next_Actual
(Actual
);
14686 Next_Formal_With_Extras
(Formal
);
14690 Expr
:= Make_Aggregate
(Loc
, Params
);
14695 -- J1'unchecked_access;
14696 -- <actual2>'reference;
14699 P
:= Make_Temporary
(Loc
, 'P');
14702 Make_Object_Declaration
(Loc
,
14703 Defining_Identifier
=> P
,
14704 Object_Definition
=> New_Occurrence_Of
(Blk_Typ
, Loc
),
14705 Expression
=> Expr
));
14708 end Parameter_Block_Pack
;
14710 ----------------------------
14711 -- Parameter_Block_Unpack --
14712 ----------------------------
14714 function Parameter_Block_Unpack
14718 Formals
: List_Id
) return List_Id
14720 Actual
: Entity_Id
;
14722 Formal
: Entity_Id
;
14723 Has_Asnmt
: Boolean := False;
14724 Result
: constant List_Id
:= New_List
;
14727 Actual
:= First
(Actuals
);
14728 Formal
:= Defining_Identifier
(First
(Formals
));
14729 while Present
(Actual
) loop
14730 if Is_By_Copy_Type
(Etype
(Actual
))
14731 and then Ekind
(Formal
) /= E_In_Parameter
14734 -- <actual> := P.<formal>;
14737 Make_Assignment_Statement
(Loc
,
14741 Make_Explicit_Dereference
(Loc
,
14742 Make_Selected_Component
(Loc
,
14744 New_Occurrence_Of
(P
, Loc
),
14746 Make_Identifier
(Loc
, Chars
(Formal
)))));
14748 Set_Assignment_OK
(Name
(Asnmt
));
14749 Append_To
(Result
, Asnmt
);
14754 Next_Actual
(Actual
);
14755 Next_Formal_With_Extras
(Formal
);
14761 return New_List
(Make_Null_Statement
(Loc
));
14763 end Parameter_Block_Unpack
;
14765 ----------------------
14766 -- Set_Discriminals --
14767 ----------------------
14769 procedure Set_Discriminals
(Dec
: Node_Id
) is
14772 D_Minal
: Entity_Id
;
14775 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
14776 Pdef
:= Defining_Identifier
(Dec
);
14778 if Has_Discriminants
(Pdef
) then
14779 D
:= First_Discriminant
(Pdef
);
14780 while Present
(D
) loop
14782 Make_Defining_Identifier
(Sloc
(D
),
14783 Chars
=> New_External_Name
(Chars
(D
), 'D'));
14785 Set_Ekind
(D_Minal
, E_Constant
);
14786 Set_Etype
(D_Minal
, Etype
(D
));
14787 Set_Scope
(D_Minal
, Pdef
);
14788 Set_Discriminal
(D
, D_Minal
);
14789 Set_Discriminal_Link
(D_Minal
, D
);
14791 Next_Discriminant
(D
);
14794 end Set_Discriminals
;
14796 -----------------------
14797 -- Trivial_Accept_OK --
14798 -----------------------
14800 function Trivial_Accept_OK
return Boolean is
14802 case Opt
.Task_Dispatching_Policy
is
14804 -- If we have the default task dispatching policy in effect, we can
14805 -- definitely do the optimization (one way of looking at this is to
14806 -- think of the formal definition of the default policy being allowed
14807 -- to run any task it likes after a rendezvous, so even if notionally
14808 -- a full rescheduling occurs, we can say that our dispatching policy
14809 -- (i.e. the default dispatching policy) reorders the queue to be the
14810 -- same as just before the call.
14815 -- FIFO_Within_Priorities certainly does not permit this
14816 -- optimization since the Rendezvous is a scheduling action that may
14817 -- require some other task to be run.
14822 -- For now, disallow the optimization for all other policies. This
14823 -- may be over-conservative, but it is certainly not incorrect.
14829 end Trivial_Accept_OK
;