1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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
74 -- entry families of 128K should be reasonable in all cases, and is a
75 -- documented implementation restriction.
77 Entry_Family_Bound
: constant Int
:= 2**16;
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Actual_Index_Expression
87 Tsk
: Entity_Id
) return Node_Id
;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
92 procedure Add_Object_Pointer
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
101 procedure Add_Formal_Renamings
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
113 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
118 function Build_Barrier_Function
121 Pid
: Node_Id
) return Node_Id
;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
125 function Build_Barrier_Function_Specification
127 Def_Id
: Entity_Id
) return Node_Id
;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
131 function Build_Corresponding_Record
134 Loc
: Source_Ptr
) return Node_Id
;
135 -- Common to tasks and protected types. Copy discriminant specifications,
136 -- build record declaration. N is the type declaration, Ctyp is the
137 -- concurrent entity (task type or protected type).
139 function Build_Entry_Count_Expression
140 (Concurrent_Type
: Node_Id
;
141 Component_List
: List_Id
;
142 Loc
: Source_Ptr
) return Node_Id
;
143 -- Compute number of entries for concurrent object. This is a count of
144 -- simple entries, followed by an expression that computes the length
145 -- of the range of each entry family. A single array with that size is
146 -- allocated for each concurrent object of the type.
148 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
;
149 -- Build the function that translates the entry index in the call
150 -- (which depends on the size of entry families) into an index into the
151 -- Entry_Bodies_Array, to determine the body and barrier function used
152 -- in a protected entry call. A pointer to this function appears in every
155 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
;
156 -- Build subprogram declaration for previous one
158 function Build_Lock_Free_Protected_Subprogram_Body
161 Unprot_Spec
: Node_Id
) return Node_Id
;
162 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
163 -- the subprogram specification of the unprotected version of N. Transform
164 -- N such that it invokes the unprotected version of the body.
166 function Build_Lock_Free_Unprotected_Subprogram_Body
168 Prot_Typ
: Node_Id
) return Node_Id
;
169 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
170 -- of N where the original statements of N are synchronized through atomic
171 -- actions such as compare and exchange. Prior to invoking this routine, it
172 -- has been established that N can be implemented in a lock-free fashion.
174 function Build_Parameter_Block
178 Decls
: List_Id
) return Entity_Id
;
179 -- Generate an access type for each actual parameter in the list Actuals.
180 -- Create an encapsulating record that contains all the actuals and return
181 -- its type. Generate:
182 -- type Ann1 is access all <actual1-type>
184 -- type AnnN is access all <actualN-type>
185 -- type Pnn is record
191 procedure Build_PPC_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
);
192 -- Build body of wrapper procedure for an entry or entry family that has
193 -- pre/postconditions. The body gathers the PPC's and expands them in the
194 -- usual way, and performs the entry call itself. This way preconditions
195 -- are evaluated before the call is queued. E is the entry in question,
196 -- and Decl is the enclosing synchronized type declaration at whose
197 -- freeze point the generated body is analyzed.
199 function Build_Protected_Entry
202 Pid
: Node_Id
) return Node_Id
;
203 -- Build the procedure implementing the statement sequence of the specified
206 function Build_Protected_Entry_Specification
209 Ent_Id
: Entity_Id
) return Node_Id
;
210 -- Build a specification for the procedure implementing the statements of
211 -- the specified entry body. Add attributes associating it with the entry
212 -- defining identifier Ent_Id.
214 function Build_Protected_Spec
216 Obj_Type
: Entity_Id
;
218 Unprotected
: Boolean := False) return List_Id
;
219 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
220 -- Subprogram_Type. Builds signature of protected subprogram, adding the
221 -- formal that corresponds to the object itself. For an access to protected
222 -- subprogram, there is no object type to specify, so the parameter has
223 -- type Address and mode In. An indirect call through such a pointer will
224 -- convert the address to a reference to the actual object. The object is
225 -- a limited record and therefore a by_reference type.
227 function Build_Protected_Subprogram_Body
230 N_Op_Spec
: Node_Id
) return Node_Id
;
231 -- This function is used to construct the protected version of a protected
232 -- subprogram. Its statement sequence first defers abort, then locks
233 -- the associated protected object, and then enters a block that contains
234 -- a call to the unprotected version of the subprogram (for details, see
235 -- Build_Unprotected_Subprogram_Body). This block statement requires
236 -- a cleanup handler that unlocks the object in all cases.
237 -- (see Exp_Ch7.Expand_Cleanup_Actions).
239 function Build_Renamed_Formal_Declaration
243 Renamed_Formal
: Node_Id
) return Node_Id
;
244 -- Create a renaming declaration for a formal, within a protected entry
245 -- body or an accept body. The renamed object is a component of the
246 -- parameter block that is a parameter in the entry call.
248 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
249 -- does not dereference the corresponding component to prevent an illegal
250 -- use of the incomplete type (AI05-0151).
252 function Build_Selected_Name
254 Selector
: Entity_Id
;
255 Append_Char
: Character := ' ') return Name_Id
;
256 -- Build a name in the form of Prefix__Selector, with an optional
257 -- character appended. This is used for internal subprograms generated
258 -- for operations of protected types, including barrier functions.
259 -- For the subprograms generated for entry bodies and entry barriers,
260 -- the generated name includes a sequence number that makes names
261 -- unique in the presence of entry overloading. This is necessary
262 -- because entry body procedures and barrier functions all have the
265 procedure Build_Simple_Entry_Call
270 -- Some comments here would be useful ???
272 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
;
273 -- This routine constructs a specification for the procedure that we will
274 -- build for the task body for task type T. The spec has the form:
276 -- procedure tnameB (_Task : access tnameV);
278 -- where name is the character name taken from the task type entity that
279 -- is passed as the argument to the procedure, and tnameV is the task
280 -- value type that is associated with the task type.
282 function Build_Unprotected_Subprogram_Body
284 Pid
: Node_Id
) return Node_Id
;
285 -- This routine constructs the unprotected version of a protected
286 -- subprogram body, which is contains all of the code in the
287 -- original, unexpanded body. This is the version of the protected
288 -- subprogram that is called from all protected operations on the same
289 -- object, including the protected version of the same subprogram.
291 procedure Build_Wrapper_Bodies
295 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
296 -- record of a concurrent type. N is the insertion node where all bodies
297 -- will be placed. This routine builds the bodies of the subprograms which
298 -- serve as an indirection mechanism to overriding primitives of concurrent
299 -- types, entries and protected procedures. Any new body is analyzed.
301 procedure Build_Wrapper_Specs
305 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
306 -- record of a concurrent type. N is the insertion node where all specs
307 -- will be placed. This routine builds the specs of the subprograms which
308 -- serve as an indirection mechanism to overriding primitives of concurrent
309 -- types, entries and protected procedures. Any new spec is analyzed.
311 procedure Collect_Entry_Families
314 Current_Node
: in out Node_Id
;
315 Conctyp
: Entity_Id
);
316 -- For each entry family in a concurrent type, create an anonymous array
317 -- type of the right size, and add a component to the corresponding_record.
319 function Concurrent_Object
320 (Spec_Id
: Entity_Id
;
321 Conc_Typ
: Entity_Id
) return Entity_Id
;
322 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
323 -- the entity associated with the concurrent object in the Protected_Body_
324 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
325 -- denotes formal parameter _O, _object or _task.
327 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
;
328 -- Copy the result type of a function specification, when building the
329 -- internal operation corresponding to a protected function, or when
330 -- expanding an access to protected function. If the result is an anonymous
331 -- access to subprogram itself, we need to create a new signature with the
332 -- same parameter names and the same resolved types, but with new entities
335 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
336 -- Decls is a list which may contain the declarations created by Install_
337 -- Private_Data_Declarations. All generated entities are marked as needing
338 -- debug info and debug nodes are manually generation where necessary. This
339 -- step of the expansion must to be done after private data has been moved
340 -- to its final resting scope to ensure proper visibility of debug objects.
342 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
);
343 -- If control flow optimizations are suppressed, and Alt is an accept,
344 -- delay, or entry call alternative with no trailing statements, insert a
345 -- null trailing statement with the given Loc (which is the sloc of the
346 -- accept, delay, or entry call statement). There might not be any
347 -- generated code for the accept, delay, or entry call itself (the
348 -- effect of these statements is part of the general processsing done
349 -- for the enclosing selective accept, timed entry call, or asynchronous
350 -- select), and the null statement is there to carry the sloc of that
351 -- statement to the back-end for trace-based coverage analysis purposes.
353 procedure Extract_Dispatching_Call
355 Call_Ent
: out Entity_Id
;
356 Object
: out Entity_Id
;
357 Actuals
: out List_Id
;
358 Formals
: out List_Id
);
359 -- Given a dispatching call, extract the entity of the name of the call,
360 -- its actual dispatching object, its actual parameters and the formal
361 -- parameters of the overridden interface-level version. If the type of
362 -- the dispatching object is an access type then an explicit dereference
363 -- is returned in Object.
365 procedure Extract_Entry
367 Concval
: out Node_Id
;
369 Index
: out Node_Id
);
370 -- Given an entry call, returns the associated concurrent object,
371 -- the entry name, and the entry family index.
373 function Family_Offset
378 Cap
: Boolean) return Node_Id
;
379 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in
380 -- an accept statement, or the upper bound in the discrete subtype of
381 -- an entry declaration. Lo is the corresponding lower bound. Ttyp is
382 -- the concurrent type of the entry. If Cap is true, the result is
383 -- capped according to Entry_Family_Bound.
390 Cap
: Boolean) return Node_Id
;
391 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
392 -- a family, and handle properly the superflat case. This is equivalent
393 -- to the use of 'Length on the index type, but must use Family_Offset
394 -- to handle properly the case of bounds that depend on discriminants.
395 -- If Cap is true, the result is capped according to Entry_Family_Bound.
397 procedure Find_Enclosing_Context
399 Context
: out Node_Id
;
400 Context_Id
: out Entity_Id
;
401 Context_Decls
: out List_Id
);
402 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
403 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
404 -- nearest enclosing body, block, package or return statement and return
405 -- its constituents. Context is the enclosing construct, Context_Id is
406 -- the scope of Context_Id and Context_Decls is the declarative list of
409 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
410 -- Given a subprogram identifier, return the entity which is associated
411 -- with the protection entry index in the Protected_Body_Subprogram or the
412 -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal
415 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean;
416 -- Tell whether a given subprogram cannot raise an exception
418 function Is_Potentially_Large_Family
419 (Base_Index
: Entity_Id
;
422 Hi
: Node_Id
) return Boolean;
424 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
425 -- Determine whether Id is a function or a procedure and is marked as a
426 -- private primitive.
428 function Null_Statements
(Stats
: List_Id
) return Boolean;
429 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
430 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as
431 -- well to still count as null. Returns True for a null sequence. The
432 -- argument is the list of statements from the DO-END sequence.
434 function Parameter_Block_Pack
440 Stmts
: List_Id
) return Entity_Id
;
441 -- Set the components of the generated parameter block with the values of
442 -- the actual parameters. Generate aliased temporaries to capture the
443 -- values for types that are passed by copy. Otherwise generate a reference
444 -- to the actual's value. Return the address of the aggregate block.
446 -- Jnn1 : alias <formal-type1>;
447 -- Jnn1 := <actual1>;
450 -- Jnn1'unchecked_access;
451 -- <actual2>'reference;
454 function Parameter_Block_Unpack
458 Formals
: List_Id
) return List_Id
;
459 -- Retrieve the values of the components from the parameter block and
460 -- assign then to the original actual parameters. Generate:
461 -- <actual1> := P.<formal1>;
463 -- <actualN> := P.<formalN>;
465 function Trivial_Accept_OK
return Boolean;
466 -- If there is no DO-END block for an accept, or if the DO-END block has
467 -- only null statements, then it is possible to do the Rendezvous with much
468 -- less overhead using the Accept_Trivial routine in the run-time library.
469 -- However, this is not always a valid optimization. Whether it is valid or
470 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
471 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
472 -- a rescheduling is required, so this optimization is not allowed. This
473 -- function returns True if the optimization is permitted.
475 -----------------------------
476 -- Actual_Index_Expression --
477 -----------------------------
479 function Actual_Index_Expression
483 Tsk
: Entity_Id
) return Node_Id
485 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
493 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
494 -- Compute difference between bounds of entry family
496 --------------------------
497 -- Actual_Family_Offset --
498 --------------------------
500 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
502 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
503 -- Replace a reference to a discriminant with a selected component
504 -- denoting the discriminant of the target task.
506 -----------------------------
507 -- Actual_Discriminant_Ref --
508 -----------------------------
510 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
511 Typ
: constant Entity_Id
:= Etype
(Bound
);
515 if not Is_Entity_Name
(Bound
)
516 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
518 if Nkind
(Bound
) = N_Attribute_Reference
then
521 B
:= New_Copy_Tree
(Bound
);
526 Make_Selected_Component
(Sloc
,
527 Prefix
=> New_Copy_Tree
(Tsk
),
528 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
530 Analyze_And_Resolve
(B
, Typ
);
534 Make_Attribute_Reference
(Sloc
,
535 Attribute_Name
=> Name_Pos
,
536 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
537 Expressions
=> New_List
(B
));
538 end Actual_Discriminant_Ref
;
540 -- Start of processing for Actual_Family_Offset
544 Make_Op_Subtract
(Sloc
,
545 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
546 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
547 end Actual_Family_Offset
;
549 -- Start of processing for Actual_Index_Expression
552 -- The queues of entries and entry families appear in textual order in
553 -- the associated record. The entry index is computed as the sum of the
554 -- number of queues for all entries that precede the designated one, to
555 -- which is added the index expression, if this expression denotes a
556 -- member of a family.
558 -- The following is a place holder for the count of simple entries
560 Num
:= Make_Integer_Literal
(Sloc
, 1);
562 -- We construct an expression which is a series of addition operations.
563 -- See comments in Entry_Index_Expression, which is identical in
566 if Present
(Index
) then
567 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
574 Actual_Family_Offset
(
575 Make_Attribute_Reference
(Sloc
,
576 Attribute_Name
=> Name_Pos
,
577 Prefix
=> New_Reference_To
(Base_Type
(S
), Sloc
),
578 Expressions
=> New_List
(Relocate_Node
(Index
))),
579 Type_Low_Bound
(S
)));
584 -- Now add lengths of preceding entries and entry families
586 Prev
:= First_Entity
(Ttyp
);
588 while Chars
(Prev
) /= Chars
(Ent
)
589 or else (Ekind
(Prev
) /= Ekind
(Ent
))
590 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
592 if Ekind
(Prev
) = E_Entry
then
593 Set_Intval
(Num
, Intval
(Num
) + 1);
595 elsif Ekind
(Prev
) = E_Entry_Family
then
597 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
599 -- The need for the following full view retrieval stems from
600 -- this complex case of nested generics and tasking:
603 -- type Formal_Index is range <>;
606 -- type Index is private;
613 -- type Index is new Formal_Index range 1 .. 10;
616 -- package body Outer is
618 -- entry Fam (Index); -- (2)
621 -- package body Inner is -- (3)
629 -- We are currently building the index expression for the entry
630 -- call "T.E" (1). Part of the expansion must mention the range
631 -- of the discrete type "Index" (2) of entry family "Fam".
632 -- However only the private view of type "Index" is available to
633 -- the inner generic (3) because there was no prior mention of
634 -- the type inside "Inner". This visibility requirement is
635 -- implicit and cannot be detected during the construction of
636 -- the generic trees and needs special handling.
639 and then Is_Private_Type
(S
)
640 and then Present
(Full_View
(S
))
645 Lo
:= Type_Low_Bound
(S
);
646 Hi
:= Type_High_Bound
(S
);
654 Actual_Family_Offset
(Hi
, Lo
),
656 Make_Integer_Literal
(Sloc
, 1)));
658 -- Other components are anonymous types to be ignored
668 end Actual_Index_Expression
;
670 --------------------------
671 -- Add_Formal_Renamings --
672 --------------------------
674 procedure Add_Formal_Renamings
680 Ptr
: constant Entity_Id
:=
682 (Next
(First
(Parameter_Specifications
(Spec
))));
683 -- The name of the formal that holds the address of the parameter block
690 Renamed_Formal
: Node_Id
;
693 Formal
:= First_Formal
(Ent
);
694 while Present
(Formal
) loop
695 Comp
:= Entry_Component
(Formal
);
697 Make_Defining_Identifier
(Sloc
(Formal
),
698 Chars
=> Chars
(Formal
));
699 Set_Etype
(New_F
, Etype
(Formal
));
700 Set_Scope
(New_F
, Ent
);
702 -- Now we set debug info needed on New_F even though it does not
703 -- come from source, so that the debugger will get the right
704 -- information for these generated names.
706 Set_Debug_Info_Needed
(New_F
);
708 if Ekind
(Formal
) = E_In_Parameter
then
709 Set_Ekind
(New_F
, E_Constant
);
711 Set_Ekind
(New_F
, E_Variable
);
712 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
715 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
718 Make_Selected_Component
(Loc
,
720 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
721 Make_Identifier
(Loc
, Chars
(Ptr
))),
722 Selector_Name
=> New_Reference_To
(Comp
, Loc
));
725 Build_Renamed_Formal_Declaration
726 (New_F
, Formal
, Comp
, Renamed_Formal
);
728 Append
(Decl
, Decls
);
729 Set_Renamed_Object
(Formal
, New_F
);
730 Next_Formal
(Formal
);
732 end Add_Formal_Renamings
;
734 ------------------------
735 -- Add_Object_Pointer --
736 ------------------------
738 procedure Add_Object_Pointer
740 Conc_Typ
: Entity_Id
;
743 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
748 -- Create the renaming declaration for the Protection object of a
749 -- protected type. _Object is used by Complete_Entry_Body.
750 -- ??? An attempt to make this a renaming was unsuccessful.
752 -- Build the entity for the access type
755 Make_Defining_Identifier
(Loc
,
756 New_External_Name
(Chars
(Rec_Typ
), 'P'));
759 -- _object : poVP := poVP!O;
762 Make_Object_Declaration
(Loc
,
763 Defining_Identifier
=>
764 Make_Defining_Identifier
(Loc
, Name_uObject
),
766 New_Reference_To
(Obj_Ptr
, Loc
),
768 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
769 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
770 Prepend_To
(Decls
, Decl
);
773 -- type poVP is access poV;
776 Make_Full_Type_Declaration
(Loc
,
777 Defining_Identifier
=>
780 Make_Access_To_Object_Definition
(Loc
,
781 Subtype_Indication
=>
782 New_Reference_To
(Rec_Typ
, Loc
)));
783 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
784 Prepend_To
(Decls
, Decl
);
785 end Add_Object_Pointer
;
787 -----------------------
788 -- Build_Accept_Body --
789 -----------------------
791 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
792 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
793 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
800 -- At the end of the statement sequence, Complete_Rendezvous is called.
801 -- A label skipping the Complete_Rendezvous, and all other accept
802 -- processing, has already been added for the expansion of requeue
803 -- statements. The Sloc is copied from the last statement since it
804 -- is really part of this last statement.
808 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
809 Insert_Before
(Last
(Statements
(Stats
)), Call
);
812 -- If exception handlers are present, then append Complete_Rendezvous
813 -- calls to the handlers, and construct the required outer block. As
814 -- above, the Sloc is copied from the last statement in the sequence.
816 if Present
(Exception_Handlers
(Stats
)) then
817 Hand
:= First
(Exception_Handlers
(Stats
));
818 while Present
(Hand
) loop
821 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
822 Append
(Call
, Statements
(Hand
));
828 Make_Handled_Sequence_Of_Statements
(Loc
,
829 Statements
=> New_List
(
830 Make_Block_Statement
(Loc
,
831 Handled_Statement_Sequence
=> Stats
)));
837 -- At this stage we know that the new statement sequence does not
838 -- have an exception handler part, so we supply one to call
839 -- Exceptional_Complete_Rendezvous. This handler is
841 -- when all others =>
842 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
844 -- We handle Abort_Signal to make sure that we properly catch the abort
845 -- case and wake up the caller.
847 Ohandle
:= Make_Others_Choice
(Loc
);
848 Set_All_Others
(Ohandle
);
850 Set_Exception_Handlers
(New_S
,
852 Make_Implicit_Exception_Handler
(Loc
,
853 Exception_Choices
=> New_List
(Ohandle
),
855 Statements
=> New_List
(
856 Make_Procedure_Call_Statement
(Sloc
(Stats
),
857 Name
=> New_Reference_To
(
858 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
859 Parameter_Associations
=> New_List
(
860 Make_Function_Call
(Sloc
(Stats
),
861 Name
=> New_Reference_To
(
862 RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
864 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
865 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
866 Expand_Exception_Handlers
(New_S
);
868 -- Exceptional_Complete_Rendezvous must be called with abort
869 -- still deferred, which is the case for a "when all others" handler.
872 end Build_Accept_Body
;
874 -----------------------------------
875 -- Build_Activation_Chain_Entity --
876 -----------------------------------
878 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
879 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean;
880 -- Determine whether an extended return statement has an activation
883 --------------------------
884 -- Has_Activation_Chain --
885 --------------------------
887 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean is
891 Decl
:= First
(Return_Object_Declarations
(Stmt
));
892 while Present
(Decl
) loop
893 if Nkind
(Decl
) = N_Object_Declaration
894 and then Chars
(Defining_Identifier
(Decl
)) = Name_uChain
903 end Has_Activation_Chain
;
908 Context_Id
: Entity_Id
;
911 -- Start of processing for Build_Activation_Chain_Entity
914 Find_Enclosing_Context
(N
, Context
, Context_Id
, Decls
);
916 -- If an activation chain entity has not been declared already, create
919 if Nkind
(Context
) = N_Extended_Return_Statement
920 or else No
(Activation_Chain_Entity
(Context
))
922 -- Since extended return statements do not store the entity of the
923 -- chain, examine the return object declarations to avoid creating
926 if Nkind
(Context
) = N_Extended_Return_Statement
927 and then Has_Activation_Chain
(Context
)
933 Loc
: constant Source_Ptr
:= Sloc
(Context
);
938 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
940 -- Note: An extended return statement is not really a task
941 -- activator, but it does have an activation chain on which to
942 -- store the tasks temporarily. On successful return, the tasks
943 -- on this chain are moved to the chain passed in by the caller.
944 -- We do not build an Activation_Chain_Entity for an extended
945 -- return statement, because we do not want to build a call to
946 -- Activate_Tasks. Task activation is the responsibility of the
949 if Nkind
(Context
) /= N_Extended_Return_Statement
then
950 Set_Activation_Chain_Entity
(Context
, Chain
);
954 Make_Object_Declaration
(Loc
,
955 Defining_Identifier
=> Chain
,
956 Aliased_Present
=> True,
958 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
));
960 Prepend_To
(Decls
, Decl
);
962 -- Ensure that the _chain appears in the proper scope of the
965 if Context_Id
/= Current_Scope
then
966 Push_Scope
(Context_Id
);
974 end Build_Activation_Chain_Entity
;
976 ----------------------------
977 -- Build_Barrier_Function --
978 ----------------------------
980 function Build_Barrier_Function
983 Pid
: Node_Id
) return Node_Id
985 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
986 Cond
: constant Node_Id
:= Condition
(Ent_Formals
);
987 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
988 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
989 Op_Decls
: constant List_Id
:= New_List
;
994 -- Add a declaration for the Protection object, renaming declarations
995 -- for the discriminals and privals and finally a declaration for the
996 -- entry family index (if applicable).
998 Install_Private_Data_Declarations
(Sloc
(N
),
1004 Family
=> Ekind
(Ent
) = E_Entry_Family
);
1006 -- If compiling with -fpreserve-control-flow, make sure we insert an
1007 -- IF statement so that the back-end knows to generate a conditional
1008 -- branch instruction, even if the condition is just the name of a
1011 if Opt
.Suppress_Control_Flow_Optimizations
then
1012 Stmt
:= Make_Implicit_If_Statement
(Cond
,
1014 Then_Statements
=> New_List
(
1015 Make_Simple_Return_Statement
(Loc
,
1016 New_Occurrence_Of
(Standard_True
, Loc
))),
1017 Else_Statements
=> New_List
(
1018 Make_Simple_Return_Statement
(Loc
,
1019 New_Occurrence_Of
(Standard_False
, Loc
))));
1022 Stmt
:= Make_Simple_Return_Statement
(Loc
, Cond
);
1025 -- Note: the condition in the barrier function needs to be properly
1026 -- processed for the C/Fortran boolean possibility, but this happens
1027 -- automatically since the return statement does this normalization.
1030 Make_Subprogram_Body
(Loc
,
1032 Build_Barrier_Function_Specification
(Loc
,
1033 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
1034 Declarations
=> Op_Decls
,
1035 Handled_Statement_Sequence
=>
1036 Make_Handled_Sequence_Of_Statements
(Loc
,
1037 Statements
=> New_List
(Stmt
)));
1038 Set_Is_Entry_Barrier_Function
(Func_Body
);
1041 end Build_Barrier_Function
;
1043 ------------------------------------------
1044 -- Build_Barrier_Function_Specification --
1045 ------------------------------------------
1047 function Build_Barrier_Function_Specification
1049 Def_Id
: Entity_Id
) return Node_Id
1052 Set_Debug_Info_Needed
(Def_Id
);
1054 return Make_Function_Specification
(Loc
,
1055 Defining_Unit_Name
=> Def_Id
,
1056 Parameter_Specifications
=> New_List
(
1057 Make_Parameter_Specification
(Loc
,
1058 Defining_Identifier
=>
1059 Make_Defining_Identifier
(Loc
, Name_uO
),
1061 New_Reference_To
(RTE
(RE_Address
), Loc
)),
1063 Make_Parameter_Specification
(Loc
,
1064 Defining_Identifier
=>
1065 Make_Defining_Identifier
(Loc
, Name_uE
),
1067 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))),
1069 Result_Definition
=>
1070 New_Reference_To
(Standard_Boolean
, Loc
));
1071 end Build_Barrier_Function_Specification
;
1073 --------------------------
1074 -- Build_Call_With_Task --
1075 --------------------------
1077 function Build_Call_With_Task
1079 E
: Entity_Id
) return Node_Id
1081 Loc
: constant Source_Ptr
:= Sloc
(N
);
1084 Make_Function_Call
(Loc
,
1085 Name
=> New_Reference_To
(E
, Loc
),
1086 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
1087 end Build_Call_With_Task
;
1089 -----------------------------
1090 -- Build_Class_Wide_Master --
1091 -----------------------------
1093 procedure Build_Class_Wide_Master
(Typ
: Entity_Id
) is
1094 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1095 Master_Id
: Entity_Id
;
1096 Master_Scope
: Entity_Id
;
1098 Related_Node
: Node_Id
;
1102 -- Nothing to do if there is no task hierarchy
1104 if Restriction_Active
(No_Task_Hierarchy
) then
1108 -- Find the declaration that created the access type. It is either a
1109 -- type declaration, or an object declaration with an access definition,
1110 -- in which case the type is anonymous.
1112 if Is_Itype
(Typ
) then
1113 Related_Node
:= Associated_Node_For_Itype
(Typ
);
1115 Related_Node
:= Parent
(Typ
);
1118 Master_Scope
:= Find_Master_Scope
(Typ
);
1120 -- Nothing to do if the master scope already contains a _master entity.
1121 -- The only exception to this is the following scenario:
1124 -- Transient_Scope_1
1127 -- Transient_Scope_2
1130 -- In this case the source scope is marked as having the master entity
1131 -- even though the actual declaration appears inside an inner scope. If
1132 -- the second transient scope requires a _master, it cannot use the one
1133 -- already declared because the entity is not visible.
1135 Name_Id
:= Make_Identifier
(Loc
, Name_uMaster
);
1137 if not Has_Master_Entity
(Master_Scope
)
1138 or else No
(Current_Entity_In_Scope
(Name_Id
))
1141 Master_Decl
: Node_Id
;
1144 Set_Has_Master_Entity
(Master_Scope
);
1147 -- _master : constant Integer := Current_Master.all;
1150 Make_Object_Declaration
(Loc
,
1151 Defining_Identifier
=>
1152 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1153 Constant_Present
=> True,
1154 Object_Definition
=>
1155 New_Reference_To
(Standard_Integer
, Loc
),
1157 Make_Explicit_Dereference
(Loc
,
1158 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
1160 Insert_Action
(Related_Node
, Master_Decl
);
1161 Analyze
(Master_Decl
);
1163 -- Mark the containing scope as a task master. Masters associated
1164 -- with return statements are already marked at this stage (see
1165 -- Analyze_Subprogram_Body).
1167 if Ekind
(Current_Scope
) /= E_Return_Statement
then
1169 Par
: Node_Id
:= Related_Node
;
1172 while Nkind
(Par
) /= N_Compilation_Unit
loop
1173 Par
:= Parent
(Par
);
1175 -- If we fall off the top, we are at the outer level, and
1176 -- the environment task is our effective master, so
1179 if Nkind_In
(Par
, N_Block_Statement
,
1183 Set_Is_Task_Master
(Par
);
1193 Make_Defining_Identifier
(Loc
,
1194 New_External_Name
(Chars
(Typ
), 'M'));
1197 -- Mnn renames _master;
1200 Make_Object_Renaming_Declaration
(Loc
,
1201 Defining_Identifier
=> Master_Id
,
1202 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
1205 Insert_Action
(Related_Node
, Ren_Decl
);
1207 Set_Master_Id
(Typ
, Master_Id
);
1208 end Build_Class_Wide_Master
;
1210 --------------------------------
1211 -- Build_Corresponding_Record --
1212 --------------------------------
1214 function Build_Corresponding_Record
1217 Loc
: Source_Ptr
) return Node_Id
1219 Rec_Ent
: constant Entity_Id
:=
1220 Make_Defining_Identifier
1221 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1224 New_Disc
: Entity_Id
;
1228 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1229 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1230 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1231 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1232 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1233 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1236 -- Use discriminals to create list of discriminants for record, and
1237 -- create new discriminals for use in default expressions, etc. It is
1238 -- worth noting that a task discriminant gives rise to 5 entities;
1240 -- a) The original discriminant.
1241 -- b) The discriminal for use in the task.
1242 -- c) The discriminant of the corresponding record.
1243 -- d) The discriminal for the init proc of the corresponding record.
1244 -- e) The local variable that renames the discriminant in the procedure
1245 -- for the task body.
1247 -- In fact the discriminals b) are used in the renaming declarations
1248 -- for e). See details in einfo (Handling of Discriminants).
1250 if Present
(Discriminant_Specifications
(N
)) then
1252 Disc
:= First_Discriminant
(Ctyp
);
1254 while Present
(Disc
) loop
1255 New_Disc
:= CR_Discriminant
(Disc
);
1258 Make_Discriminant_Specification
(Loc
,
1259 Defining_Identifier
=> New_Disc
,
1260 Discriminant_Type
=>
1261 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1263 New_Copy
(Discriminant_Default_Value
(Disc
))));
1265 Next_Discriminant
(Disc
);
1272 -- Now we can construct the record type declaration. Note that this
1273 -- record is "limited tagged". It is "limited" to reflect the underlying
1274 -- limitedness of the task or protected object that it represents, and
1275 -- ensuring for example that it is properly passed by reference. It is
1276 -- "tagged" to give support to dispatching calls through interfaces. We
1277 -- propagate here the list of interfaces covered by the concurrent type
1278 -- (Ada 2005: AI-345).
1281 Make_Full_Type_Declaration
(Loc
,
1282 Defining_Identifier
=> Rec_Ent
,
1283 Discriminant_Specifications
=> Dlist
,
1285 Make_Record_Definition
(Loc
,
1287 Make_Component_List
(Loc
,
1288 Component_Items
=> Cdecls
),
1290 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1291 Interface_List
=> Interface_List
(N
),
1292 Limited_Present
=> True));
1293 end Build_Corresponding_Record
;
1295 ----------------------------------
1296 -- Build_Entry_Count_Expression --
1297 ----------------------------------
1299 function Build_Entry_Count_Expression
1300 (Concurrent_Type
: Node_Id
;
1301 Component_List
: List_Id
;
1302 Loc
: Source_Ptr
) return Node_Id
1314 -- Count number of non-family entries
1317 Ent
:= First_Entity
(Concurrent_Type
);
1318 while Present
(Ent
) loop
1319 if Ekind
(Ent
) = E_Entry
then
1326 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1328 -- Loop through entry families building the addition nodes
1330 Ent
:= First_Entity
(Concurrent_Type
);
1331 Comp
:= First
(Component_List
);
1332 while Present
(Ent
) loop
1333 if Ekind
(Ent
) = E_Entry_Family
then
1334 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1338 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1339 Hi
:= Type_High_Bound
(Typ
);
1340 Lo
:= Type_Low_Bound
(Typ
);
1341 Large
:= Is_Potentially_Large_Family
1342 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1345 Left_Opnd
=> Ecount
,
1346 Right_Opnd
=> Family_Size
1347 (Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1354 end Build_Entry_Count_Expression
;
1356 -----------------------
1357 -- Build_Entry_Names --
1358 -----------------------
1360 function Build_Entry_Names
(Conc_Typ
: Entity_Id
) return Node_Id
is
1361 Loc
: constant Source_Ptr
:= Sloc
(Conc_Typ
);
1367 Typ
: Entity_Id
:= Conc_Typ
;
1369 procedure Build_Entry_Family_Name
(Id
: Entity_Id
);
1371 -- for Lnn in Family_Low .. Family_High loop
1374 -- (_init._object <or> _init._task_id,
1376 -- new String ("<Entry name>(" & Lnn'Img & ")"));
1378 -- Note that the bounds of the range may reference discriminants. The
1379 -- above construct is added directly to the statements of the block.
1381 procedure Build_Entry_Name
(Id
: Entity_Id
);
1385 -- (_init._object <or>_init._task_id,
1387 -- new String ("<Entry name>");
1388 -- The above construct is added directly to the statements of the block.
1390 function Build_Set_Entry_Name_Call
(Arg3
: Node_Id
) return Node_Id
;
1391 -- Generate the call to the runtime routine Set_Entry_Name with actuals
1392 -- _init._task_id or _init._object, Inn and Arg3.
1394 procedure Increment_Index
(Stmts
: List_Id
);
1395 -- Generate the following and add it to Stmts
1398 -----------------------------
1399 -- Build_Entry_Family_Name --
1400 -----------------------------
1402 procedure Build_Entry_Family_Name
(Id
: Entity_Id
) is
1403 Def
: constant Node_Id
:=
1404 Discrete_Subtype_Definition
(Parent
(Id
));
1405 L_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
1406 L_Stmts
: constant List_Id
:= New_List
;
1409 function Build_Range
(Def
: Node_Id
) return Node_Id
;
1410 -- Given a discrete subtype definition of an entry family, generate a
1411 -- range node which covers the range of Def's type.
1417 function Build_Range
(Def
: Node_Id
) return Node_Id
is
1418 High
: Node_Id
:= Type_High_Bound
(Etype
(Def
));
1419 Low
: Node_Id
:= Type_Low_Bound
(Etype
(Def
));
1422 -- If a bound references a discriminant, generate an identifier
1423 -- with the same name. Resolution will map it to the formals of
1426 if Is_Entity_Name
(Low
)
1427 and then Ekind
(Entity
(Low
)) = E_Discriminant
1429 Low
:= Make_Identifier
(Loc
, Chars
(Low
));
1431 Low
:= New_Copy_Tree
(Low
);
1434 if Is_Entity_Name
(High
)
1435 and then Ekind
(Entity
(High
)) = E_Discriminant
1437 High
:= Make_Identifier
(Loc
, Chars
(High
));
1439 High
:= New_Copy_Tree
(High
);
1445 High_Bound
=> High
);
1448 -- Start of processing for Build_Entry_Family_Name
1451 Get_Name_String
(Chars
(Id
));
1453 -- Add a leading '('
1455 Add_Char_To_Name_Buffer
('(');
1458 -- new String'("<Entry name>(" & Lnn'Img & ")");
1460 -- This is an implicit heap allocation, and Comes_From_Source is
1461 -- False, which ensures that it will get flagged as a violation of
1462 -- No_Implicit_Heap_Allocations when that restriction applies.
1465 Make_Allocator
(Loc
,
1466 Make_Qualified_Expression
(Loc
,
1468 New_Reference_To
(Standard_String
, Loc
),
1470 Make_Op_Concat
(Loc
,
1472 Make_Op_Concat
(Loc
,
1474 Make_String_Literal
(Loc
,
1475 Strval
=> String_From_Name_Buffer
),
1477 Make_Attribute_Reference
(Loc
,
1479 New_Reference_To
(L_Id
, Loc
),
1480 Attribute_Name
=> Name_Img
)),
1482 Make_String_Literal
(Loc
,
1485 Increment_Index
(L_Stmts
);
1486 Append_To
(L_Stmts
, Build_Set_Entry_Name_Call
(Val
));
1489 -- for Lnn in Family_Low .. Family_High loop
1492 -- (_init._object <or> _init._task_id, Inn, <Val>);
1496 Make_Loop_Statement
(Loc
,
1498 Make_Iteration_Scheme
(Loc
,
1499 Loop_Parameter_Specification
=>
1500 Make_Loop_Parameter_Specification
(Loc
,
1501 Defining_Identifier
=> L_Id
,
1502 Discrete_Subtype_Definition
=> Build_Range
(Def
))),
1503 Statements
=> L_Stmts
,
1504 End_Label
=> Empty
));
1505 end Build_Entry_Family_Name
;
1507 ----------------------
1508 -- Build_Entry_Name --
1509 ----------------------
1511 procedure Build_Entry_Name
(Id
: Entity_Id
) is
1515 Get_Name_String
(Chars
(Id
));
1517 -- This is an implicit heap allocation, and Comes_From_Source is
1518 -- False, which ensures that it will get flagged as a violation of
1519 -- No_Implicit_Heap_Allocations when that restriction applies.
1522 Make_Allocator
(Loc
,
1523 Make_Qualified_Expression
(Loc
,
1525 New_Reference_To
(Standard_String
, Loc
),
1527 Make_String_Literal
(Loc
,
1528 String_From_Name_Buffer
)));
1530 Increment_Index
(B_Stmts
);
1531 Append_To
(B_Stmts
, Build_Set_Entry_Name_Call
(Val
));
1532 end Build_Entry_Name
;
1534 -------------------------------
1535 -- Build_Set_Entry_Name_Call --
1536 -------------------------------
1538 function Build_Set_Entry_Name_Call
(Arg3
: Node_Id
) return Node_Id
is
1543 -- Determine the proper name for the first argument and the RTS
1546 if Is_Protected_Type
(Typ
) then
1547 Arg1
:= Name_uObject
;
1548 Proc
:= RO_PE_Set_Entry_Name
;
1550 else pragma Assert
(Is_Task_Type
(Typ
));
1551 Arg1
:= Name_uTask_Id
;
1552 Proc
:= RO_TS_Set_Entry_Name
;
1556 -- Set_Entry_Name (_init.Arg1, Inn, Arg3);
1559 Make_Procedure_Call_Statement
(Loc
,
1561 New_Reference_To
(RTE
(Proc
), Loc
),
1562 Parameter_Associations
=> New_List
(
1563 Make_Selected_Component
(Loc
, -- _init._object
1564 Prefix
=> -- _init._task_id
1565 Make_Identifier
(Loc
, Name_uInit
),
1567 Make_Identifier
(Loc
, Arg1
)),
1568 New_Reference_To
(Index
, Loc
), -- Inn
1570 end Build_Set_Entry_Name_Call
;
1572 ---------------------
1573 -- Increment_Index --
1574 ---------------------
1576 procedure Increment_Index
(Stmts
: List_Id
) is
1582 Make_Assignment_Statement
(Loc
,
1584 New_Reference_To
(Index
, Loc
),
1588 New_Reference_To
(Index
, Loc
),
1590 Make_Integer_Literal
(Loc
, 1))));
1591 end Increment_Index
;
1593 -- Start of processing for Build_Entry_Names
1596 -- Retrieve the original concurrent type
1598 if Is_Concurrent_Record_Type
(Typ
) then
1599 Typ
:= Corresponding_Concurrent_Type
(Typ
);
1602 pragma Assert
(Is_Protected_Type
(Typ
) or else Is_Task_Type
(Typ
));
1604 -- Nothing to do if the type has no entries
1606 if not Has_Entries
(Typ
) then
1610 -- Avoid generating entry names for a protected type with only one entry
1612 if Is_Protected_Type
(Typ
)
1613 and then Find_Protection_Type
(Typ
) /= RTE
(RE_Protection_Entries
)
1618 Index
:= Make_Temporary
(Loc
, 'I');
1620 -- Step 1: Generate the declaration of the index variable:
1621 -- Inn : Protected_Entry_Index := 0;
1623 -- Inn : Task_Entry_Index := 0;
1625 if Is_Protected_Type
(Typ
) then
1626 Index_Typ
:= RE_Protected_Entry_Index
;
1628 Index_Typ
:= RE_Task_Entry_Index
;
1631 B_Decls
:= New_List
;
1633 Make_Object_Declaration
(Loc
,
1634 Defining_Identifier
=> Index
,
1635 Object_Definition
=> New_Reference_To
(RTE
(Index_Typ
), Loc
),
1636 Expression
=> Make_Integer_Literal
(Loc
, 0)));
1638 B_Stmts
:= New_List
;
1640 -- Step 2: Generate a call to Set_Entry_Name for each entry and entry
1643 Comp
:= First_Entity
(Typ
);
1644 while Present
(Comp
) loop
1645 if Ekind
(Comp
) = E_Entry
then
1646 Build_Entry_Name
(Comp
);
1648 elsif Ekind
(Comp
) = E_Entry_Family
then
1649 Build_Entry_Family_Name
(Comp
);
1655 -- Step 3: Wrap the statements in a block
1658 Make_Block_Statement
(Loc
,
1659 Declarations
=> B_Decls
,
1660 Handled_Statement_Sequence
=>
1661 Make_Handled_Sequence_Of_Statements
(Loc
,
1662 Statements
=> B_Stmts
));
1663 end Build_Entry_Names
;
1665 ---------------------------
1666 -- Build_Parameter_Block --
1667 ---------------------------
1669 function Build_Parameter_Block
1673 Decls
: List_Id
) return Entity_Id
1679 Has_Comp
: Boolean := False;
1683 Actual
:= First
(Actuals
);
1685 Formal
:= Defining_Identifier
(First
(Formals
));
1687 while Present
(Actual
) loop
1688 if not Is_Controlling_Actual
(Actual
) then
1691 -- type Ann is access all <actual-type>
1693 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
1696 Make_Full_Type_Declaration
(Loc
,
1697 Defining_Identifier
=> Comp_Nam
,
1699 Make_Access_To_Object_Definition
(Loc
,
1700 All_Present
=> True,
1701 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
1702 Subtype_Indication
=>
1703 New_Reference_To
(Etype
(Actual
), Loc
))));
1709 Make_Component_Declaration
(Loc
,
1710 Defining_Identifier
=>
1711 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
1712 Component_Definition
=>
1713 Make_Component_Definition
(Loc
,
1716 Subtype_Indication
=>
1717 New_Reference_To
(Comp_Nam
, Loc
))));
1722 Next_Actual
(Actual
);
1723 Next_Formal_With_Extras
(Formal
);
1726 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
1731 -- type Pnn is record
1736 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1737 -- the original parameter names and Ann1 .. AnnN are the access to
1741 Make_Full_Type_Declaration
(Loc
,
1742 Defining_Identifier
=>
1745 Make_Record_Definition
(Loc
,
1747 Make_Component_List
(Loc
, Comps
))));
1750 -- type Pnn is null record;
1753 Make_Full_Type_Declaration
(Loc
,
1754 Defining_Identifier
=>
1757 Make_Record_Definition
(Loc
,
1758 Null_Present
=> True,
1759 Component_List
=> Empty
)));
1763 end Build_Parameter_Block
;
1765 --------------------------------------
1766 -- Build_Renamed_Formal_Declaration --
1767 --------------------------------------
1769 function Build_Renamed_Formal_Declaration
1773 Renamed_Formal
: Node_Id
) return Node_Id
1775 Loc
: constant Source_Ptr
:= Sloc
(New_F
);
1779 -- If the formal is a tagged incomplete type, it is already passed
1780 -- by reference, so it is sufficient to rename the pointer component
1781 -- that corresponds to the actual. Otherwise we need to dereference
1782 -- the pointer component to obtain the actual.
1784 if Is_Incomplete_Type
(Etype
(Formal
))
1785 and then Is_Tagged_Type
(Etype
(Formal
))
1788 Make_Object_Renaming_Declaration
(Loc
,
1789 Defining_Identifier
=> New_F
,
1790 Subtype_Mark
=> New_Reference_To
(Etype
(Comp
), Loc
),
1791 Name
=> Renamed_Formal
);
1795 Make_Object_Renaming_Declaration
(Loc
,
1796 Defining_Identifier
=> New_F
,
1797 Subtype_Mark
=> New_Reference_To
(Etype
(Formal
), Loc
),
1799 Make_Explicit_Dereference
(Loc
, Renamed_Formal
));
1803 end Build_Renamed_Formal_Declaration
;
1805 -----------------------
1806 -- Build_PPC_Wrapper --
1807 -----------------------
1809 procedure Build_PPC_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1810 Loc
: constant Source_Ptr
:= Sloc
(E
);
1811 Synch_Type
: constant Entity_Id
:= Scope
(E
);
1813 Wrapper_Id
: constant Entity_Id
:=
1814 Make_Defining_Identifier
(Loc
,
1815 Chars
=> New_External_Name
(Chars
(E
), 'E'));
1816 -- the wrapper procedure name
1818 Wrapper_Body
: Node_Id
;
1820 Synch_Id
: constant Entity_Id
:=
1821 Make_Defining_Identifier
(Loc
,
1822 Chars
=> New_External_Name
(Chars
(Scope
(E
)), 'A'));
1823 -- The parameter that designates the synchronized object in the call
1825 Actuals
: constant List_Id
:= New_List
;
1826 -- The actuals in the entry call
1828 Decls
: constant List_Id
:= New_List
;
1830 Entry_Call
: Node_Id
;
1831 Entry_Name
: Node_Id
;
1834 -- The specification of the wrapper procedure
1838 -- Only build the wrapper if entry has pre/postconditions.
1839 -- Should this be done unconditionally instead ???
1845 P
:= Spec_PPC_List
(Contract
(E
));
1850 -- Transfer ppc pragmas to the declarations of the wrapper
1852 while Present
(P
) loop
1853 if Pragma_Name
(P
) = Name_Precondition
1854 or else Pragma_Name
(P
) = Name_Postcondition
1856 Append
(Relocate_Node
(P
), Decls
);
1857 Set_Analyzed
(Last
(Decls
), False);
1860 P
:= Next_Pragma
(P
);
1864 -- First formal is synchronized object
1867 Make_Parameter_Specification
(Loc
,
1868 Defining_Identifier
=> Synch_Id
,
1869 Out_Present
=> True,
1871 Parameter_Type
=> New_Occurrence_Of
(Scope
(E
), Loc
)));
1874 Make_Selected_Component
(Loc
,
1875 Prefix
=> New_Occurrence_Of
(Synch_Id
, Loc
),
1876 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1878 -- If entity is entry family, second formal is the corresponding index,
1879 -- and entry name is an indexed component.
1881 if Ekind
(E
) = E_Entry_Family
then
1883 Index
: constant Entity_Id
:=
1884 Make_Defining_Identifier
(Loc
, Name_I
);
1887 Make_Parameter_Specification
(Loc
,
1888 Defining_Identifier
=> Index
,
1890 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1893 Make_Indexed_Component
(Loc
,
1894 Prefix
=> Entry_Name
,
1895 Expressions
=> New_List
(New_Occurrence_Of
(Index
, Loc
)));
1900 Make_Procedure_Call_Statement
(Loc
,
1902 Parameter_Associations
=> Actuals
);
1904 -- Now add formals that match those of the entry, and build actuals for
1905 -- the nested entry call.
1909 New_Form
: Entity_Id
;
1910 Parm_Spec
: Node_Id
;
1913 Form
:= First_Formal
(E
);
1914 while Present
(Form
) loop
1915 New_Form
:= Make_Defining_Identifier
(Loc
, Chars
(Form
));
1917 Make_Parameter_Specification
(Loc
,
1918 Defining_Identifier
=> New_Form
,
1919 Out_Present
=> Out_Present
(Parent
(Form
)),
1920 In_Present
=> In_Present
(Parent
(Form
)),
1921 Parameter_Type
=> New_Occurrence_Of
(Etype
(Form
), Loc
));
1923 Append
(Parm_Spec
, Specs
);
1924 Append
(New_Occurrence_Of
(New_Form
, Loc
), Actuals
);
1929 -- Add renaming declarations for the discriminants of the enclosing
1930 -- type, which may be visible in the preconditions.
1932 if Has_Discriminants
(Synch_Type
) then
1938 D
:= First_Discriminant
(Synch_Type
);
1939 while Present
(D
) loop
1941 Make_Object_Renaming_Declaration
(Loc
,
1942 Defining_Identifier
=>
1943 Make_Defining_Identifier
(Loc
, Chars
(D
)),
1944 Subtype_Mark
=> New_Reference_To
(Etype
(D
), Loc
),
1946 Make_Selected_Component
(Loc
,
1947 Prefix
=> New_Reference_To
(Synch_Id
, Loc
),
1948 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
1949 Prepend
(Decl
, Decls
);
1950 Next_Discriminant
(D
);
1955 Set_PPC_Wrapper
(E
, Wrapper_Id
);
1957 Make_Subprogram_Body
(Loc
,
1959 Make_Procedure_Specification
(Loc
,
1960 Defining_Unit_Name
=> Wrapper_Id
,
1961 Parameter_Specifications
=> Specs
),
1962 Declarations
=> Decls
,
1963 Handled_Statement_Sequence
=>
1964 Make_Handled_Sequence_Of_Statements
(Loc
,
1965 Statements
=> New_List
(Entry_Call
)));
1967 -- The wrapper body is analyzed when the enclosing type is frozen
1969 Append_Freeze_Action
(Defining_Entity
(Decl
), Wrapper_Body
);
1970 end Build_PPC_Wrapper
;
1972 --------------------------
1973 -- Build_Wrapper_Bodies --
1974 --------------------------
1976 procedure Build_Wrapper_Bodies
1981 Rec_Typ
: Entity_Id
;
1983 function Build_Wrapper_Body
1985 Subp_Id
: Entity_Id
;
1986 Obj_Typ
: Entity_Id
;
1987 Formals
: List_Id
) return Node_Id
;
1988 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1989 -- associated with a protected or task type. Subp_Id is the subprogram
1990 -- name which will be wrapped. Obj_Typ is the type of the new formal
1991 -- parameter which handles dispatching and object notation. Formals are
1992 -- the original formals of Subp_Id which will be explicitly replicated.
1994 ------------------------
1995 -- Build_Wrapper_Body --
1996 ------------------------
1998 function Build_Wrapper_Body
2000 Subp_Id
: Entity_Id
;
2001 Obj_Typ
: Entity_Id
;
2002 Formals
: List_Id
) return Node_Id
2004 Body_Spec
: Node_Id
;
2007 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
2009 -- The subprogram is not overriding or is not a primitive declared
2010 -- between two views.
2012 if No
(Body_Spec
) then
2017 Actuals
: List_Id
:= No_List
;
2019 First_Form
: Node_Id
;
2024 -- Map formals to actuals. Use the list built for the wrapper
2025 -- spec, skipping the object notation parameter.
2027 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
2029 Formal
:= First_Form
;
2032 if Present
(Formal
) then
2033 Actuals
:= New_List
;
2034 while Present
(Formal
) loop
2036 Make_Identifier
(Loc
,
2037 Chars
=> Chars
(Defining_Identifier
(Formal
))));
2042 -- Special processing for primitives declared between a private
2043 -- type and its completion: the wrapper needs a properly typed
2044 -- parameter if the wrapped operation has a controlling first
2045 -- parameter. Note that this might not be the case for a function
2046 -- with a controlling result.
2048 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
2049 if No
(Actuals
) then
2050 Actuals
:= New_List
;
2053 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
2054 Prepend_To
(Actuals
,
2055 Unchecked_Convert_To
2056 (Corresponding_Concurrent_Type
(Obj_Typ
),
2057 Make_Identifier
(Loc
, Name_uO
)));
2060 Prepend_To
(Actuals
,
2061 Make_Identifier
(Loc
,
2062 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
2065 Nam
:= New_Reference_To
(Subp_Id
, Loc
);
2067 -- An access-to-variable object parameter requires an explicit
2068 -- dereference in the unchecked conversion. This case occurs
2069 -- when a protected entry wrapper must override an interface
2070 -- level procedure with interface access as first parameter.
2072 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
2074 if Nkind
(Parameter_Type
(First_Form
)) =
2078 Make_Explicit_Dereference
(Loc
,
2079 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
2081 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
2085 Make_Selected_Component
(Loc
,
2087 Unchecked_Convert_To
2088 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
2089 Selector_Name
=> New_Reference_To
(Subp_Id
, Loc
));
2092 -- Create the subprogram body. For a function, the call to the
2093 -- actual subprogram has to be converted to the corresponding
2094 -- record if it is a controlling result.
2096 if Ekind
(Subp_Id
) = E_Function
then
2102 Make_Function_Call
(Loc
,
2104 Parameter_Associations
=> Actuals
);
2106 if Has_Controlling_Result
(Subp_Id
) then
2108 Unchecked_Convert_To
2109 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
2113 Make_Subprogram_Body
(Loc
,
2114 Specification
=> Body_Spec
,
2115 Declarations
=> Empty_List
,
2116 Handled_Statement_Sequence
=>
2117 Make_Handled_Sequence_Of_Statements
(Loc
,
2118 Statements
=> New_List
(
2119 Make_Simple_Return_Statement
(Loc
, Res
))));
2124 Make_Subprogram_Body
(Loc
,
2125 Specification
=> Body_Spec
,
2126 Declarations
=> Empty_List
,
2127 Handled_Statement_Sequence
=>
2128 Make_Handled_Sequence_Of_Statements
(Loc
,
2129 Statements
=> New_List
(
2130 Make_Procedure_Call_Statement
(Loc
,
2132 Parameter_Associations
=> Actuals
))));
2135 end Build_Wrapper_Body
;
2137 -- Start of processing for Build_Wrapper_Bodies
2140 if Is_Concurrent_Type
(Typ
) then
2141 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2146 -- Generate wrapper bodies for a concurrent type which implements an
2149 if Present
(Interfaces
(Rec_Typ
)) then
2151 Insert_Nod
: Node_Id
;
2153 Prim_Elmt
: Elmt_Id
;
2154 Prim_Decl
: Node_Id
;
2156 Wrap_Body
: Node_Id
;
2157 Wrap_Id
: Entity_Id
;
2162 -- Examine all primitive operations of the corresponding record
2163 -- type, looking for wrapper specs. Generate bodies in order to
2166 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
2167 while Present
(Prim_Elmt
) loop
2168 Prim
:= Node
(Prim_Elmt
);
2170 if (Ekind
(Prim
) = E_Function
2171 or else Ekind
(Prim
) = E_Procedure
)
2172 and then Is_Primitive_Wrapper
(Prim
)
2174 Subp
:= Wrapped_Entity
(Prim
);
2175 Prim_Decl
:= Parent
(Parent
(Prim
));
2178 Build_Wrapper_Body
(Loc
,
2181 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
2182 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
2184 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
2185 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
2187 Insert_After
(Insert_Nod
, Wrap_Body
);
2188 Insert_Nod
:= Wrap_Body
;
2190 Analyze
(Wrap_Body
);
2193 Next_Elmt
(Prim_Elmt
);
2197 end Build_Wrapper_Bodies
;
2199 ------------------------
2200 -- Build_Wrapper_Spec --
2201 ------------------------
2203 function Build_Wrapper_Spec
2204 (Subp_Id
: Entity_Id
;
2205 Obj_Typ
: Entity_Id
;
2206 Formals
: List_Id
) return Node_Id
2208 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2209 First_Param
: Node_Id
;
2211 Iface_Elmt
: Elmt_Id
;
2212 Iface_Op
: Entity_Id
;
2213 Iface_Op_Elmt
: Elmt_Id
;
2215 function Overriding_Possible
2216 (Iface_Op
: Entity_Id
;
2217 Wrapper
: Entity_Id
) return Boolean;
2218 -- Determine whether a primitive operation can be overridden by Wrapper.
2219 -- Iface_Op is the candidate primitive operation of an interface type,
2220 -- Wrapper is the generated entry wrapper.
2222 function Replicate_Formals
2224 Formals
: List_Id
) return List_Id
;
2225 -- An explicit parameter replication is required due to the Is_Entry_
2226 -- Formal flag being set for all the formals of an entry. The explicit
2227 -- replication removes the flag that would otherwise cause a different
2228 -- path of analysis.
2230 -------------------------
2231 -- Overriding_Possible --
2232 -------------------------
2234 function Overriding_Possible
2235 (Iface_Op
: Entity_Id
;
2236 Wrapper
: Entity_Id
) return Boolean
2238 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2239 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2241 function Type_Conformant_Parameters
2242 (Iface_Op_Params
: List_Id
;
2243 Wrapper_Params
: List_Id
) return Boolean;
2244 -- Determine whether the parameters of the generated entry wrapper
2245 -- and those of a primitive operation are type conformant. During
2246 -- this check, the first parameter of the primitive operation is
2247 -- skipped if it is a controlling argument: protected functions
2248 -- may have a controlling result.
2250 --------------------------------
2251 -- Type_Conformant_Parameters --
2252 --------------------------------
2254 function Type_Conformant_Parameters
2255 (Iface_Op_Params
: List_Id
;
2256 Wrapper_Params
: List_Id
) return Boolean
2258 Iface_Op_Param
: Node_Id
;
2259 Iface_Op_Typ
: Entity_Id
;
2260 Wrapper_Param
: Node_Id
;
2261 Wrapper_Typ
: Entity_Id
;
2264 -- Skip the first (controlling) parameter of primitive operation
2266 Iface_Op_Param
:= First
(Iface_Op_Params
);
2268 if Present
(First_Formal
(Iface_Op
))
2269 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2271 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2274 Wrapper_Param
:= First
(Wrapper_Params
);
2275 while Present
(Iface_Op_Param
)
2276 and then Present
(Wrapper_Param
)
2278 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2279 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2281 -- The two parameters must be mode conformant
2283 if not Conforming_Types
2284 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2289 Next
(Iface_Op_Param
);
2290 Next
(Wrapper_Param
);
2293 -- One of the lists is longer than the other
2295 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2300 end Type_Conformant_Parameters
;
2302 -- Start of processing for Overriding_Possible
2305 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2309 -- If an inherited subprogram is implemented by a protected procedure
2310 -- or an entry, then the first parameter of the inherited subprogram
2311 -- shall be of mode OUT or IN OUT, or access-to-variable parameter.
2313 if Ekind
(Iface_Op
) = E_Procedure
2314 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2317 Obj_Param
: constant Node_Id
:=
2318 First
(Parameter_Specifications
(Iface_Op_Spec
));
2320 if not Out_Present
(Obj_Param
)
2321 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2330 Type_Conformant_Parameters
(
2331 Parameter_Specifications
(Iface_Op_Spec
),
2332 Parameter_Specifications
(Wrapper_Spec
));
2333 end Overriding_Possible
;
2335 -----------------------
2336 -- Replicate_Formals --
2337 -----------------------
2339 function Replicate_Formals
2341 Formals
: List_Id
) return List_Id
2343 New_Formals
: constant List_Id
:= New_List
;
2345 Param_Type
: Node_Id
;
2348 Formal
:= First
(Formals
);
2350 -- Skip the object parameter when dealing with primitives declared
2351 -- between two views.
2353 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2354 and then not Has_Controlling_Result
(Subp_Id
)
2356 Formal
:= Next
(Formal
);
2359 while Present
(Formal
) loop
2361 -- Create an explicit copy of the entry parameter
2363 -- When creating the wrapper subprogram for a primitive operation
2364 -- of a protected interface we must construct an equivalent
2365 -- signature to that of the overriding operation. For regular
2366 -- parameters we can just use the type of the formal, but for
2367 -- access to subprogram parameters we need to reanalyze the
2368 -- parameter type to create local entities for the signature of
2369 -- the subprogram type. Using the entities of the overriding
2370 -- subprogram will result in out-of-scope errors in the back-end.
2372 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2373 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2376 New_Reference_To
(Etype
(Parameter_Type
(Formal
)), Loc
);
2379 Append_To
(New_Formals
,
2380 Make_Parameter_Specification
(Loc
,
2381 Defining_Identifier
=>
2382 Make_Defining_Identifier
(Loc
,
2383 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2384 In_Present
=> In_Present
(Formal
),
2385 Out_Present
=> Out_Present
(Formal
),
2386 Parameter_Type
=> Param_Type
));
2392 end Replicate_Formals
;
2394 -- Start of processing for Build_Wrapper_Spec
2397 -- There is no point in building wrappers for non-tagged concurrent
2400 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2402 -- An entry or a protected procedure can override a routine where the
2403 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2404 -- type. Since the wrapper must have the exact same signature as that of
2405 -- the overridden subprogram, we try to find the overriding candidate
2406 -- and use its controlling formal.
2408 First_Param
:= Empty
;
2410 -- Check every implemented interface
2412 if Present
(Interfaces
(Obj_Typ
)) then
2413 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2414 Search
: while Present
(Iface_Elmt
) loop
2415 Iface
:= Node
(Iface_Elmt
);
2417 -- Check every interface primitive
2419 if Present
(Primitive_Operations
(Iface
)) then
2420 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2421 while Present
(Iface_Op_Elmt
) loop
2422 Iface_Op
:= Node
(Iface_Op_Elmt
);
2424 -- Ignore predefined primitives
2426 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2427 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2429 -- The current primitive operation can be overridden by
2430 -- the generated entry wrapper.
2432 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2434 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2440 Next_Elmt
(Iface_Op_Elmt
);
2444 Next_Elmt
(Iface_Elmt
);
2448 -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by
2449 -- this subprogram and this is not a primitive declared between two
2450 -- views then force the generation of a wrapper. As an optimization,
2451 -- previous versions of the frontend avoid generating the wrapper;
2452 -- however, the wrapper facilitates locating and reporting an error
2453 -- when a duplicate declaration is found later. See example in
2457 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2460 (Corresponding_Concurrent_Type
(Obj_Typ
))
2463 Make_Parameter_Specification
(Loc
,
2464 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
2466 Out_Present
=> False,
2467 Parameter_Type
=> New_Reference_To
(Obj_Typ
, Loc
));
2469 -- For entries and procedures of protected types the mode of
2470 -- the controlling argument must be in-out.
2474 Make_Parameter_Specification
(Loc
,
2475 Defining_Identifier
=>
2476 Make_Defining_Identifier
(Loc
,
2479 Out_Present
=> (Ekind
(Subp_Id
) /= E_Function
),
2480 Parameter_Type
=> New_Reference_To
(Obj_Typ
, Loc
));
2485 Wrapper_Id
: constant Entity_Id
:=
2486 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2487 New_Formals
: List_Id
;
2488 Obj_Param
: Node_Id
;
2489 Obj_Param_Typ
: Entity_Id
;
2492 -- Minimum decoration is needed to catch the entity in
2493 -- Sem_Ch6.Override_Dispatching_Operation.
2495 if Ekind
(Subp_Id
) = E_Function
then
2496 Set_Ekind
(Wrapper_Id
, E_Function
);
2498 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2501 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2502 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2503 Set_Is_Private_Primitive
(Wrapper_Id
,
2504 Is_Private_Primitive_Subprogram
(Subp_Id
));
2506 -- Process the formals
2508 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2510 -- A function with a controlling result and no first controlling
2511 -- formal needs no additional parameter.
2513 if Has_Controlling_Result
(Subp_Id
)
2515 (No
(First_Formal
(Subp_Id
))
2516 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2520 -- Routine Subp_Id has been found to override an interface primitive.
2521 -- If the interface operation has an access parameter, create a copy
2522 -- of it, with the same null exclusion indicator if present.
2524 elsif Present
(First_Param
) then
2525 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2527 Make_Access_Definition
(Loc
,
2529 New_Reference_To
(Obj_Typ
, Loc
));
2530 Set_Null_Exclusion_Present
(Obj_Param_Typ
,
2531 Null_Exclusion_Present
(Parameter_Type
(First_Param
)));
2534 Obj_Param_Typ
:= New_Reference_To
(Obj_Typ
, Loc
);
2538 Make_Parameter_Specification
(Loc
,
2539 Defining_Identifier
=>
2540 Make_Defining_Identifier
(Loc
,
2542 In_Present
=> In_Present
(First_Param
),
2543 Out_Present
=> Out_Present
(First_Param
),
2544 Parameter_Type
=> Obj_Param_Typ
);
2546 Prepend_To
(New_Formals
, Obj_Param
);
2548 -- If we are dealing with a primitive declared between two views,
2549 -- implemented by a synchronized operation, we need to create
2550 -- a default parameter. The mode of the parameter must match that
2551 -- of the primitive operation.
2554 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2556 Make_Parameter_Specification
(Loc
,
2557 Defining_Identifier
=>
2558 Make_Defining_Identifier
(Loc
, Name_uO
),
2559 In_Present
=> In_Present
(Parent
(First_Entity
(Subp_Id
))),
2560 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2561 Parameter_Type
=> New_Reference_To
(Obj_Typ
, Loc
));
2562 Prepend_To
(New_Formals
, Obj_Param
);
2565 -- Build the final spec. If it is a function with a controlling
2566 -- result, it is a primitive operation of the corresponding
2567 -- record type, so mark the spec accordingly.
2569 if Ekind
(Subp_Id
) = E_Function
then
2574 if Has_Controlling_Result
(Subp_Id
) then
2577 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2579 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2583 Make_Function_Specification
(Loc
,
2584 Defining_Unit_Name
=> Wrapper_Id
,
2585 Parameter_Specifications
=> New_Formals
,
2586 Result_Definition
=> Res_Def
);
2590 Make_Procedure_Specification
(Loc
,
2591 Defining_Unit_Name
=> Wrapper_Id
,
2592 Parameter_Specifications
=> New_Formals
);
2595 end Build_Wrapper_Spec
;
2597 -------------------------
2598 -- Build_Wrapper_Specs --
2599 -------------------------
2601 procedure Build_Wrapper_Specs
2607 Rec_Typ
: Entity_Id
;
2608 procedure Scan_Declarations
(L
: List_Id
);
2609 -- Common processing for visible and private declarations
2610 -- of a protected type.
2612 procedure Scan_Declarations
(L
: List_Id
) is
2614 Wrap_Decl
: Node_Id
;
2615 Wrap_Spec
: Node_Id
;
2623 while Present
(Decl
) loop
2626 if Nkind
(Decl
) = N_Entry_Declaration
2627 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2631 (Subp_Id
=> Defining_Identifier
(Decl
),
2633 Formals
=> Parameter_Specifications
(Decl
));
2635 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2638 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2641 Parameter_Specifications
(Specification
(Decl
)));
2644 if Present
(Wrap_Spec
) then
2646 Make_Subprogram_Declaration
(Loc
,
2647 Specification
=> Wrap_Spec
);
2649 Insert_After
(N
, Wrap_Decl
);
2652 Analyze
(Wrap_Decl
);
2657 end Scan_Declarations
;
2659 -- start of processing for Build_Wrapper_Specs
2662 if Is_Protected_Type
(Typ
) then
2663 Def
:= Protected_Definition
(Parent
(Typ
));
2664 else pragma Assert
(Is_Task_Type
(Typ
));
2665 Def
:= Task_Definition
(Parent
(Typ
));
2668 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2670 -- Generate wrapper specs for a concurrent type which implements an
2671 -- interface. Operations in both the visible and private parts may
2672 -- implement progenitor operations.
2674 if Present
(Interfaces
(Rec_Typ
))
2675 and then Present
(Def
)
2677 Scan_Declarations
(Visible_Declarations
(Def
));
2678 Scan_Declarations
(Private_Declarations
(Def
));
2680 end Build_Wrapper_Specs
;
2682 ---------------------------
2683 -- Build_Find_Body_Index --
2684 ---------------------------
2686 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2687 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2690 Has_F
: Boolean := False;
2692 If_St
: Node_Id
:= Empty
;
2695 Decls
: List_Id
:= New_List
;
2698 Siz
: Node_Id
:= Empty
;
2700 procedure Add_If_Clause
(Expr
: Node_Id
);
2701 -- Add test for range of current entry
2703 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2704 -- If a bound of an entry is given by a discriminant, retrieve the
2705 -- actual value of the discriminant from the enclosing object.
2711 procedure Add_If_Clause
(Expr
: Node_Id
) is
2713 Stats
: constant List_Id
:=
2715 Make_Simple_Return_Statement
(Loc
,
2716 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2719 -- Index for current entry body
2723 -- Compute total length of entry queues so far
2731 Right_Opnd
=> Expr
);
2736 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2739 -- Map entry queue indexes in the range of the current family
2740 -- into the current index, that designates the entry body.
2744 Make_Implicit_If_Statement
(Typ
,
2746 Then_Statements
=> Stats
,
2747 Elsif_Parts
=> New_List
);
2751 Append_To
(Elsif_Parts
(If_St
),
2752 Make_Elsif_Part
(Loc
,
2754 Then_Statements
=> Stats
));
2758 ------------------------------
2759 -- Convert_Discriminant_Ref --
2760 ------------------------------
2762 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2766 if Is_Entity_Name
(Bound
)
2767 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2770 Make_Selected_Component
(Loc
,
2772 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2773 Make_Explicit_Dereference
(Loc
,
2774 Make_Identifier
(Loc
, Name_uObject
))),
2775 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
2776 Set_Etype
(B
, Etype
(Entity
(Bound
)));
2778 B
:= New_Copy_Tree
(Bound
);
2782 end Convert_Discriminant_Ref
;
2784 -- Start of processing for Build_Find_Body_Index
2787 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
2789 Ent
:= First_Entity
(Typ
);
2790 while Present
(Ent
) loop
2791 if Ekind
(Ent
) = E_Entry_Family
then
2801 -- If the protected type has no entry families, there is a one-one
2802 -- correspondence between entry queue and entry body.
2805 Make_Simple_Return_Statement
(Loc
,
2806 Expression
=> Make_Identifier
(Loc
, Name_uE
));
2809 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2812 -- if E <= l1 then return 1;
2813 -- elsif E <= l1 + l2 then return 2;
2818 Ent
:= First_Entity
(Typ
);
2820 Add_Object_Pointer
(Loc
, Typ
, Decls
);
2822 while Present
(Ent
) loop
2823 if Ekind
(Ent
) = E_Entry
then
2824 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
2826 elsif Ekind
(Ent
) = E_Entry_Family
then
2827 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
2828 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
2829 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
2830 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
2839 Make_Simple_Return_Statement
(Loc
,
2840 Expression
=> Make_Integer_Literal
(Loc
, 1));
2842 elsif Nkind
(Ret
) = N_If_Statement
then
2844 -- Ranges are in increasing order, so last one doesn't need guard
2847 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
2850 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
2856 Make_Subprogram_Body
(Loc
,
2857 Specification
=> Spec
,
2858 Declarations
=> Decls
,
2859 Handled_Statement_Sequence
=>
2860 Make_Handled_Sequence_Of_Statements
(Loc
,
2861 Statements
=> New_List
(Ret
)));
2862 end Build_Find_Body_Index
;
2864 --------------------------------
2865 -- Build_Find_Body_Index_Spec --
2866 --------------------------------
2868 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
2869 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2870 Id
: constant Entity_Id
:=
2871 Make_Defining_Identifier
(Loc
,
2872 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
2873 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
2874 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
2878 Make_Function_Specification
(Loc
,
2879 Defining_Unit_Name
=> Id
,
2880 Parameter_Specifications
=> New_List
(
2881 Make_Parameter_Specification
(Loc
,
2882 Defining_Identifier
=> Parm1
,
2884 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2886 Make_Parameter_Specification
(Loc
,
2887 Defining_Identifier
=> Parm2
,
2889 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))),
2891 Result_Definition
=> New_Occurrence_Of
(
2892 RTE
(RE_Protected_Entry_Index
), Loc
));
2893 end Build_Find_Body_Index_Spec
;
2895 -----------------------------------------------
2896 -- Build_Lock_Free_Protected_Subprogram_Body --
2897 -----------------------------------------------
2899 function Build_Lock_Free_Protected_Subprogram_Body
2902 Unprot_Spec
: Node_Id
) return Node_Id
2904 Actuals
: constant List_Id
:= New_List
;
2905 Loc
: constant Source_Ptr
:= Sloc
(N
);
2906 Spec
: constant Node_Id
:= Specification
(N
);
2907 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
2909 Prot_Spec
: Node_Id
;
2913 -- Create the protected version of the body
2916 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
2918 -- Build the actual parameters which appear in the call to the
2919 -- unprotected version of the body.
2921 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
2922 while Present
(Formal
) loop
2924 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
2929 -- Function case, generate:
2930 -- return <Unprot_Func_Call>;
2932 if Nkind
(Spec
) = N_Function_Specification
then
2934 Make_Simple_Return_Statement
(Loc
,
2936 Make_Function_Call
(Loc
,
2938 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2939 Parameter_Associations
=> Actuals
));
2941 -- Procedure case, call the unprotected version
2945 Make_Procedure_Call_Statement
(Loc
,
2947 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2948 Parameter_Associations
=> Actuals
);
2952 Make_Subprogram_Body
(Loc
,
2953 Declarations
=> Empty_List
,
2954 Specification
=> Prot_Spec
,
2955 Handled_Statement_Sequence
=>
2956 Make_Handled_Sequence_Of_Statements
(Loc
,
2957 Statements
=> New_List
(Stmt
)));
2958 end Build_Lock_Free_Protected_Subprogram_Body
;
2960 -------------------------------------------------
2961 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2962 -------------------------------------------------
2964 -- Procedures which meet the lock-free implementation requirements and
2965 -- reference a unique scalar component Comp are expanded in the following
2968 -- procedure P (...) is
2969 -- Expected_Comp : constant Comp_Type :=
2971 -- (System.Atomic_Primitives.Lock_Free_Read_N
2972 -- (_Object.Comp'Address));
2976 -- <original declarations before the object renaming declaration
2979 -- Desired_Comp : Comp_Type := Expected_Comp;
2980 -- Comp : Comp_Type renames Desired_Comp;
2982 -- <original delarations after the object renaming declaration
2986 -- <original statements>
2987 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2988 -- (_Object.Comp'Address,
2989 -- Interfaces.Unsigned_N (Expected_Comp),
2990 -- Interfaces.Unsigned_N (Desired_Comp));
2995 -- Each return and raise statement of P is transformed into an atomic
2998 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2999 -- (_Object.Comp'Address,
3000 -- Interfaces.Unsigned_N (Expected_Comp),
3001 -- Interfaces.Unsigned_N (Desired_Comp));
3003 -- <original statement>
3008 -- Functions which meet the lock-free implementation requirements and
3009 -- reference a unique scalar component Comp are expanded in the following
3012 -- function F (...) return ... is
3013 -- <original declarations before the object renaming declaration
3016 -- Expected_Comp : constant Comp_Type :=
3018 -- (System.Atomic_Primitives.Lock_Free_Read_N
3019 -- (_Object.Comp'Address));
3020 -- Comp : Comp_Type renames Expected_Comp;
3022 -- <original delarations after the object renaming declaration of
3026 -- <original statements>
3029 function Build_Lock_Free_Unprotected_Subprogram_Body
3031 Prot_Typ
: Node_Id
) return Node_Id
3033 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
3034 -- Subprograms which meet the lock-free implementation criteria are
3035 -- allowed to reference only one unique component. Return the prival
3036 -- of the said component.
3038 --------------------------
3039 -- Referenced_Component --
3040 --------------------------
3042 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
3045 Source_Comp
: Entity_Id
:= Empty
;
3048 -- Find the unique source component which N references in its
3051 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
3053 Element
: Lock_Free_Subprogram
renames
3054 Lock_Free_Subprogram_Table
.Table
(Index
);
3056 if Element
.Sub_Body
= N
then
3057 Source_Comp
:= Element
.Comp_Id
;
3063 if No
(Source_Comp
) then
3067 -- Find the prival which corresponds to the source component within
3068 -- the declarations of N.
3070 Decl
:= First
(Declarations
(N
));
3071 while Present
(Decl
) loop
3073 -- Privals appear as object renamings
3075 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
3076 Comp
:= Defining_Identifier
(Decl
);
3078 if Present
(Prival_Link
(Comp
))
3079 and then Prival_Link
(Comp
) = Source_Comp
3089 end Referenced_Component
;
3093 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
3094 Loc
: constant Source_Ptr
:= Sloc
(N
);
3095 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
3096 Decls
: List_Id
:= Declarations
(N
);
3098 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
3101 -- Add renamings for the protection object, discriminals, privals and
3102 -- the entry index constant for use by debugger.
3104 Debug_Private_Data_Declarations
(Decls
);
3106 -- Perform the lock-free expansion when the subprogram references a
3107 -- protected component.
3109 if Present
(Comp
) then
3110 Protected_Component_Ref
: declare
3111 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3112 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
3113 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
3115 Is_Procedure
: constant Boolean :=
3116 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
3117 -- Indicates if N is a protected procedure body
3119 Block_Decls
: List_Id
;
3120 Try_Write
: Entity_Id
;
3121 Desired_Comp
: Entity_Id
;
3124 Label_Id
: Entity_Id
:= Empty
;
3126 Expected_Comp
: Entity_Id
;
3129 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
3131 Unsigned
: Entity_Id
;
3133 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
3134 -- Transform a single node if it is a return statement, a raise
3135 -- statement or a reference to Comp.
3137 procedure Process_Stmts
(Stmts
: List_Id
);
3138 -- Given a statement sequence Stmts, wrap any return or raise
3139 -- statements in the following manner:
3141 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3142 -- (_Object.Comp'Address,
3143 -- Interfaces.Unsigned_N (Expected_Comp),
3144 -- Interfaces.Unsigned_N (Desired_Comp))
3155 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3157 procedure Wrap_Statement
(Stmt
: Node_Id
);
3158 -- Wrap an arbitrary statement inside an if statement where the
3159 -- condition does an atomic check on the state of the object.
3161 --------------------
3162 -- Wrap_Statement --
3163 --------------------
3165 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3167 -- The first time through, create the declaration of a label
3168 -- which is used to skip the remainder of source statements
3169 -- if the state of the object has changed.
3171 if No
(Label_Id
) then
3173 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3174 Set_Entity
(Label_Id
,
3175 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3179 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3180 -- (_Object.Comp'Address,
3181 -- Interfaces.Unsigned_N (Expected_Comp),
3182 -- Interfaces.Unsigned_N (Desired_Comp))
3190 Make_Implicit_If_Statement
(N
,
3192 Make_Function_Call
(Loc
,
3194 New_Reference_To
(Try_Write
, Loc
),
3195 Parameter_Associations
=> New_List
(
3196 Make_Attribute_Reference
(Loc
,
3197 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3198 Attribute_Name
=> Name_Address
),
3200 Unchecked_Convert_To
(Unsigned
,
3201 New_Reference_To
(Expected_Comp
, Loc
)),
3203 Unchecked_Convert_To
(Unsigned
,
3204 New_Reference_To
(Desired_Comp
, Loc
)))),
3206 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3208 Else_Statements
=> New_List
(
3209 Make_Goto_Statement
(Loc
,
3211 New_Reference_To
(Entity
(Label_Id
), Loc
)))));
3214 -- Start of processing for Process_Node
3217 -- Wrap each return and raise statement that appear inside a
3218 -- procedure. Skip the last return statement which is added by
3219 -- default since it is transformed into an exit statement.
3222 and then ((Nkind
(N
) = N_Simple_Return_Statement
3223 and then N
/= Last
(Stmts
))
3224 or else Nkind
(N
) = N_Extended_Return_Statement
3225 or else (Nkind_In
(N
, N_Raise_Constraint_Error
,
3226 N_Raise_Program_Error
,
3228 N_Raise_Storage_Error
)
3229 and then Comes_From_Source
(N
)))
3237 Set_Analyzed
(N
, False);
3242 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3248 procedure Process_Stmts
(Stmts
: List_Id
) is
3251 Stmt
:= First
(Stmts
);
3252 while Present
(Stmt
) loop
3253 Process_Nodes
(Stmt
);
3258 -- Start of processing for Protected_Component_Ref
3261 -- Get the type size
3263 if Known_Static_Esize
(Comp_Type
) then
3264 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3266 -- If the Esize (Object_Size) is unknown at compile-time, look at
3267 -- the RM_Size (Value_Size) since it may have been set by an
3268 -- explicit representation clause.
3270 elsif Known_Static_RM_Size
(Comp_Type
) then
3271 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3273 -- Should not happen since this has already been checked in
3274 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3277 raise Program_Error
;
3280 -- Retrieve all relevant atomic routines and types
3284 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3285 Read
:= RTE
(RE_Lock_Free_Read_8
);
3286 Unsigned
:= RTE
(RE_Uint8
);
3289 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3290 Read
:= RTE
(RE_Lock_Free_Read_16
);
3291 Unsigned
:= RTE
(RE_Uint16
);
3294 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3295 Read
:= RTE
(RE_Lock_Free_Read_32
);
3296 Unsigned
:= RTE
(RE_Uint32
);
3299 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3300 Read
:= RTE
(RE_Lock_Free_Read_64
);
3301 Unsigned
:= RTE
(RE_Uint64
);
3304 raise Program_Error
;
3308 -- Expected_Comp : constant Comp_Type :=
3310 -- (System.Atomic_Primitives.Lock_Free_Read_N
3311 -- (_Object.Comp'Address));
3314 Make_Defining_Identifier
(Loc
,
3315 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3318 Make_Object_Declaration
(Loc
,
3319 Defining_Identifier
=> Expected_Comp
,
3320 Object_Definition
=> New_Reference_To
(Comp_Type
, Loc
),
3321 Constant_Present
=> True,
3323 Unchecked_Convert_To
(Comp_Type
,
3324 Make_Function_Call
(Loc
,
3325 Name
=> New_Reference_To
(Read
, Loc
),
3326 Parameter_Associations
=> New_List
(
3327 Make_Attribute_Reference
(Loc
,
3328 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3329 Attribute_Name
=> Name_Address
)))));
3331 -- Protected procedures
3333 if Is_Procedure
then
3334 -- Move the original declarations inside the generated block
3336 Block_Decls
:= Decls
;
3338 -- Reset the declarations list of the protected procedure to
3339 -- contain only Decl.
3341 Decls
:= New_List
(Decl
);
3344 -- Desired_Comp : Comp_Type := Expected_Comp;
3347 Make_Defining_Identifier
(Loc
,
3348 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3350 -- Insert the declarations of Expected_Comp and Desired_Comp in
3351 -- the block declarations right before the renaming of the
3352 -- protected component.
3354 Insert_Before
(Comp_Decl
,
3355 Make_Object_Declaration
(Loc
,
3356 Defining_Identifier
=> Desired_Comp
,
3357 Object_Definition
=> New_Reference_To
(Comp_Type
, Loc
),
3359 New_Reference_To
(Expected_Comp
, Loc
)));
3361 -- Protected function
3364 Desired_Comp
:= Expected_Comp
;
3366 -- Insert the declaration of Expected_Comp in the function
3367 -- declarations right before the renaming of the protected
3370 Insert_Before
(Comp_Decl
, Decl
);
3373 -- Rewrite the protected component renaming declaration to be a
3374 -- renaming of Desired_Comp.
3377 -- Comp : Comp_Type renames Desired_Comp;
3380 Make_Object_Renaming_Declaration
(Loc
,
3381 Defining_Identifier
=>
3382 Defining_Identifier
(Comp_Decl
),
3384 New_Occurrence_Of
(Comp_Type
, Loc
),
3386 New_Reference_To
(Desired_Comp
, Loc
)));
3388 -- Wrap any return or raise statements in Stmts in same the manner
3389 -- described in Process_Stmts.
3391 Process_Stmts
(Stmts
);
3394 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3395 -- (_Object.Comp'Address,
3396 -- Interfaces.Unsigned_N (Expected_Comp),
3397 -- Interfaces.Unsigned_N (Desired_Comp))
3399 if Is_Procedure
then
3401 Make_Exit_Statement
(Loc
,
3403 Make_Function_Call
(Loc
,
3405 New_Reference_To
(Try_Write
, Loc
),
3406 Parameter_Associations
=> New_List
(
3407 Make_Attribute_Reference
(Loc
,
3408 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3409 Attribute_Name
=> Name_Address
),
3411 Unchecked_Convert_To
(Unsigned
,
3412 New_Reference_To
(Expected_Comp
, Loc
)),
3414 Unchecked_Convert_To
(Unsigned
,
3415 New_Reference_To
(Desired_Comp
, Loc
)))));
3417 -- Small optimization: transform the default return statement
3418 -- of a procedure into the atomic exit statement.
3420 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3421 Rewrite
(Last
(Stmts
), Stmt
);
3423 Append_To
(Stmts
, Stmt
);
3427 -- Create the declaration of the label used to skip the rest of
3428 -- the source statements when the object state changes.
3430 if Present
(Label_Id
) then
3431 Label
:= Make_Label
(Loc
, Label_Id
);
3433 Make_Implicit_Label_Declaration
(Loc
,
3434 Defining_Identifier
=> Entity
(Label_Id
),
3435 Label_Construct
=> Label
));
3436 Append_To
(Stmts
, Label
);
3448 if Is_Procedure
then
3451 Make_Loop_Statement
(Loc
,
3452 Statements
=> New_List
(
3453 Make_Block_Statement
(Loc
,
3454 Declarations
=> Block_Decls
,
3455 Handled_Statement_Sequence
=>
3456 Make_Handled_Sequence_Of_Statements
(Loc
,
3457 Statements
=> Stmts
))),
3458 End_Label
=> Empty
));
3462 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3463 end Protected_Component_Ref
;
3466 -- Make an unprotected version of the subprogram for use within the same
3467 -- object, with new name and extra parameter representing the object.
3470 Make_Subprogram_Body
(Loc
,
3472 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3473 Declarations
=> Decls
,
3474 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3475 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3477 -------------------------
3478 -- Build_Master_Entity --
3479 -------------------------
3481 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3482 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3484 Context_Id
: Entity_Id
;
3490 if Is_Itype
(Obj_Or_Typ
) then
3491 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3493 Par
:= Parent
(Obj_Or_Typ
);
3496 -- When creating a master for a record component which is either a task
3497 -- or access-to-task, the enclosing record is the master scope and the
3498 -- proper insertion point is the component list.
3500 if Is_Record_Type
(Current_Scope
) then
3502 Context_Id
:= Current_Scope
;
3503 Decls
:= List_Containing
(Context
);
3505 -- Default case for object declarations and access types. Note that the
3506 -- context is updated to the nearest enclosing body, block, package or
3507 -- return statement.
3510 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3513 -- Do not create a master if one already exists or there is no task
3516 if Has_Master_Entity
(Context_Id
)
3517 or else Restriction_Active
(No_Task_Hierarchy
)
3522 -- Create a master, generate:
3523 -- _Master : constant Master_Id := Current_Master.all;
3526 Make_Object_Declaration
(Loc
,
3527 Defining_Identifier
=>
3528 Make_Defining_Identifier
(Loc
, Name_uMaster
),
3529 Constant_Present
=> True,
3530 Object_Definition
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
3532 Make_Explicit_Dereference
(Loc
,
3533 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
3535 -- The master is inserted at the start of the declarative list of the
3538 Prepend_To
(Decls
, Decl
);
3540 -- In certain cases where transient scopes are involved, the immediate
3541 -- scope is not always the proper master scope. Ensure that the master
3542 -- declaration and entity appear in the same context.
3544 if Context_Id
/= Current_Scope
then
3545 Push_Scope
(Context_Id
);
3552 -- Mark the enclosing scope and its associated construct as being task
3555 Set_Has_Master_Entity
(Context_Id
);
3557 while Present
(Context
)
3558 and then Nkind
(Context
) /= N_Compilation_Unit
3560 if Nkind_In
(Context
, N_Block_Statement
,
3564 Set_Is_Task_Master
(Context
);
3567 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3568 Context
:= Corresponding_Stub
(Parent
(Context
));
3571 Context
:= Parent
(Context
);
3573 end Build_Master_Entity
;
3575 ---------------------------
3576 -- Build_Master_Renaming --
3577 ---------------------------
3579 procedure Build_Master_Renaming
3580 (Ptr_Typ
: Entity_Id
;
3581 Ins_Nod
: Node_Id
:= Empty
)
3583 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3585 Master_Decl
: Node_Id
;
3586 Master_Id
: Entity_Id
;
3589 -- Nothing to do if there is no task hierarchy
3591 if Restriction_Active
(No_Task_Hierarchy
) then
3595 -- Determine the proper context to insert the master renaming
3597 if Present
(Ins_Nod
) then
3599 elsif Is_Itype
(Ptr_Typ
) then
3600 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3602 Context
:= Parent
(Ptr_Typ
);
3606 -- <Ptr_Typ>M : Master_Id renames _Master;
3609 Make_Defining_Identifier
(Loc
,
3610 New_External_Name
(Chars
(Ptr_Typ
), 'M'));
3613 Make_Object_Renaming_Declaration
(Loc
,
3614 Defining_Identifier
=> Master_Id
,
3615 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
3616 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3618 Insert_Action
(Context
, Master_Decl
);
3620 -- The renamed master now services the access type
3622 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3623 end Build_Master_Renaming
;
3625 -----------------------------------------
3626 -- Build_Private_Protected_Declaration --
3627 -----------------------------------------
3629 function Build_Private_Protected_Declaration
3630 (N
: Node_Id
) return Entity_Id
3632 Loc
: constant Source_Ptr
:= Sloc
(N
);
3633 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3638 Spec_Id
: Entity_Id
;
3641 Formal
:= First_Formal
(Body_Id
);
3643 -- The protected operation always has at least one formal, namely the
3644 -- object itself, but it is only placed in the parameter list if
3645 -- expansion is enabled.
3647 if Present
(Formal
) or else Expander_Active
then
3648 Plist
:= Copy_Parameter_List
(Body_Id
);
3653 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
3655 Make_Procedure_Specification
(Loc
,
3656 Defining_Unit_Name
=>
3657 Make_Defining_Identifier
(Sloc
(Body_Id
),
3658 Chars
=> Chars
(Body_Id
)),
3659 Parameter_Specifications
=>
3663 Make_Function_Specification
(Loc
,
3664 Defining_Unit_Name
=>
3665 Make_Defining_Identifier
(Sloc
(Body_Id
),
3666 Chars
=> Chars
(Body_Id
)),
3667 Parameter_Specifications
=> Plist
,
3668 Result_Definition
=>
3669 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
3672 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> New_Spec
);
3673 Insert_Before
(N
, Decl
);
3674 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
3676 -- Indicate that the entity comes from source, to ensure that cross-
3677 -- reference information is properly generated. The body itself is
3678 -- rewritten during expansion, and the body entity will not appear in
3679 -- calls to the operation.
3681 Set_Comes_From_Source
(Spec_Id
, True);
3683 Set_Has_Completion
(Spec_Id
);
3684 Set_Convention
(Spec_Id
, Convention_Protected
);
3686 end Build_Private_Protected_Declaration
;
3688 ---------------------------
3689 -- Build_Protected_Entry --
3690 ---------------------------
3692 function Build_Protected_Entry
3695 Pid
: Node_Id
) return Node_Id
3697 Loc
: constant Source_Ptr
:= Sloc
(N
);
3699 Decls
: constant List_Id
:= Declarations
(N
);
3700 End_Lab
: constant Node_Id
:=
3701 End_Label
(Handled_Statement_Sequence
(N
));
3702 End_Loc
: constant Source_Ptr
:=
3703 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3704 -- Used for the generated call to Complete_Entry_Body
3706 Han_Loc
: Source_Ptr
;
3707 -- Used for the exception handler, inserted at end of the body
3709 Op_Decls
: constant List_Id
:= New_List
;
3717 -- Set the source location on the exception handler only when debugging
3718 -- the expanded code (see Make_Implicit_Exception_Handler).
3720 if Debug_Generated_Code
then
3723 -- Otherwise the inserted code should not be visible to the debugger
3726 Han_Loc
:= No_Location
;
3730 Make_Defining_Identifier
(Loc
,
3731 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3733 Build_Protected_Entry_Specification
(Loc
, Edef
, Empty
);
3735 -- Add the following declarations:
3736 -- type poVP is access poV;
3737 -- _object : poVP := poVP (_O);
3739 -- where _O is the formal parameter associated with the concurrent
3740 -- object. These declarations are needed for Complete_Entry_Body.
3742 Add_Object_Pointer
(Loc
, Pid
, Op_Decls
);
3744 -- Add renamings for all formals, the Protection object, discriminals,
3745 -- privals and the entry index constant for use by debugger.
3747 Add_Formal_Renamings
(Espec
, Op_Decls
, Ent
, Loc
);
3748 Debug_Private_Data_Declarations
(Decls
);
3750 case Corresponding_Runtime_Package
(Pid
) is
3751 when System_Tasking_Protected_Objects_Entries
=>
3753 New_Reference_To
(RTE
(RE_Complete_Entry_Body
), Loc
);
3755 when System_Tasking_Protected_Objects_Single_Entry
=>
3757 New_Reference_To
(RTE
(RE_Complete_Single_Entry_Body
), Loc
);
3760 raise Program_Error
;
3763 Op_Stats
:= New_List
(
3764 Make_Block_Statement
(Loc
,
3765 Declarations
=> Decls
,
3766 Handled_Statement_Sequence
=>
3767 Handled_Statement_Sequence
(N
)),
3769 Make_Procedure_Call_Statement
(End_Loc
,
3771 Parameter_Associations
=> New_List
(
3772 Make_Attribute_Reference
(End_Loc
,
3774 Make_Selected_Component
(End_Loc
,
3775 Prefix
=> Make_Identifier
(End_Loc
, Name_uObject
),
3776 Selector_Name
=> Make_Identifier
(End_Loc
, Name_uObject
)),
3777 Attribute_Name
=> Name_Unchecked_Access
))));
3779 -- When exceptions can not be propagated, we never need to call
3780 -- Exception_Complete_Entry_Body
3782 if No_Exception_Handlers_Set
then
3784 Make_Subprogram_Body
(Loc
,
3785 Specification
=> Espec
,
3786 Declarations
=> Op_Decls
,
3787 Handled_Statement_Sequence
=>
3788 Make_Handled_Sequence_Of_Statements
(Loc
,
3789 Statements
=> Op_Stats
,
3790 End_Label
=> End_Lab
));
3793 Ohandle
:= Make_Others_Choice
(Loc
);
3794 Set_All_Others
(Ohandle
);
3796 case Corresponding_Runtime_Package
(Pid
) is
3797 when System_Tasking_Protected_Objects_Entries
=>
3800 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
3802 when System_Tasking_Protected_Objects_Single_Entry
=>
3805 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
3808 raise Program_Error
;
3811 -- Establish link between subprogram body entity and source entry
3813 Set_Corresponding_Protected_Entry
(Edef
, Ent
);
3815 -- Create body of entry procedure. The renaming declarations are
3816 -- placed ahead of the block that contains the actual entry body.
3819 Make_Subprogram_Body
(Loc
,
3820 Specification
=> Espec
,
3821 Declarations
=> Op_Decls
,
3822 Handled_Statement_Sequence
=>
3823 Make_Handled_Sequence_Of_Statements
(Loc
,
3824 Statements
=> Op_Stats
,
3825 End_Label
=> End_Lab
,
3826 Exception_Handlers
=> New_List
(
3827 Make_Implicit_Exception_Handler
(Han_Loc
,
3828 Exception_Choices
=> New_List
(Ohandle
),
3830 Statements
=> New_List
(
3831 Make_Procedure_Call_Statement
(Han_Loc
,
3833 Parameter_Associations
=> New_List
(
3834 Make_Attribute_Reference
(Han_Loc
,
3836 Make_Selected_Component
(Han_Loc
,
3838 Make_Identifier
(Han_Loc
, Name_uObject
),
3840 Make_Identifier
(Han_Loc
, Name_uObject
)),
3841 Attribute_Name
=> Name_Unchecked_Access
),
3843 Make_Function_Call
(Han_Loc
,
3844 Name
=> New_Reference_To
(
3845 RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
3847 end Build_Protected_Entry
;
3849 -----------------------------------------
3850 -- Build_Protected_Entry_Specification --
3851 -----------------------------------------
3853 function Build_Protected_Entry_Specification
3856 Ent_Id
: Entity_Id
) return Node_Id
3858 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
3861 Set_Debug_Info_Needed
(Def_Id
);
3863 if Present
(Ent_Id
) then
3864 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
3868 Make_Procedure_Specification
(Loc
,
3869 Defining_Unit_Name
=> Def_Id
,
3870 Parameter_Specifications
=> New_List
(
3871 Make_Parameter_Specification
(Loc
,
3872 Defining_Identifier
=>
3873 Make_Defining_Identifier
(Loc
, Name_uO
),
3875 New_Reference_To
(RTE
(RE_Address
), Loc
)),
3877 Make_Parameter_Specification
(Loc
,
3878 Defining_Identifier
=> P
,
3880 New_Reference_To
(RTE
(RE_Address
), Loc
)),
3882 Make_Parameter_Specification
(Loc
,
3883 Defining_Identifier
=>
3884 Make_Defining_Identifier
(Loc
, Name_uE
),
3886 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))));
3887 end Build_Protected_Entry_Specification
;
3889 --------------------------
3890 -- Build_Protected_Spec --
3891 --------------------------
3893 function Build_Protected_Spec
3895 Obj_Type
: Entity_Id
;
3897 Unprotected
: Boolean := False) return List_Id
3899 Loc
: constant Source_Ptr
:= Sloc
(N
);
3902 New_Plist
: List_Id
;
3903 New_Param
: Node_Id
;
3906 New_Plist
:= New_List
;
3908 Formal
:= First_Formal
(Ident
);
3909 while Present
(Formal
) loop
3911 Make_Parameter_Specification
(Loc
,
3912 Defining_Identifier
=>
3913 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
3914 In_Present
=> In_Present
(Parent
(Formal
)),
3915 Out_Present
=> Out_Present
(Parent
(Formal
)),
3916 Parameter_Type
=> New_Reference_To
(Etype
(Formal
), Loc
));
3919 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
3922 Append
(New_Param
, New_Plist
);
3923 Next_Formal
(Formal
);
3926 -- If the subprogram is a procedure and the context is not an access
3927 -- to protected subprogram, the parameter is in-out. Otherwise it is
3931 Make_Parameter_Specification
(Loc
,
3932 Defining_Identifier
=>
3933 Make_Defining_Identifier
(Loc
, Name_uObject
),
3936 (Etype
(Ident
) = Standard_Void_Type
3937 and then not Is_RTE
(Obj_Type
, RE_Address
)),
3939 New_Reference_To
(Obj_Type
, Loc
));
3940 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
3941 Prepend_To
(New_Plist
, Decl
);
3944 end Build_Protected_Spec
;
3946 ---------------------------------------
3947 -- Build_Protected_Sub_Specification --
3948 ---------------------------------------
3950 function Build_Protected_Sub_Specification
3952 Prot_Typ
: Entity_Id
;
3953 Mode
: Subprogram_Protection_Mode
) return Node_Id
3955 Loc
: constant Source_Ptr
:= Sloc
(N
);
3959 New_Plist
: List_Id
;
3962 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
3963 (Dispatching_Mode
=> ' ',
3964 Protected_Mode
=> 'P',
3965 Unprotected_Mode
=> 'N');
3968 if Ekind
(Defining_Unit_Name
(Specification
(N
))) =
3971 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
3976 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
3979 Build_Protected_Spec
3980 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
3981 Mode
= Unprotected_Mode
);
3983 Make_Defining_Identifier
(Loc
,
3984 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
3986 -- The unprotected operation carries the user code, and debugging
3987 -- information must be generated for it, even though this spec does
3988 -- not come from source. It is also convenient to allow gdb to step
3989 -- into the protected operation, even though it only contains lock/
3992 Set_Debug_Info_Needed
(New_Id
);
3994 -- If a pragma Eliminate applies to the source entity, the internal
3995 -- subprograms will be eliminated as well.
3997 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
3999 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
4001 Make_Procedure_Specification
(Loc
,
4002 Defining_Unit_Name
=> New_Id
,
4003 Parameter_Specifications
=> New_Plist
);
4005 -- Create a new specification for the anonymous subprogram type
4009 Make_Function_Specification
(Loc
,
4010 Defining_Unit_Name
=> New_Id
,
4011 Parameter_Specifications
=> New_Plist
,
4012 Result_Definition
=>
4013 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
4015 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
4019 end Build_Protected_Sub_Specification
;
4021 -------------------------------------
4022 -- Build_Protected_Subprogram_Body --
4023 -------------------------------------
4025 function Build_Protected_Subprogram_Body
4028 N_Op_Spec
: Node_Id
) return Node_Id
4030 Loc
: constant Source_Ptr
:= Sloc
(N
);
4032 P_Op_Spec
: Node_Id
;
4035 Unprot_Call
: Node_Id
;
4037 Lock_Name
: Node_Id
;
4038 Lock_Stmt
: Node_Id
;
4039 Service_Name
: Node_Id
;
4041 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
4042 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
4044 Object_Parm
: Node_Id
;
4049 Op_Spec
:= Specification
(N
);
4050 Exc_Safe
:= Is_Exception_Safe
(N
);
4053 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
4055 -- Build a list of the formal parameters of the protected version of
4056 -- the subprogram to use as the actual parameters of the unprotected
4059 Uactuals
:= New_List
;
4060 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
4061 while Present
(Pformal
) loop
4062 Append_To
(Uactuals
,
4063 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
4067 -- Make a call to the unprotected version of the subprogram built above
4068 -- for use by the protected version built below.
4070 if Nkind
(Op_Spec
) = N_Function_Specification
then
4072 R
:= Make_Temporary
(Loc
, 'R');
4074 Make_Object_Declaration
(Loc
,
4075 Defining_Identifier
=> R
,
4076 Constant_Present
=> True,
4077 Object_Definition
=> New_Copy
(Result_Definition
(N_Op_Spec
)),
4079 Make_Function_Call
(Loc
,
4080 Name
=> Make_Identifier
(Loc
,
4081 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4082 Parameter_Associations
=> Uactuals
));
4085 Make_Simple_Return_Statement
(Loc
,
4086 Expression
=> New_Reference_To
(R
, Loc
));
4089 Unprot_Call
:= Make_Simple_Return_Statement
(Loc
,
4090 Expression
=> Make_Function_Call
(Loc
,
4092 Make_Identifier
(Loc
,
4093 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4094 Parameter_Associations
=> Uactuals
));
4097 Lock_Kind
:= RE_Lock_Read_Only
;
4101 Make_Procedure_Call_Statement
(Loc
,
4103 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4104 Parameter_Associations
=> Uactuals
);
4106 Lock_Kind
:= RE_Lock
;
4109 -- Wrap call in block that will be covered by an at_end handler
4111 if not Exc_Safe
then
4112 Unprot_Call
:= Make_Block_Statement
(Loc
,
4113 Handled_Statement_Sequence
=>
4114 Make_Handled_Sequence_Of_Statements
(Loc
,
4115 Statements
=> New_List
(Unprot_Call
)));
4118 -- Make the protected subprogram body. This locks the protected
4119 -- object and calls the unprotected version of the subprogram.
4121 case Corresponding_Runtime_Package
(Pid
) is
4122 when System_Tasking_Protected_Objects_Entries
=>
4123 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock_Entries
), Loc
);
4124 Service_Name
:= New_Reference_To
(RTE
(RE_Service_Entries
), Loc
);
4126 when System_Tasking_Protected_Objects_Single_Entry
=>
4127 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock_Entry
), Loc
);
4128 Service_Name
:= New_Reference_To
(RTE
(RE_Service_Entry
), Loc
);
4130 when System_Tasking_Protected_Objects
=>
4131 Lock_Name
:= New_Reference_To
(RTE
(Lock_Kind
), Loc
);
4132 Service_Name
:= New_Reference_To
(RTE
(RE_Unlock
), Loc
);
4135 raise Program_Error
;
4139 Make_Attribute_Reference
(Loc
,
4141 Make_Selected_Component
(Loc
,
4142 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4143 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4144 Attribute_Name
=> Name_Unchecked_Access
);
4146 Lock_Stmt
:= Make_Procedure_Call_Statement
(Loc
,
4148 Parameter_Associations
=> New_List
(Object_Parm
));
4150 if Abort_Allowed
then
4152 Make_Procedure_Call_Statement
(Loc
,
4153 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
4154 Parameter_Associations
=> Empty_List
),
4158 Stmts
:= New_List
(Lock_Stmt
);
4161 if not Exc_Safe
then
4162 Append
(Unprot_Call
, Stmts
);
4164 if Nkind
(Op_Spec
) = N_Function_Specification
then
4166 Stmts
:= Empty_List
;
4168 Append
(Unprot_Call
, Stmts
);
4172 Make_Procedure_Call_Statement
(Loc
,
4173 Name
=> Service_Name
,
4174 Parameter_Associations
=>
4175 New_List
(New_Copy_Tree
(Object_Parm
))),
4178 if Abort_Allowed
then
4180 Make_Procedure_Call_Statement
(Loc
,
4181 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
4182 Parameter_Associations
=> Empty_List
),
4186 if Nkind
(Op_Spec
) = N_Function_Specification
then
4187 Append
(Return_Stmt
, Stmts
);
4188 Append
(Make_Block_Statement
(Loc
,
4189 Declarations
=> New_List
(Unprot_Call
),
4190 Handled_Statement_Sequence
=>
4191 Make_Handled_Sequence_Of_Statements
(Loc
,
4192 Statements
=> Stmts
)), Pre_Stmts
);
4198 Make_Subprogram_Body
(Loc
,
4199 Declarations
=> Empty_List
,
4200 Specification
=> P_Op_Spec
,
4201 Handled_Statement_Sequence
=>
4202 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4204 if not Exc_Safe
then
4205 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4209 end Build_Protected_Subprogram_Body
;
4211 -------------------------------------
4212 -- Build_Protected_Subprogram_Call --
4213 -------------------------------------
4215 procedure Build_Protected_Subprogram_Call
4219 External
: Boolean := True)
4221 Loc
: constant Source_Ptr
:= Sloc
(N
);
4222 Sub
: constant Entity_Id
:= Entity
(Name
);
4228 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4231 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4234 if Present
(Parameter_Associations
(N
)) then
4235 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4240 -- If the type is an untagged derived type, convert to the root type,
4241 -- which is the one on which the operations are defined.
4243 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4244 and then not Is_Tagged_Type
(Etype
(Rec
))
4245 and then Is_Derived_Type
(Etype
(Rec
))
4247 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4248 Set_Subtype_Mark
(Rec
,
4249 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4252 Prepend
(Rec
, Params
);
4254 if Ekind
(Sub
) = E_Procedure
then
4256 Make_Procedure_Call_Statement
(Loc
,
4258 Parameter_Associations
=> Params
));
4261 pragma Assert
(Ekind
(Sub
) = E_Function
);
4263 Make_Function_Call
(Loc
,
4265 Parameter_Associations
=> Params
));
4269 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
4270 and then Is_Entity_Name
(Expression
(Rec
))
4271 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
4273 Add_Shared_Var_Lock_Procs
(N
);
4275 end Build_Protected_Subprogram_Call
;
4277 -------------------------
4278 -- Build_Selected_Name --
4279 -------------------------
4281 function Build_Selected_Name
4282 (Prefix
: Entity_Id
;
4283 Selector
: Entity_Id
;
4284 Append_Char
: Character := ' ') return Name_Id
4286 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4287 Select_Len
: Natural;
4290 Get_Name_String
(Chars
(Selector
));
4291 Select_Len
:= Name_Len
;
4292 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4293 Get_Name_String
(Chars
(Prefix
));
4295 -- If scope is anonymous type, discard suffix to recover name of
4296 -- single protected object. Otherwise use protected type name.
4298 if Name_Buffer
(Name_Len
) = 'T' then
4299 Name_Len
:= Name_Len
- 1;
4302 Add_Str_To_Name_Buffer
("__");
4303 for J
in 1 .. Select_Len
loop
4304 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4307 -- Now add the Append_Char if specified. The encoding to follow
4308 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4309 -- then the entity is associated to a protected type subprogram.
4310 -- Otherwise, it is a protected type entry. For each case, the
4311 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4313 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4315 if Append_Char
/= ' ' then
4316 if Append_Char
= 'P' or Append_Char
= 'N' then
4317 Add_Char_To_Name_Buffer
(Append_Char
);
4320 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4321 return New_External_Name
(Name_Find
, ' ', -1);
4326 end Build_Selected_Name
;
4328 -----------------------------
4329 -- Build_Simple_Entry_Call --
4330 -----------------------------
4332 -- A task entry call is converted to a call to Call_Simple
4335 -- P : parms := (parm, parm, parm);
4337 -- Call_Simple (acceptor-task, entry-index, P'Address);
4343 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4344 -- the parameters, and the constructed aggregate value contains either the
4345 -- parameters or, in the case of non-elementary types, references to these
4346 -- parameters. Then the address of this aggregate is passed to the runtime
4347 -- routine, along with the task id value and the task entry index value.
4348 -- Pnn is only required if parameters are present.
4350 -- The assignments after the call are present only in the case of in-out
4351 -- or out parameters for elementary types, and are used to assign back the
4352 -- resulting values of such parameters.
4354 -- Note: the reason that we insert a block here is that in the context
4355 -- of selects, conditional entry calls etc. the entry call statement
4356 -- appears on its own, not as an element of a list.
4358 -- A protected entry call is converted to a Protected_Entry_Call:
4361 -- P : E1_Params := (param, param, param);
4363 -- Bnn : Communications_Block;
4366 -- P : E1_Params := (param, param, param);
4367 -- Bnn : Communications_Block;
4370 -- Protected_Entry_Call (
4371 -- Object => po._object'Access,
4372 -- E => <entry index>;
4373 -- Uninterpreted_Data => P'Address;
4374 -- Mode => Simple_Call;
4381 procedure Build_Simple_Entry_Call
4390 -- If call has been inlined, nothing left to do
4392 if Nkind
(N
) = N_Block_Statement
then
4396 -- Convert entry call to Call_Simple call
4399 Loc
: constant Source_Ptr
:= Sloc
(N
);
4400 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4401 Stats
: constant List_Id
:= New_List
;
4404 Comm_Name
: Entity_Id
;
4408 Ent_Acc
: Entity_Id
;
4410 Iface_Tag
: Entity_Id
;
4411 Iface_Typ
: Entity_Id
;
4424 -- Simple entry and entry family cases merge here
4426 Ent
:= Entity
(Ename
);
4427 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4428 Conctyp
:= Etype
(Concval
);
4430 -- If prefix is an access type, dereference to obtain the task type
4432 if Is_Access_Type
(Conctyp
) then
4433 Conctyp
:= Designated_Type
(Conctyp
);
4436 -- Special case for protected subprogram calls
4438 if Is_Protected_Type
(Conctyp
)
4439 and then Is_Subprogram
(Entity
(Ename
))
4441 if not Is_Eliminated
(Entity
(Ename
)) then
4442 Build_Protected_Subprogram_Call
4443 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4450 -- First parameter is the Task_Id value from the task value or the
4451 -- Object from the protected object value, obtained by selecting
4452 -- the _Task_Id or _Object from the result of doing an unchecked
4453 -- conversion to convert the value to the corresponding record type.
4455 if Nkind
(Concval
) = N_Function_Call
4456 and then Is_Task_Type
(Conctyp
)
4457 and then Ada_Version
>= Ada_2005
4460 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4461 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4466 Make_Object_Declaration
(Loc
,
4467 Defining_Identifier
=> Obj
,
4468 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4469 Expression
=> ExpR
);
4470 Set_Etype
(Obj
, Conctyp
);
4471 Decls
:= New_List
(Decl
);
4472 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4479 Parm1
:= Concurrent_Ref
(Concval
);
4481 -- Second parameter is the entry index, computed by the routine
4482 -- provided for this purpose. The value of this expression is
4483 -- assigned to an intermediate variable to assure that any entry
4484 -- family index expressions are evaluated before the entry
4488 or else Restriction_Active
(No_Entry_Queue
) = False
4489 or else not Is_Protected_Type
(Conctyp
)
4490 or else Number_Entries
(Conctyp
) > 1
4491 or else (Has_Attach_Handler
(Conctyp
)
4492 and then not Restricted_Profile
)
4494 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4497 Make_Object_Declaration
(Loc
,
4498 Defining_Identifier
=> X
,
4499 Object_Definition
=>
4500 New_Reference_To
(RTE
(RE_Task_Entry_Index
), Loc
),
4501 Expression
=> Actual_Index_Expression
(
4502 Loc
, Entity
(Ename
), Index
, Concval
));
4504 Append_To
(Decls
, Xdecl
);
4505 Parm2
:= New_Reference_To
(X
, Loc
);
4512 -- The third parameter is the packaged parameters. If there are
4513 -- none, then it is just the null address, since nothing is passed.
4516 Parm3
:= New_Reference_To
(RTE
(RE_Null_Address
), Loc
);
4519 -- Case of parameters present, where third argument is the address
4520 -- of a packaged record containing the required parameter values.
4523 -- First build a list of parameter values, which are references to
4524 -- objects of the parameter types.
4528 Actual
:= First_Actual
(N
);
4529 Formal
:= First_Formal
(Ent
);
4531 while Present
(Actual
) loop
4533 -- If it is a by_copy_type, copy it to a new variable. The
4534 -- packaged record has a field that points to this variable.
4536 if Is_By_Copy_Type
(Etype
(Actual
)) then
4538 Make_Object_Declaration
(Loc
,
4539 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4540 Aliased_Present
=> True,
4541 Object_Definition
=>
4542 New_Reference_To
(Etype
(Formal
), Loc
));
4544 -- Mark the object as not needing initialization since the
4545 -- initialization is performed separately, avoiding errors
4546 -- on cases such as formals of null-excluding access types.
4548 Set_No_Initialization
(N_Node
);
4550 -- We must make an assignment statement separate for the
4551 -- case of limited type. We cannot assign it unless the
4552 -- Assignment_OK flag is set first. An out formal of an
4553 -- access type must also be initialized from the actual,
4554 -- as stated in RM 6.4.1 (13).
4556 if Ekind
(Formal
) /= E_Out_Parameter
4557 or else Is_Access_Type
(Etype
(Formal
))
4560 New_Reference_To
(Defining_Identifier
(N_Node
), Loc
);
4561 Set_Assignment_OK
(N_Var
);
4563 Make_Assignment_Statement
(Loc
,
4565 Expression
=> Relocate_Node
(Actual
)));
4568 Append
(N_Node
, Decls
);
4571 Make_Attribute_Reference
(Loc
,
4572 Attribute_Name
=> Name_Unchecked_Access
,
4574 New_Reference_To
(Defining_Identifier
(N_Node
), Loc
)));
4576 -- If it is a VM_By_Copy_Actual, copy it to a new variable
4578 elsif Is_VM_By_Copy_Actual
(Actual
) then
4580 Make_Object_Declaration
(Loc
,
4581 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4582 Aliased_Present
=> True,
4583 Object_Definition
=>
4584 New_Reference_To
(Etype
(Formal
), Loc
),
4585 Expression
=> New_Copy_Tree
(Actual
));
4586 Set_Assignment_OK
(N_Node
);
4588 Append
(N_Node
, Decls
);
4591 Make_Attribute_Reference
(Loc
,
4592 Attribute_Name
=> Name_Unchecked_Access
,
4594 New_Reference_To
(Defining_Identifier
(N_Node
), Loc
)));
4597 -- Interface class-wide formal
4599 if Ada_Version
>= Ada_2005
4600 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4601 and then Is_Interface
(Etype
(Formal
))
4603 Iface_Typ
:= Etype
(Etype
(Formal
));
4606 -- formal_iface_type! (actual.iface_tag)'reference
4609 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4610 pragma Assert
(Present
(Iface_Tag
));
4613 Make_Reference
(Loc
,
4614 Unchecked_Convert_To
(Iface_Typ
,
4615 Make_Selected_Component
(Loc
,
4617 Relocate_Node
(Actual
),
4619 New_Reference_To
(Iface_Tag
, Loc
)))));
4625 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4629 Next_Actual
(Actual
);
4630 Next_Formal_With_Extras
(Formal
);
4633 -- Now build the declaration of parameters initialized with the
4634 -- aggregate containing this constructed parameter list.
4636 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4639 Make_Object_Declaration
(Loc
,
4640 Defining_Identifier
=> P
,
4641 Object_Definition
=>
4642 New_Reference_To
(Designated_Type
(Ent_Acc
), Loc
),
4644 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4647 Make_Attribute_Reference
(Loc
,
4648 Prefix
=> New_Reference_To
(P
, Loc
),
4649 Attribute_Name
=> Name_Address
);
4651 Append
(Pdecl
, Decls
);
4654 -- Now we can create the call, case of protected type
4656 if Is_Protected_Type
(Conctyp
) then
4657 case Corresponding_Runtime_Package
(Conctyp
) is
4658 when System_Tasking_Protected_Objects_Entries
=>
4660 -- Change the type of the index declaration
4662 Set_Object_Definition
(Xdecl
,
4663 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
));
4665 -- Some additional declarations for protected entry calls
4671 -- Bnn : Communications_Block;
4673 Comm_Name
:= Make_Temporary
(Loc
, 'B');
4676 Make_Object_Declaration
(Loc
,
4677 Defining_Identifier
=> Comm_Name
,
4678 Object_Definition
=>
4679 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
4681 -- Some additional statements for protected entry calls
4683 -- Protected_Entry_Call (
4684 -- Object => po._object'Access,
4685 -- E => <entry index>;
4686 -- Uninterpreted_Data => P'Address;
4687 -- Mode => Simple_Call;
4691 Make_Procedure_Call_Statement
(Loc
,
4693 New_Reference_To
(RTE
(RE_Protected_Entry_Call
), Loc
),
4695 Parameter_Associations
=> New_List
(
4696 Make_Attribute_Reference
(Loc
,
4697 Attribute_Name
=> Name_Unchecked_Access
,
4701 New_Reference_To
(RTE
(RE_Simple_Call
), Loc
),
4702 New_Occurrence_Of
(Comm_Name
, Loc
)));
4704 when System_Tasking_Protected_Objects_Single_Entry
=>
4705 -- Protected_Single_Entry_Call (
4706 -- Object => po._object'Access,
4707 -- Uninterpreted_Data => P'Address;
4708 -- Mode => Simple_Call);
4711 Make_Procedure_Call_Statement
(Loc
,
4712 Name
=> New_Reference_To
(
4713 RTE
(RE_Protected_Single_Entry_Call
), Loc
),
4715 Parameter_Associations
=> New_List
(
4716 Make_Attribute_Reference
(Loc
,
4717 Attribute_Name
=> Name_Unchecked_Access
,
4720 New_Reference_To
(RTE
(RE_Simple_Call
), Loc
)));
4723 raise Program_Error
;
4726 -- Case of task type
4730 Make_Procedure_Call_Statement
(Loc
,
4731 Name
=> New_Reference_To
(RTE
(RE_Call_Simple
), Loc
),
4732 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
4736 Append_To
(Stats
, Call
);
4738 -- If there are out or in/out parameters by copy add assignment
4739 -- statements for the result values.
4741 if Present
(Parms
) then
4742 Actual
:= First_Actual
(N
);
4743 Formal
:= First_Formal
(Ent
);
4745 Set_Assignment_OK
(Actual
);
4746 while Present
(Actual
) loop
4747 if (Is_By_Copy_Type
(Etype
(Actual
))
4748 or else Is_VM_By_Copy_Actual
(Actual
))
4749 and then Ekind
(Formal
) /= E_In_Parameter
4752 Make_Assignment_Statement
(Loc
,
4753 Name
=> New_Copy
(Actual
),
4755 Make_Explicit_Dereference
(Loc
,
4756 Make_Selected_Component
(Loc
,
4757 Prefix
=> New_Reference_To
(P
, Loc
),
4759 Make_Identifier
(Loc
, Chars
(Formal
)))));
4761 -- In all cases (including limited private types) we want
4762 -- the assignment to be valid.
4764 Set_Assignment_OK
(Name
(N_Node
));
4766 -- If the call is the triggering alternative in an
4767 -- asynchronous select, or the entry_call alternative of a
4768 -- conditional entry call, the assignments for in-out
4769 -- parameters are incorporated into the statement list that
4770 -- follows, so that there are executed only if the entry
4773 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
4774 and then N
= Triggering_Statement
(Parent
(N
)))
4776 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
4777 and then N
= Entry_Call_Statement
(Parent
(N
)))
4779 if No
(Statements
(Parent
(N
))) then
4780 Set_Statements
(Parent
(N
), New_List
);
4783 Prepend
(N_Node
, Statements
(Parent
(N
)));
4786 Insert_After
(Call
, N_Node
);
4790 Next_Actual
(Actual
);
4791 Next_Formal_With_Extras
(Formal
);
4795 -- Finally, create block and analyze it
4798 Make_Block_Statement
(Loc
,
4799 Declarations
=> Decls
,
4800 Handled_Statement_Sequence
=>
4801 Make_Handled_Sequence_Of_Statements
(Loc
,
4802 Statements
=> Stats
)));
4806 end Build_Simple_Entry_Call
;
4808 --------------------------------
4809 -- Build_Task_Activation_Call --
4810 --------------------------------
4812 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
4813 Loc
: constant Source_Ptr
:= Sloc
(N
);
4820 -- Get the activation chain entity. Except in the case of a package
4821 -- body, this is in the node that was passed. For a package body, we
4822 -- have to find the corresponding package declaration node.
4824 if Nkind
(N
) = N_Package_Body
then
4825 P
:= Corresponding_Spec
(N
);
4828 exit when Nkind
(P
) = N_Package_Declaration
;
4831 Chain
:= Activation_Chain_Entity
(P
);
4834 Chain
:= Activation_Chain_Entity
(N
);
4837 if Present
(Chain
) then
4838 if Restricted_Profile
then
4839 Name
:= New_Reference_To
(RTE
(RE_Activate_Restricted_Tasks
), Loc
);
4841 Name
:= New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
);
4845 Make_Procedure_Call_Statement
(Loc
,
4847 Parameter_Associations
=>
4848 New_List
(Make_Attribute_Reference
(Loc
,
4849 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
4850 Attribute_Name
=> Name_Unchecked_Access
)));
4852 if Nkind
(N
) = N_Package_Declaration
then
4853 if Present
(Corresponding_Body
(N
)) then
4856 elsif Present
(Private_Declarations
(Specification
(N
))) then
4857 Append
(Call
, Private_Declarations
(Specification
(N
)));
4860 Append
(Call
, Visible_Declarations
(Specification
(N
)));
4864 if Present
(Handled_Statement_Sequence
(N
)) then
4866 -- The call goes at the start of the statement sequence
4867 -- after the start of exception range label if one is present.
4873 Stm
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
4875 -- A special case, skip exception range label if one is
4876 -- present (from front end zcx processing).
4878 if Nkind
(Stm
) = N_Label
and then Exception_Junk
(Stm
) then
4882 -- Another special case, if the first statement is a block
4883 -- from optimization of a local raise to a goto, then the
4884 -- call goes inside this block.
4886 if Nkind
(Stm
) = N_Block_Statement
4887 and then Exception_Junk
(Stm
)
4890 First
(Statements
(Handled_Statement_Sequence
(Stm
)));
4893 -- Insertion point is after any exception label pushes,
4894 -- since we want it covered by any local handlers.
4896 while Nkind
(Stm
) in N_Push_xxx_Label
loop
4900 -- Now we have the proper insertion point
4902 Insert_Before
(Stm
, Call
);
4906 Set_Handled_Statement_Sequence
(N
,
4907 Make_Handled_Sequence_Of_Statements
(Loc
,
4908 Statements
=> New_List
(Call
)));
4913 Check_Task_Activation
(N
);
4915 end Build_Task_Activation_Call
;
4917 -------------------------------
4918 -- Build_Task_Allocate_Block --
4919 -------------------------------
4921 procedure Build_Task_Allocate_Block
4926 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4927 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
4928 Loc
: constant Source_Ptr
:= Sloc
(N
);
4929 Chain
: constant Entity_Id
:=
4930 Make_Defining_Identifier
(Loc
, Name_uChain
);
4931 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4936 Make_Block_Statement
(Loc
,
4937 Identifier
=> New_Reference_To
(Blkent
, Loc
),
4938 Declarations
=> New_List
(
4940 -- _Chain : Activation_Chain;
4942 Make_Object_Declaration
(Loc
,
4943 Defining_Identifier
=> Chain
,
4944 Aliased_Present
=> True,
4945 Object_Definition
=>
4946 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
))),
4948 Handled_Statement_Sequence
=>
4949 Make_Handled_Sequence_Of_Statements
(Loc
,
4951 Statements
=> New_List
(
4955 Make_Procedure_Call_Statement
(Loc
,
4956 Name
=> New_Reference_To
(Init
, Loc
),
4957 Parameter_Associations
=> Args
),
4959 -- Activate_Tasks (_Chain);
4961 Make_Procedure_Call_Statement
(Loc
,
4962 Name
=> New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
),
4963 Parameter_Associations
=> New_List
(
4964 Make_Attribute_Reference
(Loc
,
4965 Prefix
=> New_Reference_To
(Chain
, Loc
),
4966 Attribute_Name
=> Name_Unchecked_Access
))))),
4968 Has_Created_Identifier
=> True,
4969 Is_Task_Allocation_Block
=> True);
4972 Make_Implicit_Label_Declaration
(Loc
,
4973 Defining_Identifier
=> Blkent
,
4974 Label_Construct
=> Block
));
4976 Append_To
(Actions
, Block
);
4978 Set_Activation_Chain_Entity
(Block
, Chain
);
4979 end Build_Task_Allocate_Block
;
4981 -----------------------------------------------
4982 -- Build_Task_Allocate_Block_With_Init_Stmts --
4983 -----------------------------------------------
4985 procedure Build_Task_Allocate_Block_With_Init_Stmts
4988 Init_Stmts
: List_Id
)
4990 Loc
: constant Source_Ptr
:= Sloc
(N
);
4991 Chain
: constant Entity_Id
:=
4992 Make_Defining_Identifier
(Loc
, Name_uChain
);
4993 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4997 Append_To
(Init_Stmts
,
4998 Make_Procedure_Call_Statement
(Loc
,
4999 Name
=> New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
),
5000 Parameter_Associations
=> New_List
(
5001 Make_Attribute_Reference
(Loc
,
5002 Prefix
=> New_Reference_To
(Chain
, Loc
),
5003 Attribute_Name
=> Name_Unchecked_Access
))));
5006 Make_Block_Statement
(Loc
,
5007 Identifier
=> New_Reference_To
(Blkent
, Loc
),
5008 Declarations
=> New_List
(
5010 -- _Chain : Activation_Chain;
5012 Make_Object_Declaration
(Loc
,
5013 Defining_Identifier
=> Chain
,
5014 Aliased_Present
=> True,
5015 Object_Definition
=>
5016 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
))),
5018 Handled_Statement_Sequence
=>
5019 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5021 Has_Created_Identifier
=> True,
5022 Is_Task_Allocation_Block
=> True);
5025 Make_Implicit_Label_Declaration
(Loc
,
5026 Defining_Identifier
=> Blkent
,
5027 Label_Construct
=> Block
));
5029 Append_To
(Actions
, Block
);
5031 Set_Activation_Chain_Entity
(Block
, Chain
);
5032 end Build_Task_Allocate_Block_With_Init_Stmts
;
5034 -----------------------------------
5035 -- Build_Task_Proc_Specification --
5036 -----------------------------------
5038 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5039 Loc
: constant Source_Ptr
:= Sloc
(T
);
5040 Spec_Id
: Entity_Id
;
5043 -- Case of explicit task type, suffix TB
5045 if Comes_From_Source
(T
) then
5047 Make_Defining_Identifier
(Loc
,
5048 Chars
=> New_External_Name
(Chars
(T
), "TB"));
5050 -- Case of anonymous task type, suffix B
5054 Make_Defining_Identifier
(Loc
,
5055 Chars
=> New_External_Name
(Chars
(T
), 'B'));
5058 Set_Is_Internal
(Spec_Id
);
5060 -- Associate the procedure with the task, if this is the declaration
5061 -- (and not the body) of the procedure.
5063 if No
(Task_Body_Procedure
(T
)) then
5064 Set_Task_Body_Procedure
(T
, Spec_Id
);
5068 Make_Procedure_Specification
(Loc
,
5069 Defining_Unit_Name
=> Spec_Id
,
5070 Parameter_Specifications
=> New_List
(
5071 Make_Parameter_Specification
(Loc
,
5072 Defining_Identifier
=>
5073 Make_Defining_Identifier
(Loc
, Name_uTask
),
5075 Make_Access_Definition
(Loc
,
5077 New_Reference_To
(Corresponding_Record_Type
(T
), Loc
)))));
5078 end Build_Task_Proc_Specification
;
5080 ---------------------------------------
5081 -- Build_Unprotected_Subprogram_Body --
5082 ---------------------------------------
5084 function Build_Unprotected_Subprogram_Body
5086 Pid
: Node_Id
) return Node_Id
5088 Decls
: constant List_Id
:= Declarations
(N
);
5091 -- Add renamings for the Protection object, discriminals, privals and
5092 -- the entry index constant for use by debugger.
5094 Debug_Private_Data_Declarations
(Decls
);
5096 -- Make an unprotected version of the subprogram for use within the same
5097 -- object, with a new name and an additional parameter representing the
5101 Make_Subprogram_Body
(Sloc
(N
),
5103 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5104 Declarations
=> Decls
,
5105 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5106 end Build_Unprotected_Subprogram_Body
;
5108 ----------------------------
5109 -- Collect_Entry_Families --
5110 ----------------------------
5112 procedure Collect_Entry_Families
5115 Current_Node
: in out Node_Id
;
5116 Conctyp
: Entity_Id
)
5119 Efam_Decl
: Node_Id
;
5120 Efam_Type
: Entity_Id
;
5123 Efam
:= First_Entity
(Conctyp
);
5124 while Present
(Efam
) loop
5125 if Ekind
(Efam
) = E_Entry_Family
then
5126 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5131 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
5133 Bas_Decl
: Node_Id
:= Empty
;
5138 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
5140 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
5141 Bas
:= Make_Temporary
(Loc
, 'B');
5144 Make_Subtype_Declaration
(Loc
,
5145 Defining_Identifier
=> Bas
,
5146 Subtype_Indication
=>
5147 Make_Subtype_Indication
(Loc
,
5149 New_Occurrence_Of
(Standard_Integer
, Loc
),
5151 Make_Range_Constraint
(Loc
,
5152 Range_Expression
=> Make_Range
(Loc
,
5153 Make_Integer_Literal
5154 (Loc
, -Entry_Family_Bound
),
5155 Make_Integer_Literal
5156 (Loc
, Entry_Family_Bound
- 1)))));
5158 Insert_After
(Current_Node
, Bas_Decl
);
5159 Current_Node
:= Bas_Decl
;
5164 Make_Full_Type_Declaration
(Loc
,
5165 Defining_Identifier
=> Efam_Type
,
5167 Make_Unconstrained_Array_Definition
(Loc
,
5169 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
5171 Component_Definition
=>
5172 Make_Component_Definition
(Loc
,
5173 Aliased_Present
=> False,
5174 Subtype_Indication
=>
5175 New_Reference_To
(Standard_Character
, Loc
))));
5178 Insert_After
(Current_Node
, Efam_Decl
);
5179 Current_Node
:= Efam_Decl
;
5180 Analyze
(Efam_Decl
);
5183 Make_Component_Declaration
(Loc
,
5184 Defining_Identifier
=>
5185 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5187 Component_Definition
=>
5188 Make_Component_Definition
(Loc
,
5189 Aliased_Present
=> False,
5190 Subtype_Indication
=>
5191 Make_Subtype_Indication
(Loc
,
5193 New_Occurrence_Of
(Efam_Type
, Loc
),
5196 Make_Index_Or_Discriminant_Constraint
(Loc
,
5197 Constraints
=> New_List
(
5199 (Etype
(Discrete_Subtype_Definition
5200 (Parent
(Efam
))), Loc
)))))));
5206 end Collect_Entry_Families
;
5208 -----------------------
5209 -- Concurrent_Object --
5210 -----------------------
5212 function Concurrent_Object
5213 (Spec_Id
: Entity_Id
;
5214 Conc_Typ
: Entity_Id
) return Entity_Id
5217 -- Parameter _O or _object
5219 if Is_Protected_Type
(Conc_Typ
) then
5220 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5225 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5226 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5228 end Concurrent_Object
;
5230 ----------------------
5231 -- Copy_Result_Type --
5232 ----------------------
5234 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5235 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5240 -- If the result type is an access_to_subprogram, we must create new
5241 -- entities for its spec.
5243 if Nkind
(New_Res
) = N_Access_Definition
5244 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5246 -- Provide new entities for the formals
5248 Par_Spec
:= First
(Parameter_Specifications
5249 (Access_To_Subprogram_Definition
(New_Res
)));
5250 while Present
(Par_Spec
) loop
5251 Formal
:= Defining_Identifier
(Par_Spec
);
5252 Set_Defining_Identifier
(Par_Spec
,
5253 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5259 end Copy_Result_Type
;
5261 --------------------
5262 -- Concurrent_Ref --
5263 --------------------
5265 -- The expression returned for a reference to a concurrent object has the
5268 -- taskV!(name)._Task_Id
5272 -- objectV!(name)._Object
5274 -- for a protected object. For the case of an access to a concurrent
5275 -- object, there is an extra explicit dereference:
5277 -- taskV!(name.all)._Task_Id
5278 -- objectV!(name.all)._Object
5280 -- here taskV and objectV are the types for the associated records, which
5281 -- contain the required _Task_Id and _Object fields for tasks and protected
5282 -- objects, respectively.
5284 -- For the case of a task type name, the expression is
5288 -- i.e. a call to the Self function which returns precisely this Task_Id
5290 -- For the case of a protected type name, the expression is
5294 -- which is a renaming of the _object field of the current object
5295 -- record, passed into protected operations as a parameter.
5297 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5298 Loc
: constant Source_Ptr
:= Sloc
(N
);
5299 Ntyp
: constant Entity_Id
:= Etype
(N
);
5303 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5304 -- Check whether the reference is to the immediately enclosing task
5305 -- type, or to an outer one (rare but legal).
5307 ---------------------
5308 -- Is_Current_Task --
5309 ---------------------
5311 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5315 Scop
:= Current_Scope
;
5316 while Present
(Scop
)
5317 and then Scop
/= Standard_Standard
5323 elsif Is_Task_Type
(Scop
) then
5326 -- If this is a procedure nested within the task type, we must
5327 -- assume that it can be called from an inner task, and therefore
5328 -- cannot treat it as a local reference.
5330 elsif Is_Overloadable
(Scop
)
5331 and then In_Open_Scopes
(T
)
5336 Scop
:= Scope
(Scop
);
5340 -- We know that we are within the task body, so should have found it
5343 raise Program_Error
;
5344 end Is_Current_Task
;
5346 -- Start of processing for Concurrent_Ref
5349 if Is_Access_Type
(Ntyp
) then
5350 Dtyp
:= Designated_Type
(Ntyp
);
5352 if Is_Protected_Type
(Dtyp
) then
5353 Sel
:= Name_uObject
;
5355 Sel
:= Name_uTask_Id
;
5359 Make_Selected_Component
(Loc
,
5361 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5362 Make_Explicit_Dereference
(Loc
, N
)),
5363 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5365 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5366 if Is_Task_Type
(Entity
(N
)) then
5368 if Is_Current_Task
(Entity
(N
)) then
5370 Make_Function_Call
(Loc
,
5371 Name
=> New_Reference_To
(RTE
(RE_Self
), Loc
));
5376 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5377 T_Body
: constant Node_Id
:=
5378 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5382 Make_Object_Declaration
(Loc
,
5383 Defining_Identifier
=> T_Self
,
5384 Object_Definition
=>
5385 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5387 Make_Function_Call
(Loc
,
5388 Name
=> New_Reference_To
(RTE
(RE_Self
), Loc
)));
5389 Prepend
(Decl
, Declarations
(T_Body
));
5391 Set_Scope
(T_Self
, Entity
(N
));
5392 return New_Occurrence_Of
(T_Self
, Loc
);
5397 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5400 New_Reference_To
(Find_Protection_Object
(Current_Scope
), Loc
);
5404 if Is_Protected_Type
(Ntyp
) then
5405 Sel
:= Name_uObject
;
5407 elsif Is_Task_Type
(Ntyp
) then
5408 Sel
:= Name_uTask_Id
;
5411 raise Program_Error
;
5415 Make_Selected_Component
(Loc
,
5417 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5419 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5423 ------------------------
5424 -- Convert_Concurrent --
5425 ------------------------
5427 function Convert_Concurrent
5429 Typ
: Entity_Id
) return Node_Id
5432 if not Is_Concurrent_Type
(Typ
) then
5436 Unchecked_Convert_To
5437 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5439 end Convert_Concurrent
;
5441 -------------------------------------
5442 -- Debug_Private_Data_Declarations --
5443 -------------------------------------
5445 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5446 Debug_Nod
: Node_Id
;
5450 Decl
:= First
(Decls
);
5451 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5452 -- Declaration for concurrent entity _object and its access type,
5453 -- along with the entry index subtype:
5454 -- type prot_typVP is access prot_typV;
5455 -- _object : prot_typVP := prot_typV (_O);
5456 -- subtype Jnn is <Type of Index> range Low .. High;
5458 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
5459 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5461 -- Declaration for the Protection object, discriminals, privals and
5462 -- entry index constant:
5463 -- conc_typR : protection_typ renames _object._object;
5464 -- discr_nameD : discr_typ renames _object.discr_name;
5465 -- discr_nameD : discr_typ renames _task.discr_name;
5466 -- prival_name : comp_typ renames _object.comp_name;
5467 -- J : constant Jnn :=
5468 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5470 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5471 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5472 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5474 if Present
(Debug_Nod
) then
5475 Insert_After
(Decl
, Debug_Nod
);
5481 end Debug_Private_Data_Declarations
;
5483 ------------------------------
5484 -- Ensure_Statement_Present --
5485 ------------------------------
5487 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5491 if Opt
.Suppress_Control_Flow_Optimizations
5492 and then Is_Empty_List
(Statements
(Alt
))
5494 Stmt
:= Make_Null_Statement
(Loc
);
5496 -- Mark NULL statement as coming from source so that it is not
5497 -- eliminated by GIGI.
5499 -- Another covert channel! If this is a requirement, it must be
5500 -- documented in sinfo/einfo ???
5502 Set_Comes_From_Source
(Stmt
, True);
5504 Set_Statements
(Alt
, New_List
(Stmt
));
5506 end Ensure_Statement_Present
;
5508 ----------------------------
5509 -- Entry_Index_Expression --
5510 ----------------------------
5512 function Entry_Index_Expression
5516 Ttyp
: Entity_Id
) return Node_Id
5526 -- The queues of entries and entry families appear in textual order in
5527 -- the associated record. The entry index is computed as the sum of the
5528 -- number of queues for all entries that precede the designated one, to
5529 -- which is added the index expression, if this expression denotes a
5530 -- member of a family.
5532 -- The following is a place holder for the count of simple entries
5534 Num
:= Make_Integer_Literal
(Sloc
, 1);
5536 -- We construct an expression which is a series of addition operations.
5537 -- The first operand is the number of single entries that precede this
5538 -- one, the second operand is the index value relative to the start of
5539 -- the referenced family, and the remaining operands are the lengths of
5540 -- the entry families that precede this entry, i.e. the constructed
5543 -- number_simple_entries +
5544 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5545 -- family'length + ...
5547 -- where index-value is the given index value, and s is the index
5548 -- subtype (we have to use pos because the subtype might be an
5549 -- enumeration type preventing direct subtraction). Note that the task
5550 -- entry array is one-indexed.
5552 -- The upper bound of the entry family may be a discriminant, so we
5553 -- retrieve the lower bound explicitly to compute offset, rather than
5554 -- using the index subtype which may mention a discriminant.
5556 if Present
(Index
) then
5557 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
5566 Make_Attribute_Reference
(Sloc
,
5567 Attribute_Name
=> Name_Pos
,
5568 Prefix
=> New_Reference_To
(Base_Type
(S
), Sloc
),
5569 Expressions
=> New_List
(Relocate_Node
(Index
))),
5577 -- Now add lengths of preceding entries and entry families
5579 Prev
:= First_Entity
(Ttyp
);
5581 while Chars
(Prev
) /= Chars
(Ent
)
5582 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5583 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5585 if Ekind
(Prev
) = E_Entry
then
5586 Set_Intval
(Num
, Intval
(Num
) + 1);
5588 elsif Ekind
(Prev
) = E_Entry_Family
then
5590 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
5591 Lo
:= Type_Low_Bound
(S
);
5592 Hi
:= Type_High_Bound
(S
);
5597 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5599 -- Other components are anonymous types to be ignored
5609 end Entry_Index_Expression
;
5611 ---------------------------
5612 -- Establish_Task_Master --
5613 ---------------------------
5615 procedure Establish_Task_Master
(N
: Node_Id
) is
5619 if Restriction_Active
(No_Task_Hierarchy
) = False then
5620 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5622 -- The block may have no declarations, and nevertheless be a task
5623 -- master, if it contains a call that may return an object that
5626 if No
(Declarations
(N
)) then
5627 Set_Declarations
(N
, New_List
(Call
));
5629 Prepend_To
(Declarations
(N
), Call
);
5634 end Establish_Task_Master
;
5636 --------------------------------
5637 -- Expand_Accept_Declarations --
5638 --------------------------------
5640 -- Part of the expansion of an accept statement involves the creation of
5641 -- a declaration that can be referenced from the statement sequence of
5646 -- This declaration is inserted immediately before the accept statement
5647 -- and it is important that it be inserted before the statements of the
5648 -- statement sequence are analyzed. Thus it would be too late to create
5649 -- this declaration in the Expand_N_Accept_Statement routine, which is
5650 -- why there is a separate procedure to be called directly from Sem_Ch9.
5652 -- Ann is used to hold the address of the record containing the parameters
5653 -- (see Expand_N_Entry_Call for more details on how this record is built).
5654 -- References to the parameters do an unchecked conversion of this address
5655 -- to a pointer to the required record type, and then access the field that
5656 -- holds the value of the required parameter. The entity for the address
5657 -- variable is held as the top stack element (i.e. the last element) of the
5658 -- Accept_Address stack in the corresponding entry entity, and this element
5659 -- must be set in place before the statements are processed.
5661 -- The above description applies to the case of a stand alone accept
5662 -- statement, i.e. one not appearing as part of a select alternative.
5664 -- For the case of an accept that appears as part of a select alternative
5665 -- of a selective accept, we must still create the declaration right away,
5666 -- since Ann is needed immediately, but there is an important difference:
5668 -- The declaration is inserted before the selective accept, not before
5669 -- the accept statement (which is not part of a list anyway, and so would
5670 -- not accommodate inserted declarations)
5672 -- We only need one address variable for the entire selective accept. So
5673 -- the Ann declaration is created only for the first accept alternative,
5674 -- and subsequent accept alternatives reference the same Ann variable.
5676 -- We can distinguish the two cases by seeing whether the accept statement
5677 -- is part of a list. If not, then it must be in an accept alternative.
5679 -- To expand the requeue statement, a label is provided at the end of the
5680 -- accept statement or alternative of which it is a part, so that the
5681 -- statement can be skipped after the requeue is complete. This label is
5682 -- created here rather than during the expansion of the accept statement,
5683 -- because it will be needed by any requeue statements within the accept,
5684 -- which are expanded before the accept.
5686 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
5687 Loc
: constant Source_Ptr
:= Sloc
(N
);
5688 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5689 Ann
: Entity_Id
:= Empty
;
5696 if Full_Expander_Active
then
5698 -- If we have no handled statement sequence, we may need to build
5699 -- a dummy sequence consisting of a null statement. This can be
5700 -- skipped if the trivial accept optimization is permitted.
5702 if not Trivial_Accept_OK
5704 (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
5706 Set_Handled_Statement_Sequence
(N
,
5707 Make_Handled_Sequence_Of_Statements
(Loc
,
5708 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5711 -- Create and declare two labels to be placed at the end of the
5712 -- accept statement. The first label is used to allow requeues to
5713 -- skip the remainder of entry processing. The second label is used
5714 -- to skip the remainder of entry processing if the rendezvous
5715 -- completes in the middle of the accept body.
5717 if Present
(Handled_Statement_Sequence
(N
)) then
5722 Ent
:= Make_Temporary
(Loc
, 'L');
5723 Lab
:= Make_Label
(Loc
, New_Reference_To
(Ent
, Loc
));
5725 Make_Implicit_Label_Declaration
(Loc
,
5726 Defining_Identifier
=> Ent
,
5727 Label_Construct
=> Lab
);
5728 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5730 Ent
:= Make_Temporary
(Loc
, 'L');
5731 Lab
:= Make_Label
(Loc
, New_Reference_To
(Ent
, Loc
));
5733 Make_Implicit_Label_Declaration
(Loc
,
5734 Defining_Identifier
=> Ent
,
5735 Label_Construct
=> Lab
);
5736 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5744 -- Case of stand alone accept statement
5746 if Is_List_Member
(N
) then
5748 if Present
(Handled_Statement_Sequence
(N
)) then
5749 Ann
:= Make_Temporary
(Loc
, 'A');
5752 Make_Object_Declaration
(Loc
,
5753 Defining_Identifier
=> Ann
,
5754 Object_Definition
=>
5755 New_Reference_To
(RTE
(RE_Address
), Loc
));
5757 Insert_Before_And_Analyze
(N
, Adecl
);
5758 Insert_Before_And_Analyze
(N
, Ldecl
);
5759 Insert_Before_And_Analyze
(N
, Ldecl2
);
5762 -- Case of accept statement which is in an accept alternative
5766 Acc_Alt
: constant Node_Id
:= Parent
(N
);
5767 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
5771 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
5772 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
5774 -- ??? Consider a single label for select statements
5776 if Present
(Handled_Statement_Sequence
(N
)) then
5778 Statements
(Handled_Statement_Sequence
(N
)));
5782 Statements
(Handled_Statement_Sequence
(N
)));
5786 -- Find first accept alternative of the selective accept. A
5787 -- valid selective accept must have at least one accept in it.
5789 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
5791 while Nkind
(Alt
) /= N_Accept_Alternative
loop
5795 -- If we are the first accept statement, then we have to create
5796 -- the Ann variable, as for the stand alone case, except that
5797 -- it is inserted before the selective accept. Similarly, a
5798 -- label for requeue expansion must be declared.
5800 if N
= Accept_Statement
(Alt
) then
5801 Ann
:= Make_Temporary
(Loc
, 'A');
5803 Make_Object_Declaration
(Loc
,
5804 Defining_Identifier
=> Ann
,
5805 Object_Definition
=>
5806 New_Reference_To
(RTE
(RE_Address
), Loc
));
5808 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
5810 -- If we are not the first accept statement, then find the Ann
5811 -- variable allocated by the first accept and use it.
5815 Node
(Last_Elmt
(Accept_Address
5816 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
5821 -- Merge here with Ann either created or referenced, and Adecl
5822 -- pointing to the corresponding declaration. Remaining processing
5823 -- is the same for the two cases.
5825 if Present
(Ann
) then
5826 Append_Elmt
(Ann
, Accept_Address
(Ent
));
5827 Set_Debug_Info_Needed
(Ann
);
5830 -- Create renaming declarations for the entry formals. Each reference
5831 -- to a formal becomes a dereference of a component of the parameter
5832 -- block, whose address is held in Ann. These declarations are
5833 -- eventually inserted into the accept block, and analyzed there so
5834 -- that they have the proper scope for gdb and do not conflict with
5835 -- other declarations.
5837 if Present
(Parameter_Specifications
(N
))
5838 and then Present
(Handled_Statement_Sequence
(N
))
5845 Renamed_Formal
: Node_Id
;
5849 Formal
:= First_Formal
(Ent
);
5851 while Present
(Formal
) loop
5852 Comp
:= Entry_Component
(Formal
);
5853 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
5855 Set_Etype
(New_F
, Etype
(Formal
));
5856 Set_Scope
(New_F
, Ent
);
5858 -- Now we set debug info needed on New_F even though it does
5859 -- not come from source, so that the debugger will get the
5860 -- right information for these generated names.
5862 Set_Debug_Info_Needed
(New_F
);
5864 if Ekind
(Formal
) = E_In_Parameter
then
5865 Set_Ekind
(New_F
, E_Constant
);
5867 Set_Ekind
(New_F
, E_Variable
);
5868 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
5871 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
5874 Make_Selected_Component
(Loc
,
5876 Unchecked_Convert_To
(
5877 Entry_Parameters_Type
(Ent
),
5878 New_Reference_To
(Ann
, Loc
)),
5880 New_Reference_To
(Comp
, Loc
));
5883 Build_Renamed_Formal_Declaration
5884 (New_F
, Formal
, Comp
, Renamed_Formal
);
5886 if No
(Declarations
(N
)) then
5887 Set_Declarations
(N
, New_List
);
5890 Append
(Decl
, Declarations
(N
));
5891 Set_Renamed_Object
(Formal
, New_F
);
5892 Next_Formal
(Formal
);
5899 end Expand_Accept_Declarations
;
5901 ---------------------------------------------
5902 -- Expand_Access_Protected_Subprogram_Type --
5903 ---------------------------------------------
5905 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
5906 Loc
: constant Source_Ptr
:= Sloc
(N
);
5908 T
: constant Entity_Id
:= Defining_Identifier
(N
);
5909 D_T
: constant Entity_Id
:= Designated_Type
(T
);
5910 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
5911 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
5912 P_List
: constant List_Id
:= Build_Protected_Spec
5913 (N
, RTE
(RE_Address
), D_T
, False);
5919 -- Create access to subprogram with full signature
5921 if Etype
(D_T
) /= Standard_Void_Type
then
5923 Make_Access_Function_Definition
(Loc
,
5924 Parameter_Specifications
=> P_List
,
5925 Result_Definition
=>
5926 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
5930 Make_Access_Procedure_Definition
(Loc
,
5931 Parameter_Specifications
=> P_List
);
5935 Make_Full_Type_Declaration
(Loc
,
5936 Defining_Identifier
=> D_T2
,
5937 Type_Definition
=> Def1
);
5939 Insert_After_And_Analyze
(N
, Decl1
);
5941 -- Associate the access to subprogram with its original access to
5942 -- protected subprogram type. Needed by the backend to know that this
5943 -- type corresponds with an access to protected subprogram type.
5945 Set_Original_Access_Type
(D_T2
, T
);
5947 -- Create Equivalent_Type, a record with two components for an access to
5948 -- object and an access to subprogram.
5951 Make_Component_Declaration
(Loc
,
5952 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
5953 Component_Definition
=>
5954 Make_Component_Definition
(Loc
,
5955 Aliased_Present
=> False,
5956 Subtype_Indication
=>
5957 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
5959 Make_Component_Declaration
(Loc
,
5960 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5961 Component_Definition
=>
5962 Make_Component_Definition
(Loc
,
5963 Aliased_Present
=> False,
5964 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
5967 Make_Full_Type_Declaration
(Loc
,
5968 Defining_Identifier
=> E_T
,
5970 Make_Record_Definition
(Loc
,
5972 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
5974 Insert_After_And_Analyze
(Decl1
, Decl2
);
5975 Set_Equivalent_Type
(T
, E_T
);
5976 end Expand_Access_Protected_Subprogram_Type
;
5978 --------------------------
5979 -- Expand_Entry_Barrier --
5980 --------------------------
5982 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
5983 Cond
: constant Node_Id
:=
5984 Condition
(Entry_Body_Formal_Part
(N
));
5985 Prot
: constant Entity_Id
:= Scope
(Ent
);
5986 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
5989 Body_Decl
: Node_Id
;
5992 if No_Run_Time_Mode
then
5993 Error_Msg_CRT
("entry barrier", N
);
5997 -- The body of the entry barrier must be analyzed in the context of the
5998 -- protected object, but its scope is external to it, just as any other
5999 -- unprotected version of a protected operation. The specification has
6000 -- been produced when the protected type declaration was elaborated. We
6001 -- build the body, insert it in the enclosing scope, but analyze it in
6002 -- the current context. A more uniform approach would be to treat the
6003 -- barrier just as a protected function, and discard the protected
6004 -- version of it because it is never called.
6006 if Full_Expander_Active
then
6007 B_F
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6008 Func
:= Barrier_Function
(Ent
);
6009 Set_Corresponding_Spec
(B_F
, Func
);
6011 Body_Decl
:= Parent
(Corresponding_Body
(Spec_Decl
));
6013 if Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
6014 Body_Decl
:= Corresponding_Stub
(Parent
(Body_Decl
));
6017 Insert_Before_And_Analyze
(Body_Decl
, B_F
);
6019 Set_Discriminals
(Spec_Decl
);
6020 Set_Scope
(Func
, Scope
(Prot
));
6023 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6026 -- The Ravenscar profile restricts barriers to simple variables declared
6027 -- within the protected object. We also allow Boolean constants, since
6028 -- these appear in several published examples and are also allowed by
6029 -- the Aonix compiler.
6031 -- Note that after analysis variables in this context will be replaced
6032 -- by the corresponding prival, that is to say a renaming of a selected
6033 -- component of the form _Object.Var. If expansion is disabled, as
6034 -- within a generic, we check that the entity appears in the current
6037 if Is_Entity_Name
(Cond
) then
6039 -- A small optimization of useless renamings. If the scope of the
6040 -- entity of the condition is not the barrier function, then the
6041 -- condition does not reference any of the generated renamings
6042 -- within the function.
6044 if Full_Expander_Active
and then Scope
(Entity
(Cond
)) /= Func
then
6045 Set_Declarations
(B_F
, Empty_List
);
6048 if Entity
(Cond
) = Standard_False
6050 Entity
(Cond
) = Standard_True
6054 elsif not Expander_Active
6055 and then Scope
(Entity
(Cond
)) = Current_Scope
6059 -- Check for case of _object.all.field (note that the explicit
6060 -- dereference gets inserted by analyze/expand of _object.field)
6062 elsif Present
(Renamed_Object
(Entity
(Cond
)))
6064 Nkind
(Renamed_Object
(Entity
(Cond
))) = N_Selected_Component
6068 (Prefix
(Renamed_Object
(Entity
(Cond
))))) = Name_uObject
6074 -- It is not a boolean variable or literal, so check the restriction
6076 Check_Restriction
(Simple_Barriers
, Cond
);
6077 end Expand_Entry_Barrier
;
6079 ------------------------------
6080 -- Expand_N_Abort_Statement --
6081 ------------------------------
6083 -- Expand abort T1, T2, .. Tn; into:
6084 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6086 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6087 Loc
: constant Source_Ptr
:= Sloc
(N
);
6088 Tlist
: constant List_Id
:= Names
(N
);
6094 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6097 Tasknm
:= First
(Tlist
);
6099 while Present
(Tasknm
) loop
6102 -- A task interface class-wide type object is being aborted.
6103 -- Retrieve its _task_id by calling a dispatching routine.
6105 if Ada_Version
>= Ada_2005
6106 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6107 and then Is_Interface
(Etype
(Tasknm
))
6108 and then Is_Task_Interface
(Etype
(Tasknm
))
6110 Append_To
(Component_Associations
(Aggr
),
6111 Make_Component_Association
(Loc
,
6112 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6115 -- Task_Id (Tasknm._disp_get_task_id)
6117 Make_Unchecked_Type_Conversion
(Loc
,
6119 New_Reference_To
(RTE
(RO_ST_Task_Id
), Loc
),
6121 Make_Selected_Component
(Loc
,
6122 Prefix
=> New_Copy_Tree
(Tasknm
),
6124 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6127 Append_To
(Component_Associations
(Aggr
),
6128 Make_Component_Association
(Loc
,
6129 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6130 Expression
=> Concurrent_Ref
(Tasknm
)));
6137 Make_Procedure_Call_Statement
(Loc
,
6138 Name
=> New_Reference_To
(RTE
(RE_Abort_Tasks
), Loc
),
6139 Parameter_Associations
=> New_List
(
6140 Make_Qualified_Expression
(Loc
,
6141 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Task_List
), Loc
),
6142 Expression
=> Aggr
))));
6145 end Expand_N_Abort_Statement
;
6147 -------------------------------
6148 -- Expand_N_Accept_Statement --
6149 -------------------------------
6151 -- This procedure handles expansion of accept statements that stand
6152 -- alone, i.e. they are not part of an accept alternative. The expansion
6153 -- of accept statement in accept alternatives is handled by the routines
6154 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6155 -- following description applies only to stand alone accept statements.
6157 -- If there is no handled statement sequence, or only null statements,
6158 -- then this is called a trivial accept, and the expansion is:
6160 -- Accept_Trivial (entry-index)
6162 -- If there is a handled statement sequence, then the expansion is:
6169 -- Accept_Call (entry-index, Ann);
6170 -- Renaming_Declarations for formals
6171 -- <statement sequence from N_Accept_Statement node>
6172 -- Complete_Rendezvous;
6177 -- <exception handler from N_Accept_Statement node>
6178 -- Complete_Rendezvous;
6180 -- <exception handler from N_Accept_Statement node>
6181 -- Complete_Rendezvous;
6186 -- when all others =>
6187 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6190 -- The first three declarations were already inserted ahead of the accept
6191 -- statement by the Expand_Accept_Declarations procedure, which was called
6192 -- directly from the semantics during analysis of the accept statement,
6193 -- before analyzing its contained statements.
6195 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6196 -- from possible expansion activity (the original source of course does
6197 -- not have any declarations associated with the accept statement, since
6198 -- an accept statement has no declarative part). In particular, if the
6199 -- expander is active, the first such declaration is the declaration of
6200 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6202 -- The two blocks are merged into a single block if the inner block has
6203 -- no exception handlers, but otherwise two blocks are required, since
6204 -- exceptions might be raised in the exception handlers of the inner
6205 -- block, and Exceptional_Complete_Rendezvous must be called.
6207 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6208 Loc
: constant Source_Ptr
:= Sloc
(N
);
6209 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6210 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6211 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6212 Eent
: constant Entity_Id
:= Entity
(Ename
);
6213 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6214 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6215 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6221 -- If the accept statement is not part of a list, then its parent must
6222 -- be an accept alternative, and, as described above, we do not do any
6223 -- expansion for such accept statements at this level.
6225 if not Is_List_Member
(N
) then
6226 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6229 -- Trivial accept case (no statement sequence, or null statements).
6230 -- If the accept statement has declarations, then just insert them
6231 -- before the procedure call.
6233 elsif Trivial_Accept_OK
6234 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6236 -- Remove declarations for renamings, because the parameter block
6237 -- will not be assigned.
6244 D
:= First
(Declarations
(N
));
6246 while Present
(D
) loop
6248 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6256 if Present
(Declarations
(N
)) then
6257 Insert_Actions
(N
, Declarations
(N
));
6261 Make_Procedure_Call_Statement
(Loc
,
6262 Name
=> New_Reference_To
(RTE
(RE_Accept_Trivial
), Loc
),
6263 Parameter_Associations
=> New_List
(
6264 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6268 -- Discard Entry_Address that was created for it, so it will not be
6269 -- emitted if this accept statement is in the statement part of a
6270 -- delay alternative.
6272 if Present
(Stats
) then
6273 Remove_Last_Elmt
(Acstack
);
6276 -- Case of statement sequence present
6279 -- Construct the block, using the declarations from the accept
6280 -- statement if any to initialize the declarations of the block.
6282 Blkent
:= Make_Temporary
(Loc
, 'A');
6283 Set_Ekind
(Blkent
, E_Block
);
6284 Set_Etype
(Blkent
, Standard_Void_Type
);
6285 Set_Scope
(Blkent
, Current_Scope
);
6288 Make_Block_Statement
(Loc
,
6289 Identifier
=> New_Reference_To
(Blkent
, Loc
),
6290 Declarations
=> Declarations
(N
),
6291 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6293 -- For the analysis of the generated declarations, the parent node
6294 -- must be properly set.
6296 Set_Parent
(Block
, Parent
(N
));
6298 -- Prepend call to Accept_Call to main statement sequence If the
6299 -- accept has exception handlers, the statement sequence is wrapped
6300 -- in a block. Insert call and renaming declarations in the
6301 -- declarations of the block, so they are elaborated before the
6305 Make_Procedure_Call_Statement
(Loc
,
6306 Name
=> New_Reference_To
(RTE
(RE_Accept_Call
), Loc
),
6307 Parameter_Associations
=> New_List
(
6308 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6309 New_Reference_To
(Ann
, Loc
)));
6311 if Parent
(Stats
) = N
then
6312 Prepend
(Call
, Statements
(Stats
));
6314 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6319 Push_Scope
(Blkent
);
6327 D
:= First
(Declarations
(N
));
6328 while Present
(D
) loop
6331 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6333 -- The renaming declarations for the formals were created
6334 -- during analysis of the accept statement, and attached to
6335 -- the list of declarations. Place them now in the context
6336 -- of the accept block or subprogram.
6339 Typ
:= Entity
(Subtype_Mark
(D
));
6340 Insert_After
(Call
, D
);
6343 -- If the formal is class_wide, it does not have an actual
6344 -- subtype. The analysis of the renaming declaration creates
6345 -- one, but we need to retain the class-wide nature of the
6348 if Is_Class_Wide_Type
(Typ
) then
6349 Set_Etype
(Defining_Identifier
(D
), Typ
);
6360 -- Replace the accept statement by the new block
6365 -- Last step is to unstack the Accept_Address value
6367 Remove_Last_Elmt
(Acstack
);
6369 end Expand_N_Accept_Statement
;
6371 ----------------------------------
6372 -- Expand_N_Asynchronous_Select --
6373 ----------------------------------
6375 -- This procedure assumes that the trigger statement is an entry call or
6376 -- a dispatching procedure call. A delay alternative should already have
6377 -- been expanded into an entry call to the appropriate delay object Wait
6380 -- If the trigger is a task entry call, the select is implemented with
6381 -- a Task_Entry_Call:
6386 -- P : parms := (parm, parm, parm);
6388 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6390 -- procedure _clean is
6393 -- Cancel_Task_Entry_Call (C);
6400 -- (<acceptor-task>, -- Acceptor
6401 -- <entry-index>, -- E
6402 -- P'Address, -- Uninterpreted_Data
6403 -- Asynchronous_Call, -- Mode
6404 -- B); -- Rendezvous_Successful
6411 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6414 -- when Abort_Signal => Abort_Undefer;
6421 -- <triggered-statements>
6425 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6426 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6430 -- P : parms := (parm, parm, parm);
6432 -- Call_Simple (acceptor-task, entry-index, P'Address);
6438 -- so the task at hand is to convert the latter expansion into the former
6440 -- If the trigger is a protected entry call, the select is implemented
6441 -- with Protected_Entry_Call:
6444 -- P : E1_Params := (param, param, param);
6445 -- Bnn : Communications_Block;
6450 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6452 -- procedure _clean is
6455 -- if Enqueued (Bnn) then
6456 -- Cancel_Protected_Entry_Call (Bnn);
6463 -- Protected_Entry_Call
6464 -- (po._object'Access, -- Object
6465 -- <entry index>, -- E
6466 -- P'Address, -- Uninterpreted_Data
6467 -- Asynchronous_Call, -- Mode
6470 -- if Enqueued (Bnn) then
6474 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6477 -- when Abort_Signal => Abort_Undefer;
6480 -- if not Cancelled (Bnn) then
6481 -- <triggered-statements>
6485 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6489 -- P : E1_Params := (param, param, param);
6490 -- Bnn : Communications_Block;
6493 -- Protected_Entry_Call
6494 -- (po._object'Access, -- Object
6495 -- <entry index>, -- E
6496 -- P'Address, -- Uninterpreted_Data
6497 -- Simple_Call, -- Mode
6504 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6508 -- B : Boolean := False;
6509 -- Bnn : Communication_Block;
6510 -- C : Ada.Tags.Prim_Op_Kind;
6511 -- D : System.Storage_Elements.Dummy_Communication_Block;
6512 -- K : Ada.Tags.Tagged_Kind :=
6513 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6514 -- P : Parameters := (Param1 .. ParamN);
6519 -- if K = Ada.Tags.TK_Limited_Tagged then
6520 -- <dispatching-call>;
6521 -- <triggering-statements>;
6525 -- Ada.Tags.Get_Offset_Index
6526 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6528 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6530 -- if C = POK_Protected_Entry then
6532 -- procedure _clean is
6534 -- if Enqueued (Bnn) then
6535 -- Cancel_Protected_Entry_Call (Bnn);
6541 -- _Disp_Asynchronous_Select
6542 -- (<object>, S, P'Address, D, B);
6543 -- Bnn := Communication_Block (D);
6545 -- Param1 := P.Param1;
6547 -- ParamN := P.ParamN;
6549 -- if Enqueued (Bnn) then
6550 -- <abortable-statements>
6553 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6556 -- when Abort_Signal => Abort_Undefer;
6559 -- if not Cancelled (Bnn) then
6560 -- <triggering-statements>
6563 -- elsif C = POK_Task_Entry then
6565 -- procedure _clean is
6567 -- Cancel_Task_Entry_Call (U);
6573 -- _Disp_Asynchronous_Select
6574 -- (<object>, S, P'Address, D, B);
6575 -- Bnn := Communication_Bloc (D);
6577 -- Param1 := P.Param1;
6579 -- ParamN := P.ParamN;
6584 -- <abortable-statements>
6586 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6589 -- when Abort_Signal => Abort_Undefer;
6593 -- <triggering-statements>
6598 -- <dispatching-call>;
6599 -- <triggering-statements>
6604 -- The job is to convert this to the asynchronous form
6606 -- If the trigger is a delay statement, it will have been expanded into a
6607 -- call to one of the GNARL delay procedures. This routine will convert
6608 -- this into a protected entry call on a delay object and then continue
6609 -- processing as for a protected entry call trigger. This requires
6610 -- declaring a Delay_Block object and adding a pointer to this object to
6611 -- the parameter list of the delay procedure to form the parameter list of
6612 -- the entry call. This object is used by the runtime to queue the delay
6615 -- For a description of the use of P and the assignments after the call,
6616 -- see Expand_N_Entry_Call_Statement.
6618 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
6619 Loc
: constant Source_Ptr
:= Sloc
(N
);
6620 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
6621 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
6623 Abort_Block_Ent
: Entity_Id
;
6624 Abortable_Block
: Node_Id
;
6627 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6628 Blk_Typ
: Entity_Id
;
6630 Call_Ent
: Entity_Id
;
6631 Cancel_Param
: Entity_Id
;
6632 Cleanup_Block
: Node_Id
;
6633 Cleanup_Block_Ent
: Entity_Id
;
6634 Cleanup_Stmts
: List_Id
;
6635 Conc_Typ_Stmts
: List_Id
;
6637 Dblock_Ent
: Entity_Id
;
6642 Enqueue_Call
: Node_Id
;
6645 Handler_Stmt
: Node_Id
;
6647 Lim_Typ_Stmts
: List_Id
;
6653 ProtE_Stmts
: List_Id
;
6654 ProtP_Stmts
: List_Id
;
6657 TaskE_Stmts
: List_Id
;
6660 B
: Entity_Id
; -- Call status flag
6661 Bnn
: Entity_Id
; -- Communication block
6662 C
: Entity_Id
; -- Call kind
6663 K
: Entity_Id
; -- Tagged kind
6664 P
: Entity_Id
; -- Parameter block
6665 S
: Entity_Id
; -- Primitive operation slot
6666 T
: Entity_Id
; -- Additional status flag
6669 Process_Statements_For_Controlled_Objects
(Trig
);
6670 Process_Statements_For_Controlled_Objects
(Abrt
);
6672 Ecall
:= Triggering_Statement
(Trig
);
6674 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
6676 -- Retrieve Astats and Tstats now because the finalization machinery may
6677 -- wrap them in blocks.
6679 Astats
:= Statements
(Abrt
);
6680 Tstats
:= Statements
(Trig
);
6682 -- The arguments in the call may require dynamic allocation, and the
6683 -- call statement may have been transformed into a block. The block
6684 -- may contain additional declarations for internal entities, and the
6685 -- original call is found by sequential search.
6687 if Nkind
(Ecall
) = N_Block_Statement
then
6688 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
6689 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
6690 N_Entry_Call_Statement
)
6696 -- This is either a dispatching call or a delay statement used as a
6697 -- trigger which was expanded into a procedure call.
6699 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
6700 if Ada_Version
>= Ada_2005
6702 (No
(Original_Node
(Ecall
))
6703 or else not Nkind_In
(Original_Node
(Ecall
),
6704 N_Delay_Relative_Statement
,
6705 N_Delay_Until_Statement
))
6707 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
6712 -- Call status flag processing, generate:
6713 -- B : Boolean := False;
6715 B
:= Build_B
(Loc
, Decls
);
6717 -- Communication block processing, generate:
6718 -- Bnn : Communication_Block;
6720 Bnn
:= Make_Temporary
(Loc
, 'B');
6722 Make_Object_Declaration
(Loc
,
6723 Defining_Identifier
=> Bnn
,
6724 Object_Definition
=>
6725 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
6727 -- Call kind processing, generate:
6728 -- C : Ada.Tags.Prim_Op_Kind;
6730 C
:= Build_C
(Loc
, Decls
);
6732 -- Tagged kind processing, generate:
6733 -- K : Ada.Tags.Tagged_Kind :=
6734 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6736 -- Dummy communication block, generate:
6737 -- D : Dummy_Communication_Block;
6740 Make_Object_Declaration
(Loc
,
6741 Defining_Identifier
=>
6742 Make_Defining_Identifier
(Loc
, Name_uD
),
6743 Object_Definition
=>
6745 RTE
(RE_Dummy_Communication_Block
), Loc
)));
6747 K
:= Build_K
(Loc
, Decls
, Obj
);
6749 -- Parameter block processing
6751 Blk_Typ
:= Build_Parameter_Block
6752 (Loc
, Actuals
, Formals
, Decls
);
6753 P
:= Parameter_Block_Pack
6754 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
6756 -- Dispatch table slot processing, generate:
6759 S
:= Build_S
(Loc
, Decls
);
6761 -- Additional status flag processing, generate:
6764 T
:= Make_Temporary
(Loc
, 'T');
6766 Make_Object_Declaration
(Loc
,
6767 Defining_Identifier
=> T
,
6768 Object_Definition
=>
6769 New_Reference_To
(Standard_Boolean
, Loc
)));
6771 ------------------------------
6772 -- Protected entry handling --
6773 ------------------------------
6776 -- Param1 := P.Param1;
6778 -- ParamN := P.ParamN;
6780 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
6783 -- Bnn := Communication_Block (D);
6785 Prepend_To
(Cleanup_Stmts
,
6786 Make_Assignment_Statement
(Loc
,
6788 New_Reference_To
(Bnn
, Loc
),
6790 Make_Unchecked_Type_Conversion
(Loc
,
6792 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
),
6793 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
6796 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
6798 Prepend_To
(Cleanup_Stmts
,
6799 Make_Procedure_Call_Statement
(Loc
,
6802 Find_Prim_Op
(Etype
(Etype
(Obj
)),
6803 Name_uDisp_Asynchronous_Select
),
6805 Parameter_Associations
=>
6807 New_Copy_Tree
(Obj
), -- <object>
6808 New_Reference_To
(S
, Loc
), -- S
6809 Make_Attribute_Reference
(Loc
, -- P'Address
6810 Prefix
=> New_Reference_To
(P
, Loc
),
6811 Attribute_Name
=> Name_Address
),
6812 Make_Identifier
(Loc
, Name_uD
), -- D
6813 New_Reference_To
(B
, Loc
)))); -- B
6816 -- if Enqueued (Bnn) then
6817 -- <abortable-statements>
6820 Append_To
(Cleanup_Stmts
,
6821 Make_Implicit_If_Statement
(N
,
6823 Make_Function_Call
(Loc
,
6825 New_Reference_To
(RTE
(RE_Enqueued
), Loc
),
6826 Parameter_Associations
=>
6827 New_List
(New_Reference_To
(Bnn
, Loc
))),
6830 New_Copy_List_Tree
(Astats
)));
6832 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
6833 -- will then generate a _clean for the communication block Bnn.
6837 -- procedure _clean is
6839 -- if Enqueued (Bnn) then
6840 -- Cancel_Protected_Entry_Call (Bnn);
6849 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
6851 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
6853 -- Wrap the cleanup block in an exception handling block
6859 -- when Abort_Signal => Abort_Undefer;
6862 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
6865 Make_Implicit_Label_Declaration
(Loc
,
6866 Defining_Identifier
=> Abort_Block_Ent
),
6869 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
6872 -- if not Cancelled (Bnn) then
6873 -- <triggering-statements>
6876 Append_To
(ProtE_Stmts
,
6877 Make_Implicit_If_Statement
(N
,
6881 Make_Function_Call
(Loc
,
6883 New_Reference_To
(RTE
(RE_Cancelled
), Loc
),
6884 Parameter_Associations
=>
6885 New_List
(New_Reference_To
(Bnn
, Loc
)))),
6888 New_Copy_List_Tree
(Tstats
)));
6890 -------------------------
6891 -- Task entry handling --
6892 -------------------------
6895 -- Param1 := P.Param1;
6897 -- ParamN := P.ParamN;
6899 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
6902 -- Bnn := Communication_Block (D);
6904 Append_To
(TaskE_Stmts
,
6905 Make_Assignment_Statement
(Loc
,
6907 New_Reference_To
(Bnn
, Loc
),
6909 Make_Unchecked_Type_Conversion
(Loc
,
6911 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
),
6912 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
6915 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
6917 Prepend_To
(TaskE_Stmts
,
6918 Make_Procedure_Call_Statement
(Loc
,
6921 Find_Prim_Op
(Etype
(Etype
(Obj
)),
6922 Name_uDisp_Asynchronous_Select
),
6925 Parameter_Associations
=>
6927 New_Copy_Tree
(Obj
), -- <object>
6928 New_Reference_To
(S
, Loc
), -- S
6929 Make_Attribute_Reference
(Loc
, -- P'Address
6930 Prefix
=> New_Reference_To
(P
, Loc
),
6931 Attribute_Name
=> Name_Address
),
6932 Make_Identifier
(Loc
, Name_uD
), -- D
6933 New_Reference_To
(B
, Loc
)))); -- B
6938 Prepend_To
(TaskE_Stmts
,
6939 Make_Procedure_Call_Statement
(Loc
,
6940 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
6941 Parameter_Associations
=> No_List
));
6945 -- <abortable-statements>
6947 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
6949 Prepend_To
(Cleanup_Stmts
,
6950 Make_Procedure_Call_Statement
(Loc
,
6951 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
6952 Parameter_Associations
=> No_List
));
6954 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
6955 -- will generate a _clean for the additional status flag.
6959 -- procedure _clean is
6961 -- Cancel_Task_Entry_Call (U);
6969 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
6971 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
6973 -- Wrap the cleanup block in an exception handling block
6979 -- when Abort_Signal => Abort_Undefer;
6982 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
6984 Append_To
(TaskE_Stmts
,
6985 Make_Implicit_Label_Declaration
(Loc
,
6986 Defining_Identifier
=> Abort_Block_Ent
));
6988 Append_To
(TaskE_Stmts
,
6990 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
6994 -- <triggering-statements>
6997 Append_To
(TaskE_Stmts
,
6998 Make_Implicit_If_Statement
(N
,
7000 Make_Op_Not
(Loc
, Right_Opnd
=> New_Reference_To
(T
, Loc
)),
7003 New_Copy_List_Tree
(Tstats
)));
7005 ----------------------------------
7006 -- Protected procedure handling --
7007 ----------------------------------
7010 -- <dispatching-call>;
7011 -- <triggering-statements>
7013 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7014 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7017 -- S := Ada.Tags.Get_Offset_Index
7018 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7021 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7024 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7026 Append_To
(Conc_Typ_Stmts
,
7027 Make_Procedure_Call_Statement
(Loc
,
7030 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7031 Name_uDisp_Get_Prim_Op_Kind
),
7033 Parameter_Associations
=>
7035 New_Copy_Tree
(Obj
),
7036 New_Reference_To
(S
, Loc
),
7037 New_Reference_To
(C
, Loc
))));
7040 -- if C = POK_Procedure_Entry then
7042 -- elsif C = POK_Task_Entry then
7048 Append_To
(Conc_Typ_Stmts
,
7049 Make_Implicit_If_Statement
(N
,
7053 New_Reference_To
(C
, Loc
),
7055 New_Reference_To
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7062 Make_Elsif_Part
(Loc
,
7066 New_Reference_To
(C
, Loc
),
7068 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
)),
7077 -- <dispatching-call>;
7078 -- <triggering-statements>
7080 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7081 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7084 -- if K = Ada.Tags.TK_Limited_Tagged then
7091 Make_Implicit_If_Statement
(N
,
7095 New_Reference_To
(K
, Loc
),
7097 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
7106 Make_Block_Statement
(Loc
,
7109 Handled_Statement_Sequence
=>
7110 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7115 -- Delay triggering statement processing
7118 -- Add a Delay_Block object to the parameter list of the delay
7119 -- procedure to form the parameter list of the Wait entry call.
7121 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7123 Pdef
:= Entity
(Name
(Ecall
));
7125 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7127 New_Reference_To
(RTE
(RE_Enqueue_Duration
), Loc
);
7129 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7131 New_Reference_To
(RTE
(RE_Enqueue_Calendar
), Loc
);
7133 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7134 Enqueue_Call
:= New_Reference_To
(RTE
(RE_Enqueue_RT
), Loc
);
7137 Append_To
(Parameter_Associations
(Ecall
),
7138 Make_Attribute_Reference
(Loc
,
7139 Prefix
=> New_Reference_To
(Dblock_Ent
, Loc
),
7140 Attribute_Name
=> Name_Unchecked_Access
));
7142 -- Create the inner block to protect the abortable part
7144 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7147 Make_Procedure_Call_Statement
(Loc
,
7148 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
7151 Make_Block_Statement
(Loc
,
7152 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
7153 Handled_Statement_Sequence
=>
7154 Make_Handled_Sequence_Of_Statements
(Loc
,
7155 Statements
=> Astats
),
7156 Has_Created_Identifier
=> True,
7157 Is_Asynchronous_Call_Block
=> True);
7159 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7162 Make_Implicit_If_Statement
(N
,
7164 Make_Function_Call
(Loc
,
7165 Name
=> Enqueue_Call
,
7166 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7168 New_List
(Make_Block_Statement
(Loc
,
7169 Handled_Statement_Sequence
=>
7170 Make_Handled_Sequence_Of_Statements
(Loc
,
7171 Statements
=> New_List
(
7172 Make_Implicit_Label_Declaration
(Loc
,
7173 Defining_Identifier
=> Blk_Ent
,
7174 Label_Construct
=> Abortable_Block
),
7176 Exception_Handlers
=> Hdle
)))));
7178 Stmts
:= New_List
(Ecall
);
7180 -- Construct statement sequence for new block
7183 Make_Implicit_If_Statement
(N
,
7185 Make_Function_Call
(Loc
,
7186 Name
=> New_Reference_To
(
7187 RTE
(RE_Timed_Out
), Loc
),
7188 Parameter_Associations
=> New_List
(
7189 Make_Attribute_Reference
(Loc
,
7190 Prefix
=> New_Reference_To
(Dblock_Ent
, Loc
),
7191 Attribute_Name
=> Name_Unchecked_Access
))),
7192 Then_Statements
=> Tstats
));
7194 -- The result is the new block
7196 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7199 Make_Block_Statement
(Loc
,
7200 Declarations
=> New_List
(
7201 Make_Object_Declaration
(Loc
,
7202 Defining_Identifier
=> Dblock_Ent
,
7203 Aliased_Present
=> True,
7204 Object_Definition
=> New_Reference_To
(
7205 RTE
(RE_Delay_Block
), Loc
))),
7207 Handled_Statement_Sequence
=>
7208 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7218 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7219 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7221 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7222 Decls
:= Declarations
(Ecall
);
7224 if Is_Protected_Type
(Etype
(Concval
)) then
7226 -- Get the declarations of the block expanded from the entry call
7228 Decl
:= First
(Decls
);
7229 while Present
(Decl
)
7231 (Nkind
(Decl
) /= N_Object_Declaration
7232 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7233 RE_Communication_Block
))
7238 pragma Assert
(Present
(Decl
));
7239 Cancel_Param
:= Defining_Identifier
(Decl
);
7241 -- Change the mode of the Protected_Entry_Call call
7243 -- Protected_Entry_Call (
7244 -- Object => po._object'Access,
7245 -- E => <entry index>;
7246 -- Uninterpreted_Data => P'Address;
7247 -- Mode => Asynchronous_Call;
7250 Stmt
:= First
(Stmts
);
7252 -- Skip assignments to temporaries created for in-out parameters
7254 -- This makes unwarranted assumptions about the shape of the expanded
7255 -- tree for the call, and should be cleaned up ???
7257 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7263 Param
:= First
(Parameter_Associations
(Call
));
7264 while Present
(Param
)
7265 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7270 pragma Assert
(Present
(Param
));
7271 Rewrite
(Param
, New_Reference_To
(RTE
(RE_Asynchronous_Call
), Loc
));
7274 -- Append an if statement to execute the abortable part
7277 -- if Enqueued (Bnn) then
7280 Make_Implicit_If_Statement
(N
,
7282 Make_Function_Call
(Loc
,
7283 Name
=> New_Reference_To
(RTE
(RE_Enqueued
), Loc
),
7284 Parameter_Associations
=> New_List
(
7285 New_Reference_To
(Cancel_Param
, Loc
))),
7286 Then_Statements
=> Astats
));
7289 Make_Block_Statement
(Loc
,
7290 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
7291 Handled_Statement_Sequence
=>
7292 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7293 Has_Created_Identifier
=> True,
7294 Is_Asynchronous_Call_Block
=> True);
7296 -- For the VM call Update_Exception instead of Abort_Undefer.
7297 -- See 4jexcept.ads for an explanation.
7299 if VM_Target
= No_VM
then
7300 if Exception_Mechanism
= Back_End_Exceptions
then
7302 -- Aborts are not deferred at beginning of exception handlers
7305 Handler_Stmt
:= Make_Null_Statement
(Loc
);
7308 Handler_Stmt
:= Make_Procedure_Call_Statement
(Loc
,
7309 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
7310 Parameter_Associations
=> No_List
);
7313 Handler_Stmt
:= Make_Procedure_Call_Statement
(Loc
,
7314 Name
=> New_Reference_To
(RTE
(RE_Update_Exception
), Loc
),
7315 Parameter_Associations
=> New_List
(
7316 Make_Function_Call
(Loc
,
7317 Name
=> New_Occurrence_Of
7318 (RTE
(RE_Current_Target_Exception
), Loc
))));
7322 Make_Block_Statement
(Loc
,
7323 Handled_Statement_Sequence
=>
7324 Make_Handled_Sequence_Of_Statements
(Loc
,
7325 Statements
=> New_List
(
7326 Make_Implicit_Label_Declaration
(Loc
,
7327 Defining_Identifier
=> Blk_Ent
,
7328 Label_Construct
=> Abortable_Block
),
7333 Exception_Handlers
=> New_List
(
7334 Make_Implicit_Exception_Handler
(Loc
,
7336 -- when Abort_Signal =>
7337 -- Abort_Undefer.all;
7339 Exception_Choices
=>
7340 New_List
(New_Reference_To
(Stand
.Abort_Signal
, Loc
)),
7341 Statements
=> New_List
(Handler_Stmt
))))),
7343 -- if not Cancelled (Bnn) then
7344 -- triggered statements
7347 Make_Implicit_If_Statement
(N
,
7348 Condition
=> Make_Op_Not
(Loc
,
7350 Make_Function_Call
(Loc
,
7351 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7352 Parameter_Associations
=> New_List
(
7353 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7354 Then_Statements
=> Tstats
));
7356 -- Asynchronous task entry call
7363 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7365 -- Insert declaration of B in declarations of existing block
7368 Make_Object_Declaration
(Loc
,
7369 Defining_Identifier
=> B
,
7370 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)));
7372 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7374 -- Insert declaration of C in declarations of existing block
7377 Make_Object_Declaration
(Loc
,
7378 Defining_Identifier
=> Cancel_Param
,
7379 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)));
7381 -- Remove and save the call to Call_Simple
7383 Stmt
:= First
(Stmts
);
7385 -- Skip assignments to temporaries created for in-out parameters.
7386 -- This makes unwarranted assumptions about the shape of the expanded
7387 -- tree for the call, and should be cleaned up ???
7389 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7395 -- Create the inner block to protect the abortable part
7397 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7400 Make_Procedure_Call_Statement
(Loc
,
7401 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
7404 Make_Block_Statement
(Loc
,
7405 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
7406 Handled_Statement_Sequence
=>
7407 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7408 Has_Created_Identifier
=> True,
7409 Is_Asynchronous_Call_Block
=> True);
7412 Make_Block_Statement
(Loc
,
7413 Handled_Statement_Sequence
=>
7414 Make_Handled_Sequence_Of_Statements
(Loc
,
7415 Statements
=> New_List
(
7416 Make_Implicit_Label_Declaration
(Loc
,
7417 Defining_Identifier
=> Blk_Ent
,
7418 Label_Construct
=> Abortable_Block
),
7420 Exception_Handlers
=> Hdle
)));
7422 -- Create new call statement
7424 Params
:= Parameter_Associations
(Call
);
7427 New_Reference_To
(RTE
(RE_Asynchronous_Call
), Loc
));
7428 Append_To
(Params
, New_Reference_To
(B
, Loc
));
7431 Make_Procedure_Call_Statement
(Loc
,
7432 Name
=> New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
7433 Parameter_Associations
=> Params
));
7435 -- Construct statement sequence for new block
7438 Make_Implicit_If_Statement
(N
,
7440 Make_Op_Not
(Loc
, New_Reference_To
(Cancel_Param
, Loc
)),
7441 Then_Statements
=> Tstats
));
7443 -- Protected the call against abort
7446 Make_Procedure_Call_Statement
(Loc
,
7447 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
7448 Parameter_Associations
=> Empty_List
));
7451 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7453 -- The result is the new block
7456 Make_Block_Statement
(Loc
,
7457 Declarations
=> Decls
,
7458 Handled_Statement_Sequence
=>
7459 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7462 end Expand_N_Asynchronous_Select
;
7464 -------------------------------------
7465 -- Expand_N_Conditional_Entry_Call --
7466 -------------------------------------
7468 -- The conditional task entry call is converted to a call to
7473 -- P : parms := (parm, parm, parm);
7477 -- (<acceptor-task>, -- Acceptor
7478 -- <entry-index>, -- E
7479 -- P'Address, -- Uninterpreted_Data
7480 -- Conditional_Call, -- Mode
7481 -- B); -- Rendezvous_Successful
7486 -- normal-statements
7492 -- For a description of the use of P and the assignments after the call,
7493 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7494 -- conditional entry call has already been expanded (by the Expand_N_Entry
7495 -- _Call_Statement procedure) as follows:
7498 -- P : parms := (parm, parm, parm);
7500 -- ... info for in-out parameters
7501 -- Call_Simple (acceptor-task, entry-index, P'Address);
7507 -- so the task at hand is to convert the latter expansion into the former
7509 -- The conditional protected entry call is converted to a call to
7510 -- Protected_Entry_Call:
7513 -- P : parms := (parm, parm, parm);
7514 -- Bnn : Communications_Block;
7517 -- Protected_Entry_Call
7518 -- (po._object'Access, -- Object
7519 -- <entry index>, -- E
7520 -- P'Address, -- Uninterpreted_Data
7521 -- Conditional_Call, -- Mode
7526 -- if Cancelled (Bnn) then
7529 -- normal-statements
7533 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7537 -- B : Boolean := False;
7538 -- C : Ada.Tags.Prim_Op_Kind;
7539 -- K : Ada.Tags.Tagged_Kind :=
7540 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7541 -- P : Parameters := (Param1 .. ParamN);
7545 -- if K = Ada.Tags.TK_Limited_Tagged then
7546 -- <dispatching-call>;
7547 -- <triggering-statements>
7551 -- Ada.Tags.Get_Offset_Index
7552 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7554 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7556 -- if C = POK_Protected_Entry
7557 -- or else C = POK_Task_Entry
7559 -- Param1 := P.Param1;
7561 -- ParamN := P.ParamN;
7565 -- if C = POK_Procedure
7566 -- or else C = POK_Protected_Procedure
7567 -- or else C = POK_Task_Procedure
7569 -- <dispatching-call>;
7572 -- <triggering-statements>
7574 -- <else-statements>
7579 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
7580 Loc
: constant Source_Ptr
:= Sloc
(N
);
7581 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
7582 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
7585 Blk_Typ
: Entity_Id
;
7587 Call_Ent
: Entity_Id
;
7588 Conc_Typ_Stmts
: List_Id
;
7592 Lim_Typ_Stmts
: List_Id
;
7599 Transient_Blk
: Node_Id
;
7602 B
: Entity_Id
; -- Call status flag
7603 C
: Entity_Id
; -- Call kind
7604 K
: Entity_Id
; -- Tagged kind
7605 P
: Entity_Id
; -- Parameter block
7606 S
: Entity_Id
; -- Primitive operation slot
7609 Process_Statements_For_Controlled_Objects
(N
);
7611 if Ada_Version
>= Ada_2005
7612 and then Nkind
(Blk
) = N_Procedure_Call_Statement
7614 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
7619 -- Call status flag processing, generate:
7620 -- B : Boolean := False;
7622 B
:= Build_B
(Loc
, Decls
);
7624 -- Call kind processing, generate:
7625 -- C : Ada.Tags.Prim_Op_Kind;
7627 C
:= Build_C
(Loc
, Decls
);
7629 -- Tagged kind processing, generate:
7630 -- K : Ada.Tags.Tagged_Kind :=
7631 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7633 K
:= Build_K
(Loc
, Decls
, Obj
);
7635 -- Parameter block processing
7637 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
7638 P
:= Parameter_Block_Pack
7639 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7641 -- Dispatch table slot processing, generate:
7644 S
:= Build_S
(Loc
, Decls
);
7647 -- S := Ada.Tags.Get_Offset_Index
7648 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7651 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7654 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7656 Append_To
(Conc_Typ_Stmts
,
7657 Make_Procedure_Call_Statement
(Loc
,
7660 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7661 Name_uDisp_Conditional_Select
),
7663 Parameter_Associations
=>
7665 New_Copy_Tree
(Obj
), -- <object>
7666 New_Reference_To
(S
, Loc
), -- S
7667 Make_Attribute_Reference
(Loc
, -- P'Address
7668 Prefix
=> New_Reference_To
(P
, Loc
),
7669 Attribute_Name
=> Name_Address
),
7670 New_Reference_To
(C
, Loc
), -- C
7671 New_Reference_To
(B
, Loc
)))); -- B
7674 -- if C = POK_Protected_Entry
7675 -- or else C = POK_Task_Entry
7677 -- Param1 := P.Param1;
7679 -- ParamN := P.ParamN;
7682 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7684 -- Generate the if statement only when the packed parameters need
7685 -- explicit assignments to their corresponding actuals.
7687 if Present
(Unpack
) then
7688 Append_To
(Conc_Typ_Stmts
,
7689 Make_Implicit_If_Statement
(N
,
7695 New_Reference_To
(C
, Loc
),
7697 New_Reference_To
(RTE
(
7698 RE_POK_Protected_Entry
), Loc
)),
7703 New_Reference_To
(C
, Loc
),
7705 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
7707 Then_Statements
=> Unpack
));
7712 -- if C = POK_Procedure
7713 -- or else C = POK_Protected_Procedure
7714 -- or else C = POK_Task_Procedure
7716 -- <dispatching-call>
7718 -- <normal-statements>
7720 -- <else-statements>
7723 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
7725 Prepend_To
(N_Stats
,
7726 Make_Implicit_If_Statement
(N
,
7732 New_Reference_To
(C
, Loc
),
7734 New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
)),
7741 New_Reference_To
(C
, Loc
),
7743 New_Reference_To
(RTE
(
7744 RE_POK_Protected_Procedure
), Loc
)),
7749 New_Reference_To
(C
, Loc
),
7751 New_Reference_To
(RTE
(
7752 RE_POK_Task_Procedure
), Loc
)))),
7757 Append_To
(Conc_Typ_Stmts
,
7758 Make_Implicit_If_Statement
(N
,
7759 Condition
=> New_Reference_To
(B
, Loc
),
7760 Then_Statements
=> N_Stats
,
7761 Else_Statements
=> Else_Statements
(N
)));
7764 -- <dispatching-call>;
7765 -- <triggering-statements>
7767 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
7768 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
7771 -- if K = Ada.Tags.TK_Limited_Tagged then
7778 Make_Implicit_If_Statement
(N
,
7782 New_Reference_To
(K
, Loc
),
7784 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
7793 Make_Block_Statement
(Loc
,
7796 Handled_Statement_Sequence
=>
7797 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7799 -- As described above, the entry alternative is transformed into a
7800 -- block that contains the gnulli call, and possibly assignment
7801 -- statements for in-out parameters. The gnulli call may itself be
7802 -- rewritten into a transient block if some unconstrained parameters
7803 -- require it. We need to retrieve the call to complete its parameter
7808 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
7810 if Present
(Transient_Blk
)
7811 and then Nkind
(Transient_Blk
) = N_Block_Statement
7813 Blk
:= Transient_Blk
;
7816 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
7817 Stmt
:= First
(Stmts
);
7818 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7823 Params
:= Parameter_Associations
(Call
);
7825 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
7827 -- Substitute Conditional_Entry_Call for Simple_Call parameter
7829 Param
:= First
(Params
);
7830 while Present
(Param
)
7831 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7836 pragma Assert
(Present
(Param
));
7837 Rewrite
(Param
, New_Reference_To
(RTE
(RE_Conditional_Call
), Loc
));
7841 -- Find the Communication_Block parameter for the call to the
7842 -- Cancelled function.
7844 Decl
:= First
(Declarations
(Blk
));
7845 while Present
(Decl
)
7846 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7847 RE_Communication_Block
)
7852 -- Add an if statement to execute the else part if the call
7853 -- does not succeed (as indicated by the Cancelled predicate).
7856 Make_Implicit_If_Statement
(N
,
7857 Condition
=> Make_Function_Call
(Loc
,
7858 Name
=> New_Reference_To
(RTE
(RE_Cancelled
), Loc
),
7859 Parameter_Associations
=> New_List
(
7860 New_Reference_To
(Defining_Identifier
(Decl
), Loc
))),
7861 Then_Statements
=> Else_Statements
(N
),
7862 Else_Statements
=> Statements
(Alt
)));
7865 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7867 -- Insert declaration of B in declarations of existing block
7869 if No
(Declarations
(Blk
)) then
7870 Set_Declarations
(Blk
, New_List
);
7873 Prepend_To
(Declarations
(Blk
),
7874 Make_Object_Declaration
(Loc
,
7875 Defining_Identifier
=> B
,
7876 Object_Definition
=>
7877 New_Reference_To
(Standard_Boolean
, Loc
)));
7879 -- Create new call statement
7882 New_Reference_To
(RTE
(RE_Conditional_Call
), Loc
));
7883 Append_To
(Params
, New_Reference_To
(B
, Loc
));
7886 Make_Procedure_Call_Statement
(Loc
,
7887 Name
=> New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
7888 Parameter_Associations
=> Params
));
7890 -- Construct statement sequence for new block
7893 Make_Implicit_If_Statement
(N
,
7894 Condition
=> New_Reference_To
(B
, Loc
),
7895 Then_Statements
=> Statements
(Alt
),
7896 Else_Statements
=> Else_Statements
(N
)));
7899 -- The result is the new block
7902 Make_Block_Statement
(Loc
,
7903 Declarations
=> Declarations
(Blk
),
7904 Handled_Statement_Sequence
=>
7905 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7909 end Expand_N_Conditional_Entry_Call
;
7911 ---------------------------------------
7912 -- Expand_N_Delay_Relative_Statement --
7913 ---------------------------------------
7915 -- Delay statement is implemented as a procedure call to Delay_For
7916 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
7917 -- simple delays imposed by the use of Protected Objects.
7919 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
7920 Loc
: constant Source_Ptr
:= Sloc
(N
);
7923 Make_Procedure_Call_Statement
(Loc
,
7924 Name
=> New_Reference_To
(RTE
(RO_CA_Delay_For
), Loc
),
7925 Parameter_Associations
=> New_List
(Expression
(N
))));
7927 end Expand_N_Delay_Relative_Statement
;
7929 ------------------------------------
7930 -- Expand_N_Delay_Until_Statement --
7931 ------------------------------------
7933 -- Delay Until statement is implemented as a procedure call to
7934 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
7936 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
7937 Loc
: constant Source_Ptr
:= Sloc
(N
);
7941 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
7942 Typ
:= RTE
(RO_CA_Delay_Until
);
7944 Typ
:= RTE
(RO_RT_Delay_Until
);
7948 Make_Procedure_Call_Statement
(Loc
,
7949 Name
=> New_Reference_To
(Typ
, Loc
),
7950 Parameter_Associations
=> New_List
(Expression
(N
))));
7953 end Expand_N_Delay_Until_Statement
;
7955 -------------------------
7956 -- Expand_N_Entry_Body --
7957 -------------------------
7959 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
7961 -- Associate discriminals with the next protected operation body to be
7964 if Present
(Next_Protected_Operation
(N
)) then
7965 Set_Discriminals
(Parent
(Current_Scope
));
7967 end Expand_N_Entry_Body
;
7969 -----------------------------------
7970 -- Expand_N_Entry_Call_Statement --
7971 -----------------------------------
7973 -- An entry call is expanded into GNARLI calls to implement a simple entry
7974 -- call (see Build_Simple_Entry_Call).
7976 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
7982 if No_Run_Time_Mode
then
7983 Error_Msg_CRT
("entry call", N
);
7987 -- If this entry call is part of an asynchronous select, don't expand it
7988 -- here; it will be expanded with the select statement. Don't expand
7989 -- timed entry calls either, as they are translated into asynchronous
7992 -- ??? This whole approach is questionable; it may be better to go back
7993 -- to allowing the expansion to take place and then attempting to fix it
7994 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
7995 -- whether the expanded call is on a task or protected entry.
7997 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
7998 or else N
/= Triggering_Statement
(Parent
(N
)))
7999 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8000 or else N
/= Entry_Call_Statement
(Parent
(N
))
8001 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8003 Extract_Entry
(N
, Concval
, Ename
, Index
);
8004 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8006 end Expand_N_Entry_Call_Statement
;
8008 --------------------------------
8009 -- Expand_N_Entry_Declaration --
8010 --------------------------------
8012 -- If there are parameters, then first, each of the formals is marked by
8013 -- setting Is_Entry_Formal. Next a record type is built which is used to
8014 -- hold the parameter values. The name of this record type is entryP where
8015 -- entry is the name of the entry, with an additional corresponding access
8016 -- type called entryPA. The record type has matching components for each
8017 -- formal (the component names are the same as the formal names). For
8018 -- elementary types, the component type matches the formal type. For
8019 -- composite types, an access type is declared (with the name formalA)
8020 -- which designates the formal type, and the type of the component is this
8021 -- access type. Finally the Entry_Component of each formal is set to
8022 -- reference the corresponding record component.
8024 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8025 Loc
: constant Source_Ptr
:= Sloc
(N
);
8026 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8027 Components
: List_Id
;
8030 Last_Decl
: Node_Id
;
8031 Component
: Entity_Id
;
8034 Rec_Ent
: Entity_Id
;
8035 Acc_Ent
: Entity_Id
;
8038 Formal
:= First_Formal
(Entry_Ent
);
8041 -- Most processing is done only if parameters are present
8043 if Present
(Formal
) then
8044 Components
:= New_List
;
8046 -- Loop through formals
8048 while Present
(Formal
) loop
8049 Set_Is_Entry_Formal
(Formal
);
8051 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8052 Set_Entry_Component
(Formal
, Component
);
8053 Set_Entry_Formal
(Component
, Formal
);
8054 Ftype
:= Etype
(Formal
);
8056 -- Declare new access type and then append
8058 Ctype
:= Make_Temporary
(Loc
, 'A');
8061 Make_Full_Type_Declaration
(Loc
,
8062 Defining_Identifier
=> Ctype
,
8064 Make_Access_To_Object_Definition
(Loc
,
8065 All_Present
=> True,
8066 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8067 Subtype_Indication
=> New_Reference_To
(Ftype
, Loc
)));
8069 Insert_After
(Last_Decl
, Decl
);
8072 Append_To
(Components
,
8073 Make_Component_Declaration
(Loc
,
8074 Defining_Identifier
=> Component
,
8075 Component_Definition
=>
8076 Make_Component_Definition
(Loc
,
8077 Aliased_Present
=> False,
8078 Subtype_Indication
=> New_Reference_To
(Ctype
, Loc
))));
8080 Next_Formal_With_Extras
(Formal
);
8083 -- Create the Entry_Parameter_Record declaration
8085 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8088 Make_Full_Type_Declaration
(Loc
,
8089 Defining_Identifier
=> Rec_Ent
,
8091 Make_Record_Definition
(Loc
,
8093 Make_Component_List
(Loc
,
8094 Component_Items
=> Components
)));
8096 Insert_After
(Last_Decl
, Decl
);
8099 -- Construct and link in the corresponding access type
8101 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8103 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8106 Make_Full_Type_Declaration
(Loc
,
8107 Defining_Identifier
=> Acc_Ent
,
8109 Make_Access_To_Object_Definition
(Loc
,
8110 All_Present
=> True,
8111 Subtype_Indication
=> New_Reference_To
(Rec_Ent
, Loc
)));
8113 Insert_After
(Last_Decl
, Decl
);
8115 end Expand_N_Entry_Declaration
;
8117 -----------------------------
8118 -- Expand_N_Protected_Body --
8119 -----------------------------
8121 -- Protected bodies are expanded to the completion of the subprograms
8122 -- created for the corresponding protected type. These are a protected and
8123 -- unprotected version of each protected subprogram in the object, a
8124 -- function to calculate each entry barrier, and a procedure to execute the
8125 -- sequence of statements of each protected entry body. For example, for
8126 -- protected type ptype:
8129 -- (O : System.Address;
8130 -- E : Protected_Entry_Index)
8133 -- <discriminant renamings>
8134 -- <private object renamings>
8136 -- return <barrier expression>;
8139 -- procedure pprocN (_object : in out poV;...) is
8140 -- <discriminant renamings>
8141 -- <private object renamings>
8143 -- <sequence of statements>
8146 -- procedure pprocP (_object : in out poV;...) is
8147 -- procedure _clean is
8150 -- ptypeS (_object, Pn);
8151 -- Unlock (_object._object'Access);
8152 -- Abort_Undefer.all;
8157 -- Lock (_object._object'Access);
8158 -- pprocN (_object;...);
8163 -- function pfuncN (_object : poV;...) return Return_Type is
8164 -- <discriminant renamings>
8165 -- <private object renamings>
8167 -- <sequence of statements>
8170 -- function pfuncP (_object : poV) return Return_Type is
8171 -- procedure _clean is
8173 -- Unlock (_object._object'Access);
8174 -- Abort_Undefer.all;
8179 -- Lock (_object._object'Access);
8180 -- return pfuncN (_object);
8187 -- (O : System.Address;
8188 -- P : System.Address;
8189 -- E : Protected_Entry_Index)
8191 -- <discriminant renamings>
8192 -- <private object renamings>
8193 -- type poVP is access poV;
8194 -- _Object : ptVP := ptVP!(O);
8198 -- <statement sequence>
8199 -- Complete_Entry_Body (_Object._Object);
8201 -- when all others =>
8202 -- Exceptional_Complete_Entry_Body (
8203 -- _Object._Object, Get_GNAT_Exception);
8207 -- The type poV is the record created for the protected type to hold
8208 -- the state of the protected object.
8210 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8211 Loc
: constant Source_Ptr
:= Sloc
(N
);
8212 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8214 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8215 -- This flag indicates whether the lock free implementation is active
8217 Current_Node
: Node_Id
;
8218 Disp_Op_Body
: Node_Id
;
8219 New_Op_Body
: Node_Id
;
8220 Num_Entries
: Natural := 0;
8224 function Build_Dispatching_Subprogram_Body
8227 Prot_Bod
: Node_Id
) return Node_Id
;
8228 -- Build a dispatching version of the protected subprogram body. The
8229 -- newly generated subprogram contains a call to the original protected
8230 -- body. The following code is generated:
8232 -- function <protected-function-name> (Param1 .. ParamN) return
8235 -- return <protected-function-name>P (Param1 .. ParamN);
8236 -- end <protected-function-name>;
8240 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8242 -- <protected-procedure-name>P (Param1 .. ParamN);
8243 -- end <protected-procedure-name>
8245 ---------------------------------------
8246 -- Build_Dispatching_Subprogram_Body --
8247 ---------------------------------------
8249 function Build_Dispatching_Subprogram_Body
8252 Prot_Bod
: Node_Id
) return Node_Id
8254 Loc
: constant Source_Ptr
:= Sloc
(N
);
8261 -- Generate a specification without a letter suffix in order to
8262 -- override an interface function or procedure.
8264 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8266 -- The formal parameters become the actuals of the protected function
8267 -- or procedure call.
8269 Actuals
:= New_List
;
8270 Formal
:= First
(Parameter_Specifications
(Spec
));
8271 while Present
(Formal
) loop
8273 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8277 if Nkind
(Spec
) = N_Procedure_Specification
then
8280 Make_Procedure_Call_Statement
(Loc
,
8282 New_Reference_To
(Corresponding_Spec
(Prot_Bod
), Loc
),
8283 Parameter_Associations
=> Actuals
));
8286 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8290 Make_Simple_Return_Statement
(Loc
,
8292 Make_Function_Call
(Loc
,
8294 New_Reference_To
(Corresponding_Spec
(Prot_Bod
), Loc
),
8295 Parameter_Associations
=> Actuals
)));
8299 Make_Subprogram_Body
(Loc
,
8300 Declarations
=> Empty_List
,
8301 Specification
=> Spec
,
8302 Handled_Statement_Sequence
=>
8303 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8304 end Build_Dispatching_Subprogram_Body
;
8306 -- Start of processing for Expand_N_Protected_Body
8309 if No_Run_Time_Mode
then
8310 Error_Msg_CRT
("protected body", N
);
8314 -- This is the proper body corresponding to a stub. The declarations
8315 -- must be inserted at the point of the stub, which in turn is in the
8316 -- declarative part of the parent unit.
8318 if Nkind
(Parent
(N
)) = N_Subunit
then
8319 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8324 Op_Body
:= First
(Declarations
(N
));
8326 -- The protected body is replaced with the bodies of its
8327 -- protected operations, and the declarations for internal objects
8328 -- that may have been created for entry family bounds.
8330 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8333 while Present
(Op_Body
) loop
8334 case Nkind
(Op_Body
) is
8335 when N_Subprogram_Declaration
=>
8338 when N_Subprogram_Body
=>
8340 -- Do not create bodies for eliminated operations
8342 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8343 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8345 if Lock_Free_Active
then
8347 Build_Lock_Free_Unprotected_Subprogram_Body
8351 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8354 Insert_After
(Current_Node
, New_Op_Body
);
8355 Current_Node
:= New_Op_Body
;
8356 Analyze
(New_Op_Body
);
8358 -- Build the corresponding protected operation. It may
8359 -- appear that this is needed only if this is a visible
8360 -- operation of the type, or if it is an interrupt handler,
8361 -- and this was the strategy used previously in GNAT.
8363 -- However, the operation may be exported through a 'Access
8364 -- to an external caller. This is the common idiom in code
8365 -- that uses the Ada 2005 Timing_Events package. As a result
8366 -- we need to produce the protected body for both visible
8367 -- and private operations, as well as operations that only
8368 -- have a body in the source, and for which we create a
8369 -- declaration in the protected body itself.
8371 if Present
(Corresponding_Spec
(Op_Body
)) then
8372 if Lock_Free_Active
then
8374 Build_Lock_Free_Protected_Subprogram_Body
8375 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8378 Build_Protected_Subprogram_Body
8379 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8382 Insert_After
(Current_Node
, New_Op_Body
);
8383 Analyze
(New_Op_Body
);
8385 Current_Node
:= New_Op_Body
;
8387 -- Generate an overriding primitive operation body for
8388 -- this subprogram if the protected type implements an
8391 if Ada_Version
>= Ada_2005
8393 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
8396 Build_Dispatching_Subprogram_Body
8397 (Op_Body
, Pid
, New_Op_Body
);
8399 Insert_After
(Current_Node
, Disp_Op_Body
);
8400 Analyze
(Disp_Op_Body
);
8402 Current_Node
:= Disp_Op_Body
;
8407 when N_Entry_Body
=>
8408 Op_Id
:= Defining_Identifier
(Op_Body
);
8409 Num_Entries
:= Num_Entries
+ 1;
8411 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8413 Insert_After
(Current_Node
, New_Op_Body
);
8414 Current_Node
:= New_Op_Body
;
8415 Analyze
(New_Op_Body
);
8417 when N_Implicit_Label_Declaration
=>
8420 when N_Itype_Reference
=>
8421 Insert_After
(Current_Node
, New_Copy
(Op_Body
));
8423 when N_Freeze_Entity
=>
8424 New_Op_Body
:= New_Copy
(Op_Body
);
8426 if Present
(Entity
(Op_Body
))
8427 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8429 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8432 Insert_After
(Current_Node
, New_Op_Body
);
8433 Current_Node
:= New_Op_Body
;
8434 Analyze
(New_Op_Body
);
8437 New_Op_Body
:= New_Copy
(Op_Body
);
8438 Insert_After
(Current_Node
, New_Op_Body
);
8439 Current_Node
:= New_Op_Body
;
8440 Analyze
(New_Op_Body
);
8442 when N_Object_Declaration
=>
8443 pragma Assert
(not Comes_From_Source
(Op_Body
));
8444 New_Op_Body
:= New_Copy
(Op_Body
);
8445 Insert_After
(Current_Node
, New_Op_Body
);
8446 Current_Node
:= New_Op_Body
;
8447 Analyze
(New_Op_Body
);
8450 raise Program_Error
;
8457 -- Finally, create the body of the function that maps an entry index
8458 -- into the corresponding body index, except when there is no entry, or
8459 -- in a Ravenscar-like profile.
8461 if Corresponding_Runtime_Package
(Pid
) =
8462 System_Tasking_Protected_Objects_Entries
8464 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8465 Insert_After
(Current_Node
, New_Op_Body
);
8466 Current_Node
:= New_Op_Body
;
8467 Analyze
(New_Op_Body
);
8470 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8471 -- protected body. At this point all wrapper specs have been created,
8472 -- frozen and included in the dispatch table for the protected type.
8474 if Ada_Version
>= Ada_2005
then
8475 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8477 end Expand_N_Protected_Body
;
8479 -----------------------------------------
8480 -- Expand_N_Protected_Type_Declaration --
8481 -----------------------------------------
8483 -- First we create a corresponding record type declaration used to
8484 -- represent values of this protected type.
8485 -- The general form of this type declaration is
8487 -- type poV (discriminants) is record
8488 -- _Object : aliased <kind>Protection
8489 -- [(<entry count> [, <handler count>])];
8490 -- [entry_family : array (bounds) of Void;]
8491 -- <private data fields>
8494 -- The discriminants are present only if the corresponding protected type
8495 -- has discriminants, and they exactly mirror the protected type
8496 -- discriminants. The private data fields similarly mirror the private
8497 -- declarations of the protected type.
8499 -- The Object field is always present. It contains RTS specific data used
8500 -- to control the protected object. It is declared as Aliased so that it
8501 -- can be passed as a pointer to the RTS. This allows the protected record
8502 -- to be referenced within RTS data structures. An appropriate Protection
8503 -- type and discriminant are generated.
8505 -- The Service field is present for protected objects with entries. It
8506 -- contains sufficient information to allow the entry service procedure for
8507 -- this object to be called when the object is not known till runtime.
8509 -- One entry_family component is present for each entry family in the
8510 -- task definition (see Expand_N_Task_Type_Declaration).
8512 -- When a protected object is declared, an instance of the protected type
8513 -- value record is created. The elaboration of this declaration creates the
8514 -- correct bounds for the entry families, and also evaluates the priority
8515 -- expression if needed. The initialization routine for the protected type
8516 -- itself then calls Initialize_Protection with appropriate parameters to
8517 -- initialize the value of the Task_Id field. Install_Handlers may be also
8518 -- called if a pragma Attach_Handler applies.
8520 -- Note: this record is passed to the subprograms created by the expansion
8521 -- of protected subprograms and entries. It is an in parameter to protected
8522 -- functions and an in out parameter to procedures and entry bodies. The
8523 -- Entity_Id for this created record type is placed in the
8524 -- Corresponding_Record_Type field of the associated protected type entity.
8526 -- Next we create a procedure specifications for protected subprograms and
8527 -- entry bodies. For each protected subprograms two subprograms are
8528 -- created, an unprotected and a protected version. The unprotected version
8529 -- is called from within other operations of the same protected object.
8531 -- We also build the call to register the procedure if a pragma
8532 -- Interrupt_Handler applies.
8534 -- A single subprogram is created to service all entry bodies; it has an
8535 -- additional boolean out parameter indicating that the previous entry call
8536 -- made by the current task was serviced immediately, i.e. not by proxy.
8537 -- The O parameter contains a pointer to a record object of the type
8538 -- described above. An untyped interface is used here to allow this
8539 -- procedure to be called in places where the type of the object to be
8540 -- serviced is not known. This must be done, for example, when a call that
8541 -- may have been requeued is cancelled; the corresponding object must be
8542 -- serviced, but which object that is not known till runtime.
8545 -- (O : System.Address; P : out Boolean);
8546 -- procedure pprocN (_object : in out poV);
8547 -- procedure pproc (_object : in out poV);
8548 -- function pfuncN (_object : poV);
8549 -- function pfunc (_object : poV);
8552 -- Note that this must come after the record type declaration, since
8553 -- the specs refer to this type.
8555 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
8556 Loc
: constant Source_Ptr
:= Sloc
(N
);
8557 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
8559 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
8560 -- This flag indicates whether the lock free implementation is active
8562 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
8563 -- This contains two lists; one for visible and one for private decls
8567 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
8571 Comp_Id
: Entity_Id
;
8573 Current_Node
: Node_Id
:= N
;
8574 Bdef
: Entity_Id
:= Empty
; -- avoid uninit warning
8575 Edef
: Entity_Id
:= Empty
; -- avoid uninit warning
8576 Entries_Aggr
: Node_Id
;
8577 Body_Id
: Entity_Id
;
8580 Object_Comp
: Node_Id
;
8582 procedure Check_Inlining
(Subp
: Entity_Id
);
8583 -- If the original operation has a pragma Inline, propagate the flag
8584 -- to the internal body, for possible inlining later on. The source
8585 -- operation is invisible to the back-end and is never actually called.
8587 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
8588 -- When compiling under the Ravenscar profile, private components must
8589 -- have a static size, or else a protected object will require heap
8590 -- allocation, violating the corresponding restriction. It is preferable
8591 -- to make this check here, because it provides a better error message
8592 -- than the back-end, which refers to the object as a whole.
8594 procedure Register_Handler
;
8595 -- For a protected operation that is an interrupt handler, add the
8596 -- freeze action that will register it as such.
8598 --------------------
8599 -- Check_Inlining --
8600 --------------------
8602 procedure Check_Inlining
(Subp
: Entity_Id
) is
8604 if Is_Inlined
(Subp
) then
8605 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
8606 Set_Is_Inlined
(Subp
, False);
8610 ---------------------------------
8611 -- Check_Static_Component_Size --
8612 ---------------------------------
8614 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
8615 Typ
: constant Entity_Id
:= Etype
(Comp
);
8619 if Is_Scalar_Type
(Typ
) then
8622 elsif Is_Array_Type
(Typ
) then
8623 return Compile_Time_Known_Bounds
(Typ
);
8625 elsif Is_Record_Type
(Typ
) then
8626 C
:= First_Component
(Typ
);
8627 while Present
(C
) loop
8628 if not Static_Component_Size
(C
) then
8637 -- Any other type will be checked by the back-end
8642 end Static_Component_Size
;
8644 ----------------------
8645 -- Register_Handler --
8646 ----------------------
8648 procedure Register_Handler
is
8650 -- All semantic checks already done in Sem_Prag
8652 Prot_Proc
: constant Entity_Id
:=
8653 Defining_Unit_Name
(Specification
(Current_Node
));
8655 Proc_Address
: constant Node_Id
:=
8656 Make_Attribute_Reference
(Loc
,
8658 New_Reference_To
(Prot_Proc
, Loc
),
8659 Attribute_Name
=> Name_Address
);
8661 RTS_Call
: constant Entity_Id
:=
8662 Make_Procedure_Call_Statement
(Loc
,
8665 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
8666 Parameter_Associations
=> New_List
(Proc_Address
));
8668 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
8669 end Register_Handler
;
8671 -- Start of processing for Expand_N_Protected_Type_Declaration
8674 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
8677 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
8680 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
8682 Qualify_Entity_Names
(N
);
8684 -- If the type has discriminants, their occurrences in the declaration
8685 -- have been replaced by the corresponding discriminals. For components
8686 -- that are constrained by discriminants, their homologues in the
8687 -- corresponding record type must refer to the discriminants of that
8688 -- record, so we must apply a new renaming to subtypes_indications:
8690 -- protected discriminant => discriminal => record discriminant
8692 -- This replacement is not applied to default expressions, for which
8693 -- the discriminal is correct.
8695 if Has_Discriminants
(Prot_Typ
) then
8701 Disc
:= First_Discriminant
(Prot_Typ
);
8702 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
8703 while Present
(Disc
) loop
8704 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
8705 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
8706 Next_Discriminant
(Disc
);
8712 -- Fill in the component declarations
8714 -- Add components for entry families. For each entry family, create an
8715 -- anonymous type declaration with the same size, and analyze the type.
8717 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
8719 pragma Assert
(Present
(Pdef
));
8721 -- Add private field components
8723 if Present
(Private_Declarations
(Pdef
)) then
8724 Priv
:= First
(Private_Declarations
(Pdef
));
8726 while Present
(Priv
) loop
8728 if Nkind
(Priv
) = N_Component_Declaration
then
8729 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
8731 -- When compiling for a restricted profile, the private
8732 -- components must have a static size. If not, this is an
8733 -- error for a single protected declaration, and rates a
8734 -- warning on a protected type declaration.
8736 if not Comes_From_Source
(Prot_Typ
) then
8737 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
8739 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
8740 Error_Msg_N
("component has non-static size?", Priv
);
8742 ("\creation of protected object of type& will violate"
8743 & " restriction No_Implicit_Heap_Allocations?",
8748 -- The component definition consists of a subtype indication,
8749 -- or (in Ada 2005) an access definition. Make a copy of the
8750 -- proper definition.
8753 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
8754 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
8756 Nent
: constant Entity_Id
:=
8757 Make_Defining_Identifier
(Sloc
(Oent
),
8758 Chars
=> Chars
(Oent
));
8761 if Present
(Subtype_Indication
(Old_Comp
)) then
8763 Make_Component_Definition
(Sloc
(Oent
),
8764 Aliased_Present
=> False,
8765 Subtype_Indication
=>
8766 New_Copy_Tree
(Subtype_Indication
(Old_Comp
),
8770 Make_Component_Definition
(Sloc
(Oent
),
8771 Aliased_Present
=> False,
8772 Access_Definition
=>
8773 New_Copy_Tree
(Access_Definition
(Old_Comp
),
8778 Make_Component_Declaration
(Loc
,
8779 Defining_Identifier
=> Nent
,
8780 Component_Definition
=> New_Comp
,
8781 Expression
=> Expression
(Priv
));
8783 Set_Has_Per_Object_Constraint
(Nent
,
8784 Has_Per_Object_Constraint
(Oent
));
8786 Append_To
(Cdecls
, New_Priv
);
8789 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
8791 -- Make the unprotected version of the subprogram available
8792 -- for expansion of intra object calls. There is need for
8793 -- a protected version only if the subprogram is an interrupt
8794 -- handler, otherwise this operation can only be called from
8798 Make_Subprogram_Declaration
(Loc
,
8800 Build_Protected_Sub_Specification
8801 (Priv
, Prot_Typ
, Unprotected_Mode
));
8803 Insert_After
(Current_Node
, Sub
);
8806 Set_Protected_Body_Subprogram
8807 (Defining_Unit_Name
(Specification
(Priv
)),
8808 Defining_Unit_Name
(Specification
(Sub
)));
8809 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
8810 Current_Node
:= Sub
;
8813 Make_Subprogram_Declaration
(Loc
,
8815 Build_Protected_Sub_Specification
8816 (Priv
, Prot_Typ
, Protected_Mode
));
8818 Insert_After
(Current_Node
, Sub
);
8820 Current_Node
:= Sub
;
8822 if Is_Interrupt_Handler
8823 (Defining_Unit_Name
(Specification
(Priv
)))
8825 if not Restricted_Profile
then
8835 -- Except for the lock-free implementation, prepend the _Object field
8836 -- with the right type to the component list. We need to compute the
8837 -- number of entries, and in some cases the number of Attach_Handler
8840 if not Lock_Free_Active
then
8843 Num_Attach_Handler
: Int
:= 0;
8844 Protection_Subtype
: Node_Id
;
8845 Entry_Count_Expr
: constant Node_Id
:=
8846 Build_Entry_Count_Expression
8847 (Prot_Typ
, Cdecls
, Loc
);
8850 -- Could this be simplified using Corresponding_Runtime_Package???
8852 if Has_Attach_Handler
(Prot_Typ
) then
8853 Ritem
:= First_Rep_Item
(Prot_Typ
);
8854 while Present
(Ritem
) loop
8855 if Nkind
(Ritem
) = N_Pragma
8856 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
8858 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
8861 Next_Rep_Item
(Ritem
);
8864 if Restricted_Profile
then
8865 if Has_Entries
(Prot_Typ
) then
8866 Protection_Subtype
:=
8867 New_Reference_To
(RTE
(RE_Protection_Entry
), Loc
);
8869 Protection_Subtype
:=
8870 New_Reference_To
(RTE
(RE_Protection
), Loc
);
8874 Protection_Subtype
:=
8875 Make_Subtype_Indication
(Loc
,
8878 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
8880 Make_Index_Or_Discriminant_Constraint
(Loc
,
8881 Constraints
=> New_List
(
8883 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
8886 elsif Has_Interrupt_Handler
(Prot_Typ
)
8887 and then not Restriction_Active
(No_Dynamic_Attachment
)
8889 Protection_Subtype
:=
8890 Make_Subtype_Indication
(Loc
,
8893 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
8895 Make_Index_Or_Discriminant_Constraint
(Loc
,
8896 Constraints
=> New_List
(Entry_Count_Expr
)));
8898 -- Type has explicit entries or generated primitive entry wrappers
8900 elsif Has_Entries
(Prot_Typ
)
8901 or else (Ada_Version
>= Ada_2005
8902 and then Present
(Interface_List
(N
)))
8904 case Corresponding_Runtime_Package
(Prot_Typ
) is
8905 when System_Tasking_Protected_Objects_Entries
=>
8906 Protection_Subtype
:=
8907 Make_Subtype_Indication
(Loc
,
8910 (RTE
(RE_Protection_Entries
), Loc
),
8912 Make_Index_Or_Discriminant_Constraint
(Loc
,
8913 Constraints
=> New_List
(Entry_Count_Expr
)));
8915 when System_Tasking_Protected_Objects_Single_Entry
=>
8916 Protection_Subtype
:=
8917 New_Reference_To
(RTE
(RE_Protection_Entry
), Loc
);
8920 raise Program_Error
;
8924 Protection_Subtype
:=
8925 New_Reference_To
(RTE
(RE_Protection
), Loc
);
8929 Make_Component_Declaration
(Loc
,
8930 Defining_Identifier
=>
8931 Make_Defining_Identifier
(Loc
, Name_uObject
),
8932 Component_Definition
=>
8933 Make_Component_Definition
(Loc
,
8934 Aliased_Present
=> True,
8935 Subtype_Indication
=> Protection_Subtype
));
8938 -- Put the _Object component after the private component so that it
8939 -- be finalized early as required by 9.4 (20)
8941 Append_To
(Cdecls
, Object_Comp
);
8944 Insert_After
(Current_Node
, Rec_Decl
);
8945 Current_Node
:= Rec_Decl
;
8947 -- Analyze the record declaration immediately after construction,
8948 -- because the initialization procedure is needed for single object
8949 -- declarations before the next entity is analyzed (the freeze call
8950 -- that generates this initialization procedure is found below).
8952 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
8954 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
8955 -- the corresponding record is frozen. If any wrappers are generated,
8956 -- Current_Node is updated accordingly.
8958 if Ada_Version
>= Ada_2005
then
8959 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
8962 -- Collect pointers to entry bodies and their barriers, to be placed
8963 -- in the Entry_Bodies_Array for the type. For each entry/family we
8964 -- add an expression to the aggregate which is the initial value of
8965 -- this array. The array is declared after all protected subprograms.
8967 if Has_Entries
(Prot_Typ
) then
8968 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
8970 Entries_Aggr
:= Empty
;
8973 -- Build two new procedure specifications for each protected subprogram;
8974 -- one to call from outside the object and one to call from inside.
8975 -- Build a barrier function and an entry body action procedure
8976 -- specification for each protected entry. Initialize the entry body
8977 -- array. If subprogram is flagged as eliminated, do not generate any
8978 -- internal operations.
8981 Comp
:= First
(Visible_Declarations
(Pdef
));
8982 while Present
(Comp
) loop
8983 if Nkind
(Comp
) = N_Subprogram_Declaration
then
8985 Make_Subprogram_Declaration
(Loc
,
8987 Build_Protected_Sub_Specification
8988 (Comp
, Prot_Typ
, Unprotected_Mode
));
8990 Insert_After
(Current_Node
, Sub
);
8993 Set_Protected_Body_Subprogram
8994 (Defining_Unit_Name
(Specification
(Comp
)),
8995 Defining_Unit_Name
(Specification
(Sub
)));
8996 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
8998 -- Make the protected version of the subprogram available for
8999 -- expansion of external calls.
9001 Current_Node
:= Sub
;
9004 Make_Subprogram_Declaration
(Loc
,
9006 Build_Protected_Sub_Specification
9007 (Comp
, Prot_Typ
, Protected_Mode
));
9009 Insert_After
(Current_Node
, Sub
);
9012 Current_Node
:= Sub
;
9014 -- Generate an overriding primitive operation specification for
9015 -- this subprogram if the protected type implements an interface.
9017 if Ada_Version
>= Ada_2005
9019 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9022 Make_Subprogram_Declaration
(Loc
,
9024 Build_Protected_Sub_Specification
9025 (Comp
, Prot_Typ
, Dispatching_Mode
));
9027 Insert_After
(Current_Node
, Sub
);
9030 Current_Node
:= Sub
;
9033 -- If a pragma Interrupt_Handler applies, build and add a call to
9034 -- Register_Interrupt_Handler to the freezing actions of the
9035 -- protected version (Current_Node) of the subprogram:
9037 -- system.interrupts.register_interrupt_handler
9038 -- (prot_procP'address);
9040 if not Restricted_Profile
9041 and then Is_Interrupt_Handler
9042 (Defining_Unit_Name
(Specification
(Comp
)))
9047 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9048 E_Count
:= E_Count
+ 1;
9049 Comp_Id
:= Defining_Identifier
(Comp
);
9052 Make_Defining_Identifier
(Loc
,
9053 Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
9055 Make_Subprogram_Declaration
(Loc
,
9057 Build_Protected_Entry_Specification
(Loc
, Edef
, Comp_Id
));
9059 Insert_After
(Current_Node
, Sub
);
9062 -- Build wrapper procedure for pre/postconditions
9064 Build_PPC_Wrapper
(Comp_Id
, N
);
9066 Set_Protected_Body_Subprogram
9067 (Defining_Identifier
(Comp
),
9068 Defining_Unit_Name
(Specification
(Sub
)));
9070 Current_Node
:= Sub
;
9073 Make_Defining_Identifier
(Loc
,
9074 Chars
=> Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'B'));
9076 Make_Subprogram_Declaration
(Loc
,
9078 Build_Barrier_Function_Specification
(Loc
, Bdef
));
9080 Insert_After
(Current_Node
, Sub
);
9082 Set_Protected_Body_Subprogram
(Bdef
, Bdef
);
9083 Set_Barrier_Function
(Comp_Id
, Bdef
);
9084 Set_Scope
(Bdef
, Scope
(Comp_Id
));
9085 Current_Node
:= Sub
;
9087 -- Collect pointers to the protected subprogram and the barrier
9088 -- of the current entry, for insertion into Entry_Bodies_Array.
9090 Append_To
(Expressions
(Entries_Aggr
),
9091 Make_Aggregate
(Loc
,
9092 Expressions
=> New_List
(
9093 Make_Attribute_Reference
(Loc
,
9094 Prefix
=> New_Reference_To
(Bdef
, Loc
),
9095 Attribute_Name
=> Name_Unrestricted_Access
),
9096 Make_Attribute_Reference
(Loc
,
9097 Prefix
=> New_Reference_To
(Edef
, Loc
),
9098 Attribute_Name
=> Name_Unrestricted_Access
))));
9104 -- If there are some private entry declarations, expand it as if they
9105 -- were visible entries.
9107 if Present
(Private_Declarations
(Pdef
)) then
9108 Comp
:= First
(Private_Declarations
(Pdef
));
9109 while Present
(Comp
) loop
9110 if Nkind
(Comp
) = N_Entry_Declaration
then
9111 E_Count
:= E_Count
+ 1;
9112 Comp_Id
:= Defining_Identifier
(Comp
);
9115 Make_Defining_Identifier
(Loc
,
9116 Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
9118 Make_Subprogram_Declaration
(Loc
,
9120 Build_Protected_Entry_Specification
(Loc
, Edef
, Comp_Id
));
9122 Insert_After
(Current_Node
, Sub
);
9125 Set_Protected_Body_Subprogram
9126 (Defining_Identifier
(Comp
),
9127 Defining_Unit_Name
(Specification
(Sub
)));
9129 Current_Node
:= Sub
;
9132 Make_Defining_Identifier
(Loc
,
9133 Chars
=> Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
9136 Make_Subprogram_Declaration
(Loc
,
9138 Build_Barrier_Function_Specification
(Loc
, Bdef
));
9140 Insert_After
(Current_Node
, Sub
);
9142 Set_Protected_Body_Subprogram
(Bdef
, Bdef
);
9143 Set_Barrier_Function
(Comp_Id
, Bdef
);
9144 Set_Scope
(Bdef
, Scope
(Comp_Id
));
9145 Current_Node
:= Sub
;
9147 -- Collect pointers to the protected subprogram and the barrier
9148 -- of the current entry, for insertion into Entry_Bodies_Array.
9150 Append_To
(Expressions
(Entries_Aggr
),
9151 Make_Aggregate
(Loc
,
9152 Expressions
=> New_List
(
9153 Make_Attribute_Reference
(Loc
,
9154 Prefix
=> New_Reference_To
(Bdef
, Loc
),
9155 Attribute_Name
=> Name_Unrestricted_Access
),
9156 Make_Attribute_Reference
(Loc
,
9157 Prefix
=> New_Reference_To
(Edef
, Loc
),
9158 Attribute_Name
=> Name_Unrestricted_Access
))));
9165 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9166 -- all protected subprograms have been collected.
9168 if Has_Entries
(Prot_Typ
) then
9170 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9171 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9173 case Corresponding_Runtime_Package
(Prot_Typ
) is
9174 when System_Tasking_Protected_Objects_Entries
=>
9175 Body_Arr
:= Make_Object_Declaration
(Loc
,
9176 Defining_Identifier
=> Body_Id
,
9177 Aliased_Present
=> True,
9178 Object_Definition
=>
9179 Make_Subtype_Indication
(Loc
,
9180 Subtype_Mark
=> New_Reference_To
(
9181 RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9183 Make_Index_Or_Discriminant_Constraint
(Loc
,
9184 Constraints
=> New_List
(
9186 Make_Integer_Literal
(Loc
, 1),
9187 Make_Integer_Literal
(Loc
, E_Count
))))),
9188 Expression
=> Entries_Aggr
);
9190 when System_Tasking_Protected_Objects_Single_Entry
=>
9191 Body_Arr
:= Make_Object_Declaration
(Loc
,
9192 Defining_Identifier
=> Body_Id
,
9193 Aliased_Present
=> True,
9194 Object_Definition
=> New_Reference_To
9195 (RTE
(RE_Entry_Body
), Loc
),
9197 Make_Aggregate
(Loc
,
9198 Expressions
=> New_List
(
9199 Make_Attribute_Reference
(Loc
,
9200 Prefix
=> New_Reference_To
(Bdef
, Loc
),
9201 Attribute_Name
=> Name_Unrestricted_Access
),
9202 Make_Attribute_Reference
(Loc
,
9203 Prefix
=> New_Reference_To
(Edef
, Loc
),
9204 Attribute_Name
=> Name_Unrestricted_Access
))));
9207 raise Program_Error
;
9210 -- A pointer to this array will be placed in the corresponding record
9211 -- by its initialization procedure so this needs to be analyzed here.
9213 Insert_After
(Current_Node
, Body_Arr
);
9214 Current_Node
:= Body_Arr
;
9217 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9219 -- Finally, build the function that maps an entry index into the
9220 -- corresponding body. A pointer to this function is placed in each
9221 -- object of the type. Except for a ravenscar-like profile (no abort,
9222 -- no entry queue, 1 entry)
9224 if Corresponding_Runtime_Package
(Prot_Typ
) =
9225 System_Tasking_Protected_Objects_Entries
9228 Make_Subprogram_Declaration
(Loc
,
9229 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9230 Insert_After
(Current_Node
, Sub
);
9234 end Expand_N_Protected_Type_Declaration
;
9236 --------------------------------
9237 -- Expand_N_Requeue_Statement --
9238 --------------------------------
9240 -- A non-dispatching requeue statement is expanded into one of four GNARLI
9241 -- operations, depending on the source and destination (task or protected
9242 -- object). A dispatching requeue statement is expanded into a call to the
9243 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9244 -- jump around the remainder of processing for the original entry and, if
9245 -- the destination is (different) protected object, to attempt to service
9246 -- it. The following illustrates the various cases:
9249 -- (O : System.Address;
9250 -- P : System.Address;
9251 -- E : Protected_Entry_Index)
9253 -- <discriminant renamings>
9254 -- <private object renamings>
9255 -- type poVP is access poV;
9256 -- _object : ptVP := ptVP!(O);
9260 -- <start of statement sequence for entry>
9262 -- -- Requeue from one protected entry body to another protected
9265 -- Requeue_Protected_Entry (
9266 -- _object._object'Access,
9267 -- new._object'Access,
9272 -- <some more of the statement sequence for entry>
9274 -- -- Requeue from an entry body to a task entry
9276 -- Requeue_Protected_To_Task_Entry (
9282 -- <rest of statement sequence for entry>
9283 -- Complete_Entry_Body (_object._object);
9286 -- when all others =>
9287 -- Exceptional_Complete_Entry_Body (
9288 -- _object._object, Get_GNAT_Exception);
9292 -- Requeue of a task entry call to a task entry
9294 -- Accept_Call (E, Ann);
9295 -- <start of statement sequence for accept statement>
9296 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9298 -- <rest of statement sequence for accept statement>
9300 -- Complete_Rendezvous;
9303 -- when all others =>
9304 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9306 -- Requeue of a task entry call to a protected entry
9308 -- Accept_Call (E, Ann);
9309 -- <start of statement sequence for accept statement>
9310 -- Requeue_Task_To_Protected_Entry (
9311 -- new._object'Access,
9316 -- <rest of statement sequence for accept statement>
9318 -- Complete_Rendezvous;
9321 -- when all others =>
9322 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9324 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9325 -- marked by pragma Implemented (XXX, By_Entry).
9327 -- The requeue is inside a protected entry:
9330 -- (O : System.Address;
9331 -- P : System.Address;
9332 -- E : Protected_Entry_Index)
9334 -- <discriminant renamings>
9335 -- <private object renamings>
9336 -- type poVP is access poV;
9337 -- _object : ptVP := ptVP!(O);
9341 -- <start of statement sequence for entry>
9344 -- (<interface class-wide object>,
9347 -- Ada.Tags.Get_Offset_Index
9349 -- <interface dispatch table index of target entry>),
9353 -- <rest of statement sequence for entry>
9354 -- Complete_Entry_Body (_object._object);
9357 -- when all others =>
9358 -- Exceptional_Complete_Entry_Body (
9359 -- _object._object, Get_GNAT_Exception);
9363 -- The requeue is inside a task entry:
9365 -- Accept_Call (E, Ann);
9366 -- <start of statement sequence for accept statement>
9368 -- (<interface class-wide object>,
9371 -- Ada.Tags.Get_Offset_Index
9373 -- <interface dispatch table index of target entrt>),
9377 -- <rest of statement sequence for accept statement>
9379 -- Complete_Rendezvous;
9382 -- when all others =>
9383 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9385 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9386 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9387 -- statement is replaced by a dispatching call with actual parameters taken
9388 -- from the inner-most accept statement or entry body.
9390 -- Target.Primitive (Param1, ..., ParamN);
9392 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9393 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9397 -- S : constant Offset_Index :=
9398 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9399 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9402 -- if C = POK_Protected_Entry
9403 -- or else C = POK_Task_Entry
9405 -- <statements for dispatching requeue>
9407 -- elsif C = POK_Protected_Procedure then
9408 -- <dispatching call equivalent>
9411 -- raise Program_Error;
9415 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
9416 Loc
: constant Source_Ptr
:= Sloc
(N
);
9417 Conc_Typ
: Entity_Id
;
9421 Old_Typ
: Entity_Id
;
9423 function Build_Dispatching_Call_Equivalent
return Node_Id
;
9424 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9425 -- the form Concval.Ename. It is statically known that Ename is allowed
9426 -- to be implemented by a protected procedure. Create a dispatching call
9427 -- equivalent of Concval.Ename taking the actual parameters from the
9428 -- inner-most accept statement or entry body.
9430 function Build_Dispatching_Requeue
return Node_Id
;
9431 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9432 -- the form Concval.Ename. It is statically known that Ename is allowed
9433 -- to be implemented by a protected or a task entry. Create a call to
9434 -- primitive _Disp_Requeue which handles the low-level actions.
9436 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
9437 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9438 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9439 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9440 -- determines at runtime whether Ename denotes an entry or a procedure
9441 -- and perform the appropriate kind of dispatching select.
9443 function Build_Normal_Requeue
return Node_Id
;
9444 -- N denotes a non-dispatching requeue statement to either a task or a
9445 -- protected entry. Build the appropriate runtime call to perform the
9448 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
9449 -- For a protected entry, create a return statement to skip the rest of
9450 -- the entry body. Otherwise, create a goto statement to skip the rest
9451 -- of a task accept statement. The lookup for the enclosing entry body
9452 -- or accept statement starts from Search.
9454 ---------------------------------------
9455 -- Build_Dispatching_Call_Equivalent --
9456 ---------------------------------------
9458 function Build_Dispatching_Call_Equivalent
return Node_Id
is
9459 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
9460 Obj
: constant Node_Id
:= Original_Node
(Concval
);
9467 -- Climb the parent chain looking for the inner-most entry body or
9468 -- accept statement.
9471 while Present
(Acc_Ent
)
9472 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
9475 Acc_Ent
:= Parent
(Acc_Ent
);
9478 -- A requeue statement should be housed inside an entry body or an
9479 -- accept statement at some level. If this is not the case, then the
9480 -- tree is malformed.
9482 pragma Assert
(Present
(Acc_Ent
));
9484 -- Recover the list of formal parameters
9486 if Nkind
(Acc_Ent
) = N_Entry_Body
then
9487 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
9490 Formals
:= Parameter_Specifications
(Acc_Ent
);
9492 -- Create the actual parameters for the dispatching call. These are
9493 -- simply copies of the entry body or accept statement formals in the
9494 -- same order as they appear.
9498 if Present
(Formals
) then
9499 Actuals
:= New_List
;
9500 Formal
:= First
(Formals
);
9501 while Present
(Formal
) loop
9503 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
9509 -- Obj.Call_Ent (Actuals);
9512 Make_Procedure_Call_Statement
(Loc
,
9514 Make_Selected_Component
(Loc
,
9515 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
9516 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
9518 Parameter_Associations
=> Actuals
);
9519 end Build_Dispatching_Call_Equivalent
;
9521 -------------------------------
9522 -- Build_Dispatching_Requeue --
9523 -------------------------------
9525 function Build_Dispatching_Requeue
return Node_Id
is
9526 Params
: constant List_Id
:= New_List
;
9529 -- Process the "with abort" parameter
9532 New_Reference_To
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
9534 -- Process the entry wrapper's position in the primary dispatch
9535 -- table parameter. Generate:
9537 -- Ada.Tags.Get_Entry_Index
9538 -- (T => To_Tag_Ptr (Obj'Address).all,
9540 -- Ada.Tags.Get_Offset_Index
9541 -- (Ada.Tags.Tag (Concval),
9542 -- <interface dispatch table position of Ename>));
9544 -- Note that Obj'Address is recursively expanded into a call to
9545 -- Base_Address (Obj).
9547 if Tagged_Type_Expansion
then
9549 Make_Function_Call
(Loc
,
9550 Name
=> New_Reference_To
(RTE
(RE_Get_Entry_Index
), Loc
),
9551 Parameter_Associations
=> New_List
(
9553 Make_Explicit_Dereference
(Loc
,
9554 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
9555 Make_Attribute_Reference
(Loc
,
9556 Prefix
=> New_Copy_Tree
(Concval
),
9557 Attribute_Name
=> Name_Address
))),
9559 Make_Function_Call
(Loc
,
9560 Name
=> New_Reference_To
(RTE
(RE_Get_Offset_Index
), Loc
),
9561 Parameter_Associations
=> New_List
(
9562 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
9563 Make_Integer_Literal
(Loc
,
9564 DT_Position
(Entity
(Ename
))))))));
9570 Make_Function_Call
(Loc
,
9571 Name
=> New_Reference_To
(RTE
(RE_Get_Entry_Index
), Loc
),
9572 Parameter_Associations
=> New_List
(
9574 Make_Attribute_Reference
(Loc
,
9576 Attribute_Name
=> Name_Tag
),
9578 Make_Function_Call
(Loc
,
9579 Name
=> New_Reference_To
(RTE
(RE_Get_Offset_Index
), Loc
),
9581 Parameter_Associations
=> New_List
(
9585 Make_Attribute_Reference
(Loc
,
9587 Attribute_Name
=> Name_Tag
),
9591 Make_Attribute_Reference
(Loc
,
9592 Prefix
=> New_Reference_To
(Etype
(Concval
), Loc
),
9593 Attribute_Name
=> Name_Tag
),
9597 Make_Integer_Literal
(Loc
,
9598 DT_Position
(Entity
(Ename
))))))));
9601 -- Specific actuals for protected to XXX requeue
9603 if Is_Protected_Type
(Old_Typ
) then
9605 Make_Attribute_Reference
(Loc
, -- _object'Address
9607 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
9608 Attribute_Name
=> Name_Address
));
9610 Prepend_To
(Params
, -- True
9611 New_Reference_To
(Standard_True
, Loc
));
9613 -- Specific actuals for task to XXX requeue
9616 pragma Assert
(Is_Task_Type
(Old_Typ
));
9618 Prepend_To
(Params
, -- null
9619 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
9621 Prepend_To
(Params
, -- False
9622 New_Reference_To
(Standard_False
, Loc
));
9625 -- Add the object parameter
9627 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
9630 -- _Disp_Requeue (<Params>);
9632 -- Find entity for Disp_Requeue operation, which belongs to
9633 -- the type and may not be directly visible.
9640 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
9641 while Present
(Elmt
) loop
9643 exit when Chars
(Op
) = Name_uDisp_Requeue
;
9648 Make_Procedure_Call_Statement
(Loc
,
9649 Name
=> New_Occurrence_Of
(Op
, Loc
),
9650 Parameter_Associations
=> Params
);
9652 end Build_Dispatching_Requeue
;
9654 --------------------------------------
9655 -- Build_Dispatching_Requeue_To_Any --
9656 --------------------------------------
9658 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
9659 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
9660 Obj
: constant Node_Id
:= Original_Node
(Concval
);
9661 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
9671 -- Dispatch table slot processing, generate:
9674 S
:= Build_S
(Loc
, Decls
);
9676 -- Call kind processing, generate:
9677 -- C : Ada.Tags.Prim_Op_Kind;
9679 C
:= Build_C
(Loc
, Decls
);
9682 -- S := Ada.Tags.Get_Offset_Index
9683 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
9685 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
9688 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
9691 Make_Procedure_Call_Statement
(Loc
,
9694 Find_Prim_Op
(Etype
(Etype
(Obj
)),
9695 Name_uDisp_Get_Prim_Op_Kind
),
9697 Parameter_Associations
=> New_List
(
9698 New_Copy_Tree
(Obj
),
9699 New_Reference_To
(S
, Loc
),
9700 New_Reference_To
(C
, Loc
))));
9704 -- if C = POK_Protected_Entry
9705 -- or else C = POK_Task_Entry
9708 Make_Implicit_If_Statement
(N
,
9714 New_Reference_To
(C
, Loc
),
9716 New_Reference_To
(RTE
(RE_POK_Protected_Entry
), Loc
)),
9721 New_Reference_To
(C
, Loc
),
9723 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
9725 -- Dispatching requeue equivalent
9727 Then_Statements
=> New_List
(
9728 Build_Dispatching_Requeue
,
9731 -- elsif C = POK_Protected_Procedure then
9733 Elsif_Parts
=> New_List
(
9734 Make_Elsif_Part
(Loc
,
9738 New_Reference_To
(C
, Loc
),
9741 RTE
(RE_POK_Protected_Procedure
), Loc
)),
9743 -- Dispatching call equivalent
9745 Then_Statements
=> New_List
(
9746 Build_Dispatching_Call_Equivalent
))),
9749 -- raise Program_Error;
9752 Else_Statements
=> New_List
(
9753 Make_Raise_Program_Error
(Loc
,
9754 Reason
=> PE_Explicit_Raise
))));
9756 -- Wrap everything into a block
9759 Make_Block_Statement
(Loc
,
9760 Declarations
=> Decls
,
9761 Handled_Statement_Sequence
=>
9762 Make_Handled_Sequence_Of_Statements
(Loc
,
9763 Statements
=> Stmts
));
9764 end Build_Dispatching_Requeue_To_Any
;
9766 --------------------------
9767 -- Build_Normal_Requeue --
9768 --------------------------
9770 function Build_Normal_Requeue
return Node_Id
is
9771 Params
: constant List_Id
:= New_List
;
9776 -- Process the "with abort" parameter
9779 New_Reference_To
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
9781 -- Add the index expression to the parameters. It is common among all
9785 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
9787 if Is_Protected_Type
(Old_Typ
) then
9789 Self_Param
: Node_Id
;
9793 Make_Attribute_Reference
(Loc
,
9795 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
9797 Name_Unchecked_Access
);
9799 -- Protected to protected requeue
9801 if Is_Protected_Type
(Conc_Typ
) then
9804 RTE
(RE_Requeue_Protected_Entry
), Loc
);
9807 Make_Attribute_Reference
(Loc
,
9809 Concurrent_Ref
(Concval
),
9811 Name_Unchecked_Access
);
9813 -- Protected to task requeue
9815 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
9818 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
9820 Param
:= Concurrent_Ref
(Concval
);
9823 Prepend_To
(Params
, Param
);
9824 Prepend_To
(Params
, Self_Param
);
9827 else pragma Assert
(Is_Task_Type
(Old_Typ
));
9829 -- Task to protected requeue
9831 if Is_Protected_Type
(Conc_Typ
) then
9834 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
9837 Make_Attribute_Reference
(Loc
,
9839 Concurrent_Ref
(Concval
),
9841 Name_Unchecked_Access
);
9843 -- Task to task requeue
9845 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
9847 New_Reference_To
(RTE
(RE_Requeue_Task_Entry
), Loc
);
9849 Param
:= Concurrent_Ref
(Concval
);
9852 Prepend_To
(Params
, Param
);
9856 Make_Procedure_Call_Statement
(Loc
,
9858 Parameter_Associations
=> Params
);
9859 end Build_Normal_Requeue
;
9861 --------------------------
9862 -- Build_Skip_Statement --
9863 --------------------------
9865 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
9866 Skip_Stmt
: Node_Id
;
9869 -- Build a return statement to skip the rest of the entire body
9871 if Is_Protected_Type
(Old_Typ
) then
9872 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
9874 -- If the requeue is within a task, find the end label of the
9875 -- enclosing accept statement and create a goto statement to it.
9883 -- Climb the parent chain looking for the enclosing accept
9886 Acc
:= Parent
(Search
);
9888 and then Nkind
(Acc
) /= N_Accept_Statement
9890 Acc
:= Parent
(Acc
);
9893 -- The last statement is the second label used for completing
9894 -- the rendezvous the usual way. The label we are looking for
9895 -- is right before it.
9898 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
9900 pragma Assert
(Nkind
(Label
) = N_Label
);
9902 -- Generate a goto statement to skip the rest of the accept
9905 Make_Goto_Statement
(Loc
,
9907 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
9911 Set_Analyzed
(Skip_Stmt
);
9914 end Build_Skip_Statement
;
9916 -- Start of processing for Expand_N_Requeue_Statement
9919 -- Extract the components of the entry call
9921 Extract_Entry
(N
, Concval
, Ename
, Index
);
9922 Conc_Typ
:= Etype
(Concval
);
9924 -- If the prefix is an access to class-wide type, dereference to get
9925 -- object and entry type.
9927 if Is_Access_Type
(Conc_Typ
) then
9928 Conc_Typ
:= Designated_Type
(Conc_Typ
);
9930 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Concval
)));
9931 Analyze_And_Resolve
(Concval
, Conc_Typ
);
9934 -- Examine the scope stack in order to find nearest enclosing protected
9935 -- or task type. This will constitute our invocation source.
9937 Old_Typ
:= Current_Scope
;
9938 while Present
(Old_Typ
)
9939 and then not Is_Protected_Type
(Old_Typ
)
9940 and then not Is_Task_Type
(Old_Typ
)
9942 Old_Typ
:= Scope
(Old_Typ
);
9945 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
9946 -- Concval.Ename where the type of Concval is class-wide concurrent
9949 if Ada_Version
>= Ada_2012
9950 and then Present
(Concval
)
9951 and then Is_Class_Wide_Type
(Conc_Typ
)
9952 and then Is_Concurrent_Interface
(Conc_Typ
)
9955 Has_Impl
: Boolean := False;
9956 Impl_Kind
: Name_Id
:= No_Name
;
9959 -- Check whether the Ename is flagged by pragma Implemented
9961 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
9963 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
9966 -- The procedure_or_entry_NAME is guaranteed to be overridden by
9967 -- an entry. Create a call to predefined primitive _Disp_Requeue.
9970 and then Impl_Kind
= Name_By_Entry
9972 Rewrite
(N
, Build_Dispatching_Requeue
);
9974 Insert_After
(N
, Build_Skip_Statement
(N
));
9976 -- The procedure_or_entry_NAME is guaranteed to be overridden by
9977 -- a protected procedure. In this case the requeue is transformed
9978 -- into a dispatching call.
9981 and then Impl_Kind
= Name_By_Protected_Procedure
9983 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
9986 -- The procedure_or_entry_NAME's implementation kind is either
9987 -- By_Any, Optional, or pragma Implemented was not applied at all.
9988 -- In this case a runtime test determines whether Ename denotes an
9989 -- entry or a protected procedure and performs the appropriate
9993 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
9998 -- Processing for regular (non-dispatching) requeues
10001 Rewrite
(N
, Build_Normal_Requeue
);
10003 Insert_After
(N
, Build_Skip_Statement
(N
));
10005 end Expand_N_Requeue_Statement
;
10007 -------------------------------
10008 -- Expand_N_Selective_Accept --
10009 -------------------------------
10011 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10012 Loc
: constant Source_Ptr
:= Sloc
(N
);
10013 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10015 -- Note: in the below declarations a lot of new lists are allocated
10016 -- unconditionally which may well not end up being used. That's not
10017 -- a good idea since it wastes space gratuitously ???
10019 Accept_Case
: List_Id
;
10020 Accept_List
: constant List_Id
:= New_List
;
10023 Alt_List
: constant List_Id
:= New_List
;
10024 Alt_Stats
: List_Id
;
10025 Ann
: Entity_Id
:= Empty
;
10027 Check_Guard
: Boolean := True;
10029 Decls
: constant List_Id
:= New_List
;
10030 Stats
: constant List_Id
:= New_List
;
10031 Body_List
: constant List_Id
:= New_List
;
10032 Trailing_List
: constant List_Id
:= New_List
;
10035 Else_Present
: Boolean := False;
10036 Terminate_Alt
: Node_Id
:= Empty
;
10037 Select_Mode
: Node_Id
;
10039 Delay_Case
: List_Id
;
10040 Delay_Count
: Integer := 0;
10041 Delay_Val
: Entity_Id
;
10042 Delay_Index
: Entity_Id
;
10043 Delay_Min
: Entity_Id
;
10044 Delay_Num
: Int
:= 1;
10045 Delay_Alt_List
: List_Id
:= New_List
;
10046 Delay_List
: constant List_Id
:= New_List
;
10050 First_Delay
: Boolean := True;
10051 Guard_Open
: Entity_Id
;
10057 Num_Accept
: Nat
:= 0;
10059 Time_Type
: Entity_Id
;
10060 Select_Call
: Node_Id
;
10062 Qnam
: constant Entity_Id
:=
10063 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10065 Xnam
: constant Entity_Id
:=
10066 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10068 -----------------------
10069 -- Local subprograms --
10070 -----------------------
10072 function Accept_Or_Raise
return List_Id
;
10073 -- For the rare case where delay alternatives all have guards, and
10074 -- all of them are closed, it is still possible that there were open
10075 -- accept alternatives with no callers. We must reexamine the
10076 -- Accept_List, and execute a selective wait with no else if some
10077 -- accept is open. If none, we raise program_error.
10079 procedure Add_Accept
(Alt
: Node_Id
);
10080 -- Process a single accept statement in a select alternative. Build
10081 -- procedure for body of accept, and add entry to dispatch table with
10082 -- expression for guard, in preparation for call to run time select.
10084 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10085 -- Manufacture a label using Num as a serial number and declare it.
10086 -- The declaration is appended to Decls. The label marks the trailing
10087 -- statements of an accept or delay alternative.
10089 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10090 -- Build call to Selective_Wait runtime routine
10092 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10093 -- Add code to compare value of delay with previous values, and
10094 -- generate case entry for trailing statements.
10096 procedure Process_Accept_Alternative
10100 -- Add code to call corresponding procedure, and branch to
10101 -- trailing statements, if any.
10103 ---------------------
10104 -- Accept_Or_Raise --
10105 ---------------------
10107 function Accept_Or_Raise
return List_Id
is
10110 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10113 -- We generate the following:
10115 -- for J in q'range loop
10116 -- if q(J).S /=null_task_entry then
10117 -- selective_wait (simple_mode,...);
10123 -- if no rendez_vous then
10124 -- raise program_error;
10127 -- Note that the code needs to know that the selector name
10128 -- in an Accept_Alternative is named S.
10130 Cond
:= Make_Op_Ne
(Loc
,
10132 Make_Selected_Component
(Loc
,
10134 Make_Indexed_Component
(Loc
,
10135 Prefix
=> New_Reference_To
(Qnam
, Loc
),
10136 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))),
10137 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10139 New_Reference_To
(RTE
(RE_Null_Task_Entry
), Loc
));
10141 Stats
:= New_List
(
10142 Make_Implicit_Loop_Statement
(N
,
10143 Iteration_Scheme
=>
10144 Make_Iteration_Scheme
(Loc
,
10145 Loop_Parameter_Specification
=>
10146 Make_Loop_Parameter_Specification
(Loc
,
10147 Defining_Identifier
=> J
,
10148 Discrete_Subtype_Definition
=>
10149 Make_Attribute_Reference
(Loc
,
10150 Prefix
=> New_Reference_To
(Qnam
, Loc
),
10151 Attribute_Name
=> Name_Range
,
10152 Expressions
=> New_List
(
10153 Make_Integer_Literal
(Loc
, 1))))),
10155 Statements
=> New_List
(
10156 Make_Implicit_If_Statement
(N
,
10158 Then_Statements
=> New_List
(
10160 New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
)),
10161 Make_Exit_Statement
(Loc
))))));
10164 Make_Raise_Program_Error
(Loc
,
10165 Condition
=> Make_Op_Eq
(Loc
,
10166 Left_Opnd
=> New_Reference_To
(Xnam
, Loc
),
10168 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
)),
10169 Reason
=> PE_All_Guards_Closed
));
10172 end Accept_Or_Raise
;
10178 procedure Add_Accept
(Alt
: Node_Id
) is
10179 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10180 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10181 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10182 Eent
: constant Entity_Id
:= Entity
(Ename
);
10183 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10184 Null_Body
: Node_Id
;
10185 Proc_Body
: Node_Id
;
10186 PB_Ent
: Entity_Id
;
10192 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10195 if Present
(Condition
(Alt
)) then
10197 Make_If_Expression
(Eloc
, New_List
(
10199 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10200 New_Reference_To
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10203 Entry_Index_Expression
10204 (Eloc
, Eent
, Index
, Scope
(Eent
));
10207 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10208 Null_Body
:= New_Reference_To
(Standard_False
, Eloc
);
10210 if Abort_Allowed
then
10211 Call
:= Make_Procedure_Call_Statement
(Eloc
,
10212 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Eloc
));
10213 Insert_Before
(First
(Statements
(Handled_Statement_Sequence
(
10214 Accept_Statement
(Alt
)))), Call
);
10219 Make_Defining_Identifier
(Eloc
,
10220 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10222 if Comes_From_Source
(Alt
) then
10223 Set_Debug_Info_Needed
(PB_Ent
);
10227 Make_Subprogram_Body
(Eloc
,
10229 Make_Procedure_Specification
(Eloc
,
10230 Defining_Unit_Name
=> PB_Ent
),
10231 Declarations
=> Declarations
(Acc_Stm
),
10232 Handled_Statement_Sequence
=>
10233 Build_Accept_Body
(Accept_Statement
(Alt
)));
10235 -- During the analysis of the body of the accept statement, any
10236 -- zero cost exception handler records were collected in the
10237 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10238 -- This is where we move them to where they belong, namely the
10239 -- newly created procedure.
10241 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10242 Append
(Proc_Body
, Body_List
);
10245 Null_Body
:= New_Reference_To
(Standard_True
, Eloc
);
10247 -- if accept statement has declarations, insert above, given that
10248 -- we are not creating a body for the accept.
10250 if Present
(Declarations
(Acc_Stm
)) then
10251 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10255 Append_To
(Accept_List
,
10256 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10258 Num_Accept
:= Num_Accept
+ 1;
10261 ----------------------------
10262 -- Make_And_Declare_Label --
10263 ----------------------------
10265 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10269 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10271 Make_Label
(Loc
, Lab_Id
);
10274 Make_Implicit_Label_Declaration
(Loc
,
10275 Defining_Identifier
=>
10276 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10277 Label_Construct
=> Lab
));
10280 end Make_And_Declare_Label
;
10282 ----------------------
10283 -- Make_Select_Call --
10284 ----------------------
10286 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10287 Params
: constant List_Id
:= New_List
;
10291 Make_Attribute_Reference
(Loc
,
10292 Prefix
=> New_Reference_To
(Qnam
, Loc
),
10293 Attribute_Name
=> Name_Unchecked_Access
),
10295 Append
(Select_Mode
, Params
);
10296 Append
(New_Reference_To
(Ann
, Loc
), Params
);
10297 Append
(New_Reference_To
(Xnam
, Loc
), Params
);
10300 Make_Procedure_Call_Statement
(Loc
,
10301 Name
=> New_Reference_To
(RTE
(RE_Selective_Wait
), Loc
),
10302 Parameter_Associations
=> Params
);
10303 end Make_Select_Call
;
10305 --------------------------------
10306 -- Process_Accept_Alternative --
10307 --------------------------------
10309 procedure Process_Accept_Alternative
10314 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10315 Alt_Stats
: List_Id
;
10318 Adjust_Condition
(Condition
(Alt
));
10320 -- Accept with body
10322 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10325 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10328 (Defining_Unit_Name
(Specification
(Proc
)),
10331 -- Accept with no body (followed by trailing statements)
10334 Alt_Stats
:= Empty_List
;
10337 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
10339 -- After the call, if any, branch to trailing statements, if any.
10340 -- We create a label for each, as well as the corresponding label
10343 if not Is_Empty_List
(Statements
(Alt
)) then
10344 Lab
:= Make_And_Declare_Label
(Index
);
10345 Append
(Lab
, Trailing_List
);
10346 Append_List
(Statements
(Alt
), Trailing_List
);
10347 Append_To
(Trailing_List
,
10348 Make_Goto_Statement
(Loc
,
10349 Name
=> New_Copy
(Identifier
(End_Lab
))));
10355 Append_To
(Alt_Stats
,
10356 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
10358 Append_To
(Alt_List
,
10359 Make_Case_Statement_Alternative
(Loc
,
10360 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
10361 Statements
=> Alt_Stats
));
10362 end Process_Accept_Alternative
;
10364 -------------------------------
10365 -- Process_Delay_Alternative --
10366 -------------------------------
10368 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
10369 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
10371 Delay_Alt
: List_Id
;
10374 -- Deal with C/Fortran boolean as delay condition
10376 Adjust_Condition
(Condition
(Alt
));
10378 -- Determine the smallest specified delay
10380 -- for each delay alternative generate:
10382 -- if guard-expression then
10383 -- Delay_Val := delay-expression;
10384 -- Guard_Open := True;
10385 -- if Delay_Val < Delay_Min then
10386 -- Delay_Min := Delay_Val;
10387 -- Delay_Index := Index;
10391 -- The enclosing if-statement is omitted if there is no guard
10393 if Delay_Count
= 1 or else First_Delay
then
10394 First_Delay
:= False;
10396 Delay_Alt
:= New_List
(
10397 Make_Assignment_Statement
(Loc
,
10398 Name
=> New_Reference_To
(Delay_Min
, Loc
),
10399 Expression
=> Expression
(Delay_Statement
(Alt
))));
10401 if Delay_Count
> 1 then
10402 Append_To
(Delay_Alt
,
10403 Make_Assignment_Statement
(Loc
,
10404 Name
=> New_Reference_To
(Delay_Index
, Loc
),
10405 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
10409 Delay_Alt
:= New_List
(
10410 Make_Assignment_Statement
(Loc
,
10411 Name
=> New_Reference_To
(Delay_Val
, Loc
),
10412 Expression
=> Expression
(Delay_Statement
(Alt
))));
10414 if Time_Type
= Standard_Duration
then
10417 Left_Opnd
=> New_Reference_To
(Delay_Val
, Loc
),
10418 Right_Opnd
=> New_Reference_To
(Delay_Min
, Loc
));
10421 -- The scope of the time type must define a comparison
10422 -- operator. The scope itself may not be visible, so we
10423 -- construct a node with entity information to insure that
10424 -- semantic analysis can find the proper operator.
10427 Make_Function_Call
(Loc
,
10428 Name
=> Make_Selected_Component
(Loc
,
10430 New_Reference_To
(Scope
(Time_Type
), Loc
),
10432 Make_Operator_Symbol
(Loc
,
10433 Chars
=> Name_Op_Lt
,
10434 Strval
=> No_String
)),
10435 Parameter_Associations
=>
10437 New_Reference_To
(Delay_Val
, Loc
),
10438 New_Reference_To
(Delay_Min
, Loc
)));
10440 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
10443 Append_To
(Delay_Alt
,
10444 Make_Implicit_If_Statement
(N
,
10446 Then_Statements
=> New_List
(
10447 Make_Assignment_Statement
(Loc
,
10448 Name
=> New_Reference_To
(Delay_Min
, Loc
),
10449 Expression
=> New_Reference_To
(Delay_Val
, Loc
)),
10451 Make_Assignment_Statement
(Loc
,
10452 Name
=> New_Reference_To
(Delay_Index
, Loc
),
10453 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
10456 if Check_Guard
then
10457 Append_To
(Delay_Alt
,
10458 Make_Assignment_Statement
(Loc
,
10459 Name
=> New_Reference_To
(Guard_Open
, Loc
),
10460 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
10463 if Present
(Condition
(Alt
)) then
10464 Delay_Alt
:= New_List
(
10465 Make_Implicit_If_Statement
(N
,
10466 Condition
=> Condition
(Alt
),
10467 Then_Statements
=> Delay_Alt
));
10470 Append_List
(Delay_Alt
, Delay_List
);
10472 Ensure_Statement_Present
(Dloc
, Alt
);
10474 -- If the delay alternative has a statement part, add choice to the
10475 -- case statements for delays.
10477 if not Is_Empty_List
(Statements
(Alt
)) then
10479 if Delay_Count
= 1 then
10480 Append_List
(Statements
(Alt
), Delay_Alt_List
);
10483 Append_To
(Delay_Alt_List
,
10484 Make_Case_Statement_Alternative
(Loc
,
10485 Discrete_Choices
=> New_List
(
10486 Make_Integer_Literal
(Loc
, Index
)),
10487 Statements
=> Statements
(Alt
)));
10490 elsif Delay_Count
= 1 then
10492 -- If the single delay has no trailing statements, add a branch
10493 -- to the exit label to the selective wait.
10495 Delay_Alt_List
:= New_List
(
10496 Make_Goto_Statement
(Loc
,
10497 Name
=> New_Copy
(Identifier
(End_Lab
))));
10500 end Process_Delay_Alternative
;
10502 -- Start of processing for Expand_N_Selective_Accept
10505 Process_Statements_For_Controlled_Objects
(N
);
10507 -- First insert some declarations before the select. The first is:
10511 -- This variable holds the parameters passed to the accept body. This
10512 -- declaration has already been inserted by the time we get here by
10513 -- a call to Expand_Accept_Declarations made from the semantics when
10514 -- processing the first accept statement contained in the select. We
10515 -- can find this entity as Accept_Address (E), where E is any of the
10516 -- entries references by contained accept statements.
10518 -- The first step is to scan the list of Selective_Accept_Statements
10519 -- to find this entity, and also count the number of accepts, and
10520 -- determine if terminated, delay or else is present:
10524 Alt
:= First
(Alts
);
10525 while Present
(Alt
) loop
10526 Process_Statements_For_Controlled_Objects
(Alt
);
10528 if Nkind
(Alt
) = N_Accept_Alternative
then
10531 elsif Nkind
(Alt
) = N_Delay_Alternative
then
10532 Delay_Count
:= Delay_Count
+ 1;
10534 -- If the delays are relative delays, the delay expressions have
10535 -- type Standard_Duration. Otherwise they must have some time type
10536 -- recognized by GNAT.
10538 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
10539 Time_Type
:= Standard_Duration
;
10541 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
10543 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
10544 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
10549 "& is not a time type (RM 9.6(6))",
10550 Expression
(Delay_Statement
(Alt
)), Time_Type
);
10551 Time_Type
:= Standard_Duration
;
10552 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
10556 if No
(Condition
(Alt
)) then
10558 -- This guard will always be open
10560 Check_Guard
:= False;
10563 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
10564 Adjust_Condition
(Condition
(Alt
));
10565 Terminate_Alt
:= Alt
;
10568 Num_Alts
:= Num_Alts
+ 1;
10572 Else_Present
:= Present
(Else_Statements
(N
));
10574 -- At the same time (see procedure Add_Accept) we build the accept list:
10576 -- Qnn : Accept_List (1 .. num-select) := (
10577 -- (null-body, entry-index),
10578 -- (null-body, entry-index),
10580 -- (null_body, entry-index));
10582 -- In the above declaration, null-body is True if the corresponding
10583 -- accept has no body, and false otherwise. The entry is either the
10584 -- entry index expression if there is no guard, or if a guard is
10585 -- present, then an if expression of the form:
10587 -- (if guard then entry-index else Null_Task_Entry)
10589 -- If a guard is statically known to be false, the entry can simply
10590 -- be omitted from the accept list.
10593 Make_Object_Declaration
(Loc
,
10594 Defining_Identifier
=> Qnam
,
10595 Object_Definition
=> New_Reference_To
(RTE
(RE_Accept_List
), Loc
),
10596 Aliased_Present
=> True,
10598 Make_Qualified_Expression
(Loc
,
10600 New_Reference_To
(RTE
(RE_Accept_List
), Loc
),
10602 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
10604 -- Then we declare the variable that holds the index for the accept
10605 -- that will be selected for service:
10607 -- Xnn : Select_Index;
10610 Make_Object_Declaration
(Loc
,
10611 Defining_Identifier
=> Xnam
,
10612 Object_Definition
=>
10613 New_Reference_To
(RTE
(RE_Select_Index
), Loc
),
10615 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
)));
10617 -- After this follow procedure declarations for each accept body
10619 -- procedure Pnn is
10624 -- where the ... are statements from the corresponding procedure body.
10625 -- No parameters are involved, since the parameters are passed via Ann
10626 -- and the parameter references have already been expanded to be direct
10627 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
10628 -- any embedded tasking statements (which would normally be illegal in
10629 -- procedures), have been converted to calls to the tasking runtime so
10630 -- there is no problem in putting them into procedures.
10632 -- The original accept statement has been expanded into a block in
10633 -- the same fashion as for simple accepts (see Build_Accept_Body).
10635 -- Note: we don't really need to build these procedures for the case
10636 -- where no delay statement is present, but it is just as easy to
10637 -- build them unconditionally, and not significantly inefficient,
10638 -- since if they are short they will be inlined anyway.
10640 -- The procedure declarations have been assembled in Body_List
10642 -- If delays are present, we must compute the required delay.
10643 -- We first generate the declarations:
10645 -- Delay_Index : Boolean := 0;
10646 -- Delay_Min : Some_Time_Type.Time;
10647 -- Delay_Val : Some_Time_Type.Time;
10649 -- Delay_Index will be set to the index of the minimum delay, i.e. the
10650 -- active delay that is actually chosen as the basis for the possible
10651 -- delay if an immediate rendez-vous is not possible.
10653 -- In the most common case there is a single delay statement, and this
10654 -- is handled specially.
10656 if Delay_Count
> 0 then
10658 -- Generate the required declarations
10661 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
10663 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
10665 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
10668 Make_Object_Declaration
(Loc
,
10669 Defining_Identifier
=> Delay_Val
,
10670 Object_Definition
=> New_Reference_To
(Time_Type
, Loc
)));
10673 Make_Object_Declaration
(Loc
,
10674 Defining_Identifier
=> Delay_Index
,
10675 Object_Definition
=> New_Reference_To
(Standard_Integer
, Loc
),
10676 Expression
=> Make_Integer_Literal
(Loc
, 0)));
10679 Make_Object_Declaration
(Loc
,
10680 Defining_Identifier
=> Delay_Min
,
10681 Object_Definition
=> New_Reference_To
(Time_Type
, Loc
),
10683 Unchecked_Convert_To
(Time_Type
,
10684 Make_Attribute_Reference
(Loc
,
10686 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
10687 Attribute_Name
=> Name_Last
))));
10689 -- Create Duration and Delay_Mode objects used for passing a delay
10692 D
:= Make_Temporary
(Loc
, 'D');
10693 M
:= Make_Temporary
(Loc
, 'M');
10699 -- Note that these values are defined in s-osprim.ads and must
10700 -- be kept in sync:
10702 -- Relative : constant := 0;
10703 -- Absolute_Calendar : constant := 1;
10704 -- Absolute_RT : constant := 2;
10706 if Time_Type
= Standard_Duration
then
10707 Discr
:= Make_Integer_Literal
(Loc
, 0);
10709 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
10710 Discr
:= Make_Integer_Literal
(Loc
, 1);
10714 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
10715 Discr
:= Make_Integer_Literal
(Loc
, 2);
10719 Make_Object_Declaration
(Loc
,
10720 Defining_Identifier
=> D
,
10721 Object_Definition
=>
10722 New_Reference_To
(Standard_Duration
, Loc
)));
10725 Make_Object_Declaration
(Loc
,
10726 Defining_Identifier
=> M
,
10727 Object_Definition
=>
10728 New_Reference_To
(Standard_Integer
, Loc
),
10729 Expression
=> Discr
));
10732 if Check_Guard
then
10734 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
10737 Make_Object_Declaration
(Loc
,
10738 Defining_Identifier
=> Guard_Open
,
10739 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
10740 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
10743 -- Delay_Count is zero, don't need M and D set (suppress warning)
10750 if Present
(Terminate_Alt
) then
10752 -- If the terminate alternative guard is False, use
10753 -- Simple_Mode; otherwise use Terminate_Mode.
10755 if Present
(Condition
(Terminate_Alt
)) then
10756 Select_Mode
:= Make_If_Expression
(Loc
,
10757 New_List
(Condition
(Terminate_Alt
),
10758 New_Reference_To
(RTE
(RE_Terminate_Mode
), Loc
),
10759 New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
)));
10761 Select_Mode
:= New_Reference_To
(RTE
(RE_Terminate_Mode
), Loc
);
10764 elsif Else_Present
or Delay_Count
> 0 then
10765 Select_Mode
:= New_Reference_To
(RTE
(RE_Else_Mode
), Loc
);
10768 Select_Mode
:= New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
);
10771 Select_Call
:= Make_Select_Call
(Select_Mode
);
10772 Append
(Select_Call
, Stats
);
10774 -- Now generate code to act on the result. There is an entry
10775 -- in this case for each accept statement with a non-null body,
10776 -- followed by a branch to the statements that follow the Accept.
10777 -- In the absence of delay alternatives, we generate:
10780 -- when No_Rendezvous => -- omitted if simple mode
10795 -- Lab0: Else_Statements;
10798 -- Lab1: Trailing_Statements1;
10801 -- Lab2: Trailing_Statements2;
10806 -- Generate label for common exit
10808 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
10810 -- First entry is the default case, when no rendezvous is possible
10812 Choices
:= New_List
(New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
));
10814 if Else_Present
then
10816 -- If no rendezvous is possible, the else part is executed
10818 Lab
:= Make_And_Declare_Label
(0);
10819 Alt_Stats
:= New_List
(
10820 Make_Goto_Statement
(Loc
,
10821 Name
=> New_Copy
(Identifier
(Lab
))));
10823 Append
(Lab
, Trailing_List
);
10824 Append_List
(Else_Statements
(N
), Trailing_List
);
10825 Append_To
(Trailing_List
,
10826 Make_Goto_Statement
(Loc
,
10827 Name
=> New_Copy
(Identifier
(End_Lab
))));
10829 Alt_Stats
:= New_List
(
10830 Make_Goto_Statement
(Loc
,
10831 Name
=> New_Copy
(Identifier
(End_Lab
))));
10834 Append_To
(Alt_List
,
10835 Make_Case_Statement_Alternative
(Loc
,
10836 Discrete_Choices
=> Choices
,
10837 Statements
=> Alt_Stats
));
10839 -- We make use of the fact that Accept_Index is an integer type, and
10840 -- generate successive literals for entries for each accept. Only those
10841 -- for which there is a body or trailing statements get a case entry.
10843 Alt
:= First
(Select_Alternatives
(N
));
10844 Proc
:= First
(Body_List
);
10845 while Present
(Alt
) loop
10847 if Nkind
(Alt
) = N_Accept_Alternative
then
10848 Process_Accept_Alternative
(Alt
, Index
, Proc
);
10849 Index
:= Index
+ 1;
10852 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
10857 elsif Nkind
(Alt
) = N_Delay_Alternative
then
10858 Process_Delay_Alternative
(Alt
, Delay_Num
);
10859 Delay_Num
:= Delay_Num
+ 1;
10865 -- An others choice is always added to the main case, as well
10866 -- as the delay case (to satisfy the compiler).
10868 Append_To
(Alt_List
,
10869 Make_Case_Statement_Alternative
(Loc
,
10870 Discrete_Choices
=>
10871 New_List
(Make_Others_Choice
(Loc
)),
10873 New_List
(Make_Goto_Statement
(Loc
,
10874 Name
=> New_Copy
(Identifier
(End_Lab
))))));
10876 Accept_Case
:= New_List
(
10877 Make_Case_Statement
(Loc
,
10878 Expression
=> New_Reference_To
(Xnam
, Loc
),
10879 Alternatives
=> Alt_List
));
10881 Append_List
(Trailing_List
, Accept_Case
);
10882 Append_List
(Body_List
, Decls
);
10884 -- Construct case statement for trailing statements of delay
10885 -- alternatives, if there are several of them.
10887 if Delay_Count
> 1 then
10888 Append_To
(Delay_Alt_List
,
10889 Make_Case_Statement_Alternative
(Loc
,
10890 Discrete_Choices
=>
10891 New_List
(Make_Others_Choice
(Loc
)),
10893 New_List
(Make_Null_Statement
(Loc
))));
10895 Delay_Case
:= New_List
(
10896 Make_Case_Statement
(Loc
,
10897 Expression
=> New_Reference_To
(Delay_Index
, Loc
),
10898 Alternatives
=> Delay_Alt_List
));
10900 Delay_Case
:= Delay_Alt_List
;
10903 -- If there are no delay alternatives, we append the case statement
10904 -- to the statement list.
10906 if Delay_Count
= 0 then
10907 Append_List
(Accept_Case
, Stats
);
10909 -- Delay alternatives present
10912 -- If delay alternatives are present we generate:
10914 -- find minimum delay.
10915 -- DX := minimum delay;
10916 -- M := <delay mode>;
10917 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
10920 -- if X = No_Rendezvous then
10921 -- case statement for delay statements.
10923 -- case statement for accept alternatives.
10934 -- The type of the delay expression is known to be legal
10936 if Time_Type
= Standard_Duration
then
10937 Conv
:= New_Reference_To
(Delay_Min
, Loc
);
10939 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
10940 Conv
:= Make_Function_Call
(Loc
,
10941 New_Reference_To
(RTE
(RO_CA_To_Duration
), Loc
),
10942 New_List
(New_Reference_To
(Delay_Min
, Loc
)));
10946 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
10948 Conv
:= Make_Function_Call
(Loc
,
10949 New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
10950 New_List
(New_Reference_To
(Delay_Min
, Loc
)));
10953 Stmt
:= Make_Assignment_Statement
(Loc
,
10954 Name
=> New_Reference_To
(D
, Loc
),
10955 Expression
=> Conv
);
10957 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
10959 Parms
:= Parameter_Associations
(Select_Call
);
10960 Parm
:= First
(Parms
);
10962 while Present
(Parm
) and then Parm
/= Select_Mode
loop
10966 pragma Assert
(Present
(Parm
));
10967 Rewrite
(Parm
, New_Reference_To
(RTE
(RE_Delay_Mode
), Loc
));
10970 -- Prepare two new parameters of Duration and Delay_Mode type
10971 -- which represent the value and the mode of the minimum delay.
10974 Insert_After
(Parm
, New_Reference_To
(M
, Loc
));
10975 Insert_After
(Parm
, New_Reference_To
(D
, Loc
));
10977 -- Create a call to RTS
10979 Rewrite
(Select_Call
,
10980 Make_Procedure_Call_Statement
(Loc
,
10981 Name
=> New_Reference_To
(RTE
(RE_Timed_Selective_Wait
), Loc
),
10982 Parameter_Associations
=> Parms
));
10984 -- This new call should follow the calculation of the minimum
10987 Insert_List_Before
(Select_Call
, Delay_List
);
10989 if Check_Guard
then
10991 Make_Implicit_If_Statement
(N
,
10992 Condition
=> New_Reference_To
(Guard_Open
, Loc
),
10993 Then_Statements
=> New_List
(
10994 New_Copy_Tree
(Stmt
),
10995 New_Copy_Tree
(Select_Call
)),
10996 Else_Statements
=> Accept_Or_Raise
);
10997 Rewrite
(Select_Call
, Stmt
);
10999 Insert_Before
(Select_Call
, Stmt
);
11003 Make_Implicit_If_Statement
(N
,
11004 Condition
=> Make_Op_Eq
(Loc
,
11005 Left_Opnd
=> New_Reference_To
(Xnam
, Loc
),
11007 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
)),
11009 Then_Statements
=> Delay_Case
,
11010 Else_Statements
=> Accept_Case
);
11012 Append
(Cases
, Stats
);
11015 Append
(End_Lab
, Stats
);
11017 -- Replace accept statement with appropriate block
11020 Make_Block_Statement
(Loc
,
11021 Declarations
=> Decls
,
11022 Handled_Statement_Sequence
=>
11023 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11026 -- Note: have to worry more about abort deferral in above code ???
11028 -- Final step is to unstack the Accept_Address entries for all accept
11029 -- statements appearing in accept alternatives in the select statement
11031 Alt
:= First
(Alts
);
11032 while Present
(Alt
) loop
11033 if Nkind
(Alt
) = N_Accept_Alternative
then
11034 Remove_Last_Elmt
(Accept_Address
11035 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11040 end Expand_N_Selective_Accept
;
11042 --------------------------------------
11043 -- Expand_N_Single_Task_Declaration --
11044 --------------------------------------
11046 -- Single task declarations should never be present after semantic
11047 -- analysis, since we expect them to be replaced by a declaration of an
11048 -- anonymous task type, followed by a declaration of the task object. We
11049 -- include this routine to make sure that is happening!
11051 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11053 raise Program_Error
;
11054 end Expand_N_Single_Task_Declaration
;
11056 ------------------------
11057 -- Expand_N_Task_Body --
11058 ------------------------
11060 -- Given a task body
11062 -- task body tname is
11068 -- This expansion routine converts it into a procedure and sets the
11069 -- elaboration flag for the procedure to true, to represent the fact
11070 -- that the task body is now elaborated:
11072 -- procedure tnameB (_Task : access tnameV) is
11073 -- discriminal : dtype renames _Task.discriminant;
11075 -- procedure _clean is
11077 -- Abort_Defer.all;
11079 -- Abort_Undefer.all;
11084 -- Abort_Undefer.all;
11086 -- System.Task_Stages.Complete_Activation;
11094 -- In addition, if the task body is an activator, then a call to activate
11095 -- tasks is added at the start of the statements, before the call to
11096 -- Complete_Activation, and if in addition the task is a master then it
11097 -- must be established as a master. These calls are inserted and analyzed
11098 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11101 -- There is one discriminal declaration line generated for each
11102 -- discriminant that is present to provide an easy reference point for
11103 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11105 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11106 -- task body procedures have a profile (Arg : System.Address). That is
11107 -- needed because GNARLI has to use the same access-to-subprogram type
11108 -- for all task types. We depend here on knowing that in GNAT, passing
11109 -- an address argument by value is identical to passing a record value
11110 -- by access (in either case a single pointer is passed), so even though
11111 -- this procedure has the wrong profile. In fact it's all OK, since the
11112 -- callings sequence is identical.
11114 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11115 Loc
: constant Source_Ptr
:= Sloc
(N
);
11116 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11120 Insert_Nod
: Node_Id
;
11121 -- Used to determine the proper location of wrapper body insertions
11124 -- Add renaming declarations for discriminals and a declaration for the
11125 -- entry family index (if applicable).
11127 Install_Private_Data_Declarations
11128 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11130 -- Add a call to Abort_Undefer at the very beginning of the task
11131 -- body since this body is called with abort still deferred.
11133 if Abort_Allowed
then
11134 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11136 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11140 -- The statement part has already been protected with an at_end and
11141 -- cleanup actions. The call to Complete_Activation must be placed
11142 -- at the head of the sequence of statements of that block. The
11143 -- declarations have been merged in this sequence of statements but
11144 -- the first real statement is accessible from the First_Real_Statement
11145 -- field (which was set for exactly this purpose).
11147 if Restricted_Profile
then
11148 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11150 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11154 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11158 Make_Subprogram_Body
(Loc
,
11159 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11160 Declarations
=> Declarations
(N
),
11161 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11163 -- If the task contains generic instantiations, cleanup actions are
11164 -- delayed until after instantiation. Transfer the activation chain to
11165 -- the subprogram, to insure that the activation call is properly
11166 -- generated. It the task body contains inner tasks, indicate that the
11167 -- subprogram is a task master.
11169 if Delay_Cleanups
(Ttyp
) then
11170 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11171 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11174 Rewrite
(N
, New_N
);
11177 -- Set elaboration flag immediately after task body. If the body is a
11178 -- subunit, the flag is set in the declarative part containing the stub.
11180 if Nkind
(Parent
(N
)) /= N_Subunit
then
11182 Make_Assignment_Statement
(Loc
,
11184 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11185 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
11188 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11189 -- the task body. At this point all wrapper specs have been created,
11190 -- frozen and included in the dispatch table for the task type.
11192 if Ada_Version
>= Ada_2005
then
11193 if Nkind
(Parent
(N
)) = N_Subunit
then
11194 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11199 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11201 end Expand_N_Task_Body
;
11203 ------------------------------------
11204 -- Expand_N_Task_Type_Declaration --
11205 ------------------------------------
11207 -- We have several things to do. First we must create a Boolean flag used
11208 -- to mark if the body is elaborated yet. This variable gets set to True
11209 -- when the body of the task is elaborated (we can't rely on the normal
11210 -- ABE mechanism for the task body, since we need to pass an access to
11211 -- this elaboration boolean to the runtime routines).
11213 -- taskE : aliased Boolean := False;
11215 -- Next a variable is declared to hold the task stack size (either the
11216 -- default : Unspecified_Size, or a value that is set by a pragma
11217 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11218 -- the variable is initialized with this value:
11220 -- taskZ : Size_Type := Unspecified_Size;
11222 -- taskZ : Size_Type := Size_Type (size_expression);
11224 -- Note: No variable is needed to hold the task relative deadline since
11225 -- its value would never be static because the parameter is of a private
11226 -- type (Ada.Real_Time.Time_Span).
11228 -- Next we create a corresponding record type declaration used to represent
11229 -- values of this task. The general form of this type declaration is
11231 -- type taskV (discriminants) is record
11232 -- _Task_Id : Task_Id;
11233 -- entry_family : array (bounds) of Void;
11234 -- _Priority : Integer := priority_expression;
11235 -- _Size : Size_Type := size_expression;
11236 -- _Task_Info : Task_Info_Type := task_info_expression;
11237 -- _CPU : Integer := cpu_range_expression;
11238 -- _Relative_Deadline : Time_Span := time_span_expression;
11239 -- _Domain : Dispatching_Domain := dd_expression;
11242 -- The discriminants are present only if the corresponding task type has
11243 -- discriminants, and they exactly mirror the task type discriminants.
11245 -- The Id field is always present. It contains the Task_Id value, as set by
11246 -- the call to Create_Task. Note that although the task is limited, the
11247 -- task value record type is not limited, so there is no problem in passing
11248 -- this field as an out parameter to Create_Task.
11250 -- One entry_family component is present for each entry family in the task
11251 -- definition. The bounds correspond to the bounds of the entry family
11252 -- (which may depend on discriminants). The element type is void, since we
11253 -- only need the bounds information for determining the entry index. Note
11254 -- that the use of an anonymous array would normally be illegal in this
11255 -- context, but this is a parser check, and the semantics is quite prepared
11256 -- to handle such a case.
11258 -- The _Size field is present only if a Storage_Size pragma appears in the
11259 -- task definition. The expression captures the argument that was present
11260 -- in the pragma, and is used to override the task stack size otherwise
11261 -- associated with the task type.
11263 -- The _Priority field is present only if the task entity has a Priority or
11264 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11265 -- definition clause). It will be filled at the freeze point, when the
11266 -- record init proc is built, to capture the expression of the rep item
11267 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11268 -- here since aspect evaluations are delayed till the freeze point.
11270 -- The _Task_Info field is present only if a Task_Info pragma appears in
11271 -- the task definition. The expression captures the argument that was
11272 -- present in the pragma, and is used to provide the Task_Image parameter
11273 -- to the call to Create_Task.
11275 -- The _CPU field is present only if the task entity has a CPU rep item
11276 -- (pragma, aspect specification or attribute definition clause). It will
11277 -- be filled at the freeze point, when the record init proc is built, to
11278 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11279 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11280 -- are delayed till the freeze point.
11282 -- The _Relative_Deadline field is present only if a Relative_Deadline
11283 -- pragma appears in the task definition. The expression captures the
11284 -- argument that was present in the pragma, and is used to provide the
11285 -- Relative_Deadline parameter to the call to Create_Task.
11287 -- The _Domain field is present only if the task entity has a
11288 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11289 -- definition clause). It will be filled at the freeze point, when the
11290 -- record init proc is built, to capture the expression of the rep item
11291 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11292 -- here since aspect evaluations are delayed till the freeze point.
11294 -- When a task is declared, an instance of the task value record is
11295 -- created. The elaboration of this declaration creates the correct bounds
11296 -- for the entry families, and also evaluates the size, priority, and
11297 -- task_Info expressions if needed. The initialization routine for the task
11298 -- type itself then calls Create_Task with appropriate parameters to
11299 -- initialize the value of the Task_Id field.
11301 -- Note: the address of this record is passed as the "Discriminants"
11302 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11303 -- body procedure, it does not matter that it does not quite match the
11304 -- GNARLI model of what is being passed (the record contains more than just
11305 -- the discriminants, but the discriminants can be found from the record
11308 -- The Entity_Id for this created record type is placed in the
11309 -- Corresponding_Record_Type field of the associated task type entity.
11311 -- Next we create a procedure specification for the task body procedure:
11313 -- procedure taskB (_Task : access taskV);
11315 -- Note that this must come after the record type declaration, since
11316 -- the spec refers to this type. It turns out that the initialization
11317 -- procedure for the value type references the task body spec, but that's
11318 -- fine, since it won't be generated till the freeze point for the type,
11319 -- which is certainly after the task body spec declaration.
11321 -- Finally, we set the task index value field of the entry attribute in
11322 -- the case of a simple entry.
11324 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
11325 Loc
: constant Source_Ptr
:= Sloc
(N
);
11326 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
11327 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
11328 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
11329 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
11331 Body_Decl
: Node_Id
;
11333 Decl_Stack
: Node_Id
;
11334 Elab_Decl
: Node_Id
;
11335 Ent_Stack
: Entity_Id
;
11336 Proc_Spec
: Node_Id
;
11337 Rec_Decl
: Node_Id
;
11338 Rec_Ent
: Entity_Id
;
11339 Size_Decl
: Entity_Id
;
11340 Task_Size
: Node_Id
;
11342 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
11343 -- Searches the task definition T for the first occurrence of the pragma
11344 -- Relative Deadline. The caller has ensured that the pragma is present
11345 -- in the task definition. Note that this routine cannot be implemented
11346 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11347 -- not chained because their expansion into a procedure call statement
11348 -- would cause a break in the chain.
11350 ----------------------------------
11351 -- Get_Relative_Deadline_Pragma --
11352 ----------------------------------
11354 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
11358 N
:= First
(Visible_Declarations
(T
));
11359 while Present
(N
) loop
11360 if Nkind
(N
) = N_Pragma
11361 and then Pragma_Name
(N
) = Name_Relative_Deadline
11369 N
:= First
(Private_Declarations
(T
));
11370 while Present
(N
) loop
11371 if Nkind
(N
) = N_Pragma
11372 and then Pragma_Name
(N
) = Name_Relative_Deadline
11380 raise Program_Error
;
11381 end Get_Relative_Deadline_Pragma
;
11383 -- Start of processing for Expand_N_Task_Type_Declaration
11386 -- If already expanded, nothing to do
11388 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
11392 -- Here we will do the expansion
11394 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
11396 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
11397 Cdecls
:= Component_Items
(Component_List
11398 (Type_Definition
(Rec_Decl
)));
11400 Qualify_Entity_Names
(N
);
11402 -- First create the elaboration variable
11405 Make_Object_Declaration
(Loc
,
11406 Defining_Identifier
=>
11407 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11408 Chars
=> New_External_Name
(Tasknm
, 'E')),
11409 Aliased_Present
=> True,
11410 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
11411 Expression
=> New_Reference_To
(Standard_False
, Loc
));
11413 Insert_After
(N
, Elab_Decl
);
11415 -- Next create the declaration of the size variable (tasknmZ)
11417 Set_Storage_Size_Variable
(Tasktyp
,
11418 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11419 Chars
=> New_External_Name
(Tasknm
, 'Z')));
11421 if Present
(Taskdef
)
11422 and then Has_Storage_Size_Pragma
(Taskdef
)
11424 Is_Static_Expression
11426 (First
(Pragma_Argument_Associations
11427 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
11430 Make_Object_Declaration
(Loc
,
11431 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11432 Object_Definition
=> New_Reference_To
(RTE
(RE_Size_Type
), Loc
),
11434 Convert_To
(RTE
(RE_Size_Type
),
11436 (Expression
(First
(Pragma_Argument_Associations
11438 (TaskId
, Name_Storage_Size
)))))));
11442 Make_Object_Declaration
(Loc
,
11443 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11444 Object_Definition
=>
11445 New_Reference_To
(RTE
(RE_Size_Type
), Loc
),
11447 New_Reference_To
(RTE
(RE_Unspecified_Size
), Loc
));
11450 Insert_After
(Elab_Decl
, Size_Decl
);
11452 -- Next build the rest of the corresponding record declaration. This is
11453 -- done last, since the corresponding record initialization procedure
11454 -- will reference the previously created entities.
11456 -- Fill in the component declarations -- first the _Task_Id field
11459 Make_Component_Declaration
(Loc
,
11460 Defining_Identifier
=>
11461 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
11462 Component_Definition
=>
11463 Make_Component_Definition
(Loc
,
11464 Aliased_Present
=> False,
11465 Subtype_Indication
=> New_Reference_To
(RTE
(RO_ST_Task_Id
),
11468 -- Declare static ATCB (that is, created by the expander) if we are
11469 -- using the Restricted run time.
11471 if Restricted_Profile
then
11473 Make_Component_Declaration
(Loc
,
11474 Defining_Identifier
=>
11475 Make_Defining_Identifier
(Loc
, Name_uATCB
),
11477 Component_Definition
=>
11478 Make_Component_Definition
(Loc
,
11479 Aliased_Present
=> True,
11480 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
11482 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
11485 Make_Index_Or_Discriminant_Constraint
(Loc
,
11487 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
11491 -- Declare static stack (that is, created by the expander) if we are
11492 -- using the Restricted run time on a bare board configuration.
11494 if Restricted_Profile
11495 and then Preallocated_Stacks_On_Target
11497 -- First we need to extract the appropriate stack size
11499 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
11501 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
11503 Expr_N
: constant Node_Id
:=
11504 Expression
(First
(
11505 Pragma_Argument_Associations
(
11506 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
11507 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
11508 P
: constant Node_Id
:= Parent
(Expr_N
);
11511 -- The stack is defined inside the corresponding record.
11512 -- Therefore if the size of the stack is set by means of
11513 -- a discriminant, we must reference the discriminant of the
11514 -- corresponding record type.
11516 if Nkind
(Expr_N
) in N_Has_Entity
11517 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
11521 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
11523 Set_Parent
(Task_Size
, P
);
11524 Set_Etype
(Task_Size
, Etyp
);
11525 Set_Analyzed
(Task_Size
);
11528 Task_Size
:= Relocate_Node
(Expr_N
);
11534 New_Reference_To
(RTE
(RE_Default_Stack_Size
), Loc
);
11537 Decl_Stack
:= Make_Component_Declaration
(Loc
,
11538 Defining_Identifier
=> Ent_Stack
,
11540 Component_Definition
=>
11541 Make_Component_Definition
(Loc
,
11542 Aliased_Present
=> True,
11543 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
11545 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
11548 Make_Index_Or_Discriminant_Constraint
(Loc
,
11549 Constraints
=> New_List
(Make_Range
(Loc
,
11550 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
11551 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
11554 Append_To
(Cdecls
, Decl_Stack
);
11556 -- The appropriate alignment for the stack is ensured by the run-time
11557 -- code in charge of task creation.
11561 -- Add components for entry families
11563 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
11565 -- Add the _Priority component if a Interrupt_Priority or Priority rep
11566 -- item is present.
11568 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
11570 Make_Component_Declaration
(Loc
,
11571 Defining_Identifier
=>
11572 Make_Defining_Identifier
(Loc
, Name_uPriority
),
11573 Component_Definition
=>
11574 Make_Component_Definition
(Loc
,
11575 Aliased_Present
=> False,
11576 Subtype_Indication
=>
11577 New_Reference_To
(Standard_Integer
, Loc
))));
11580 -- Add the _Size component if a Storage_Size pragma is present
11582 if Present
(Taskdef
)
11583 and then Has_Storage_Size_Pragma
(Taskdef
)
11586 Make_Component_Declaration
(Loc
,
11587 Defining_Identifier
=>
11588 Make_Defining_Identifier
(Loc
, Name_uSize
),
11590 Component_Definition
=>
11591 Make_Component_Definition
(Loc
,
11592 Aliased_Present
=> False,
11593 Subtype_Indication
=>
11594 New_Reference_To
(RTE
(RE_Size_Type
), Loc
)),
11597 Convert_To
(RTE
(RE_Size_Type
),
11599 Expression
(First
(
11600 Pragma_Argument_Associations
(
11601 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
11604 -- Add the _Task_Info component if a Task_Info pragma is present
11606 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
11608 Make_Component_Declaration
(Loc
,
11609 Defining_Identifier
=>
11610 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
11612 Component_Definition
=>
11613 Make_Component_Definition
(Loc
,
11614 Aliased_Present
=> False,
11615 Subtype_Indication
=>
11616 New_Reference_To
(RTE
(RE_Task_Info_Type
), Loc
)),
11618 Expression
=> New_Copy
(
11619 Expression
(First
(
11620 Pragma_Argument_Associations
(
11622 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
11625 -- Add the _CPU component if a CPU rep item is present
11627 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
11629 Make_Component_Declaration
(Loc
,
11630 Defining_Identifier
=>
11631 Make_Defining_Identifier
(Loc
, Name_uCPU
),
11633 Component_Definition
=>
11634 Make_Component_Definition
(Loc
,
11635 Aliased_Present
=> False,
11636 Subtype_Indication
=>
11637 New_Reference_To
(RTE
(RE_CPU_Range
), Loc
))));
11640 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
11641 -- present. If we are using a restricted run time this component will
11642 -- not be added (deadlines are not allowed by the Ravenscar profile).
11644 if not Restricted_Profile
11645 and then Present
(Taskdef
)
11646 and then Has_Relative_Deadline_Pragma
(Taskdef
)
11649 Make_Component_Declaration
(Loc
,
11650 Defining_Identifier
=>
11651 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
11653 Component_Definition
=>
11654 Make_Component_Definition
(Loc
,
11655 Aliased_Present
=> False,
11656 Subtype_Indication
=>
11657 New_Reference_To
(RTE
(RE_Time_Span
), Loc
)),
11660 Convert_To
(RTE
(RE_Time_Span
),
11662 Expression
(First
(
11663 Pragma_Argument_Associations
(
11664 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
11667 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
11668 -- item is present. If we are using a restricted run time this component
11669 -- will not be added (dispatching domains are not allowed by the
11670 -- Ravenscar profile).
11672 if not Restricted_Profile
11675 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
11678 Make_Component_Declaration
(Loc
,
11679 Defining_Identifier
=>
11680 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
11682 Component_Definition
=>
11683 Make_Component_Definition
(Loc
,
11684 Aliased_Present
=> False,
11685 Subtype_Indication
=>
11687 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
11690 Insert_After
(Size_Decl
, Rec_Decl
);
11692 -- Analyze the record declaration immediately after construction,
11693 -- because the initialization procedure is needed for single task
11694 -- declarations before the next entity is analyzed.
11696 Analyze
(Rec_Decl
);
11698 -- Create the declaration of the task body procedure
11700 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
11702 Make_Subprogram_Declaration
(Loc
,
11703 Specification
=> Proc_Spec
);
11705 Insert_After
(Rec_Decl
, Body_Decl
);
11707 -- The subprogram does not comes from source, so we have to indicate the
11708 -- need for debugging information explicitly.
11710 if Comes_From_Source
(Original_Node
(N
)) then
11711 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
11714 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
11715 -- the corresponding record has been frozen.
11717 if Ada_Version
>= Ada_2005
then
11718 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
11721 -- Ada 2005 (AI-345): We must defer freezing to allow further
11722 -- declaration of primitive subprograms covering task interfaces
11724 if Ada_Version
<= Ada_95
then
11726 -- Now we can freeze the corresponding record. This needs manually
11727 -- freezing, since it is really part of the task type, and the task
11728 -- type is frozen at this stage. We of course need the initialization
11729 -- procedure for this corresponding record type and we won't get it
11730 -- in time if we don't freeze now.
11733 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
11735 if Is_Non_Empty_List
(L
) then
11736 Insert_List_After
(Body_Decl
, L
);
11741 -- Complete the expansion of access types to the current task type, if
11742 -- any were declared.
11744 Expand_Previous_Access_Type
(Tasktyp
);
11746 -- Create wrappers for entries that have pre/postconditions
11752 Ent
:= First_Entity
(Tasktyp
);
11753 while Present
(Ent
) loop
11754 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
)
11755 and then Present
(Spec_PPC_List
(Contract
(Ent
)))
11757 Build_PPC_Wrapper
(Ent
, N
);
11763 end Expand_N_Task_Type_Declaration
;
11765 -------------------------------
11766 -- Expand_N_Timed_Entry_Call --
11767 -------------------------------
11769 -- A timed entry call in normal case is not implemented using ATC mechanism
11770 -- anymore for efficiency reason.
11780 -- is expanded as follows:
11782 -- 1) When T.E is a task entry_call;
11786 -- X : Task_Entry_Index := <entry index>;
11787 -- DX : Duration := To_Duration (D);
11788 -- M : Delay_Mode := <discriminant>;
11789 -- P : parms := (parm, parm, parm);
11792 -- Timed_Protected_Entry_Call
11793 -- (<acceptor-task>, X, P'Address, DX, M, B);
11801 -- 2) When T.E is a protected entry_call;
11805 -- X : Protected_Entry_Index := <entry index>;
11806 -- DX : Duration := To_Duration (D);
11807 -- M : Delay_Mode := <discriminant>;
11808 -- P : parms := (parm, parm, parm);
11811 -- Timed_Protected_Entry_Call
11812 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
11820 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
11823 -- B : Boolean := False;
11824 -- C : Ada.Tags.Prim_Op_Kind;
11825 -- DX : Duration := To_Duration (D)
11826 -- K : Ada.Tags.Tagged_Kind :=
11827 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
11828 -- M : Integer :=...;
11829 -- P : Parameters := (Param1 .. ParamN);
11833 -- if K = Ada.Tags.TK_Limited_Tagged then
11834 -- <dispatching-call>;
11835 -- <triggering-statements>
11839 -- Ada.Tags.Get_Offset_Index
11840 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
11842 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
11844 -- if C = POK_Protected_Entry
11845 -- or else C = POK_Task_Entry
11847 -- Param1 := P.Param1;
11849 -- ParamN := P.ParamN;
11853 -- if C = POK_Procedure
11854 -- or else C = POK_Protected_Procedure
11855 -- or else C = POK_Task_Procedure
11857 -- <dispatching-call>;
11860 -- <triggering-statements>
11862 -- <timed-statements>
11867 -- The triggering statement and the sequence of timed statements have not
11868 -- been analyzed yet (see Analyzed_Timed_Entry_Call). They may contain
11869 -- local declarations, and therefore the copies that are made during
11870 -- expansion must be disjoint, as for any other inlining.
11872 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
11873 Loc
: constant Source_Ptr
:= Sloc
(N
);
11876 Blk_Typ
: Entity_Id
;
11878 Call_Ent
: Entity_Id
;
11879 Conc_Typ_Stmts
: List_Id
;
11881 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
11884 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
11886 D_Type
: Entity_Id
;
11889 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
11890 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
11895 Is_Disp_Select
: Boolean;
11896 Lim_Typ_Stmts
: List_Id
;
11905 B
: Entity_Id
; -- Call status flag
11906 C
: Entity_Id
; -- Call kind
11907 D
: Entity_Id
; -- Delay
11908 K
: Entity_Id
; -- Tagged kind
11909 M
: Entity_Id
; -- Delay mode
11910 P
: Entity_Id
; -- Parameter block
11911 S
: Entity_Id
; -- Primitive operation slot
11914 -- Under the Ravenscar profile, timed entry calls are excluded. An error
11915 -- was already reported on spec, so do not attempt to expand the call.
11917 if Restriction_Active
(No_Select_Statements
) then
11921 Process_Statements_For_Controlled_Objects
(E_Alt
);
11922 Process_Statements_For_Controlled_Objects
(D_Alt
);
11924 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
11926 -- Retrieve E_Stats and D_Stats now because the finalization machinery
11927 -- may wrap them in blocks.
11929 E_Stats
:= Statements
(E_Alt
);
11930 D_Stats
:= Statements
(D_Alt
);
11932 -- The arguments in the call may require dynamic allocation, and the
11933 -- call statement may have been transformed into a block. The block
11934 -- may contain additional declarations for internal entities, and the
11935 -- original call is found by sequential search.
11937 if Nkind
(E_Call
) = N_Block_Statement
then
11938 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
11939 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
11940 N_Entry_Call_Statement
)
11947 Ada_Version
>= Ada_2005
11948 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
11950 if Is_Disp_Select
then
11951 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
11957 -- B : Boolean := False;
11959 B
:= Build_B
(Loc
, Decls
);
11962 -- C : Ada.Tags.Prim_Op_Kind;
11964 C
:= Build_C
(Loc
, Decls
);
11966 -- Because the analysis of all statements was disabled, manually
11967 -- analyze the delay statement.
11970 D_Stat
:= Original_Node
(D_Stat
);
11973 -- Build an entry call using Simple_Entry_Call
11975 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
11976 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
11978 Decls
:= Declarations
(E_Call
);
11979 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
11988 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
11991 Make_Object_Declaration
(Loc
,
11992 Defining_Identifier
=> B
,
11993 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)));
11996 -- Duration and mode processing
11998 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12000 -- Use the type of the delay expression (Calendar or Real_Time) to
12001 -- generate the appropriate conversion.
12003 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12004 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12005 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12007 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12008 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12010 Make_Function_Call
(Loc
,
12011 Name
=> New_Reference_To
(RTE
(RO_CA_To_Duration
), Loc
),
12012 Parameter_Associations
=>
12013 New_List
(New_Copy
(Expression
(D_Stat
))));
12015 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12016 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12018 Make_Function_Call
(Loc
,
12019 Name
=> New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
12020 Parameter_Associations
=>
12021 New_List
(New_Copy
(Expression
(D_Stat
))));
12024 D
:= Make_Temporary
(Loc
, 'D');
12030 Make_Object_Declaration
(Loc
,
12031 Defining_Identifier
=> D
,
12032 Object_Definition
=> New_Reference_To
(Standard_Duration
, Loc
)));
12034 M
:= Make_Temporary
(Loc
, 'M');
12037 -- M : Integer := (0 | 1 | 2);
12040 Make_Object_Declaration
(Loc
,
12041 Defining_Identifier
=> M
,
12042 Object_Definition
=> New_Reference_To
(Standard_Integer
, Loc
),
12043 Expression
=> D_Disc
));
12045 -- Do the assignment at this stage only because the evaluation of the
12046 -- expression must not occur before (see ACVC C97302A).
12049 Make_Assignment_Statement
(Loc
,
12050 Name
=> New_Reference_To
(D
, Loc
),
12051 Expression
=> D_Conv
));
12053 -- Parameter block processing
12055 -- Manually create the parameter block for dispatching calls. In the
12056 -- case of entries, the block has already been created during the call
12057 -- to Build_Simple_Entry_Call.
12059 if Is_Disp_Select
then
12061 -- Tagged kind processing, generate:
12062 -- K : Ada.Tags.Tagged_Kind :=
12063 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12065 K
:= Build_K
(Loc
, Decls
, Obj
);
12067 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12069 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12071 -- Dispatch table slot processing, generate:
12074 S
:= Build_S
(Loc
, Decls
);
12077 -- S := Ada.Tags.Get_Offset_Index
12078 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12081 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12084 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12086 -- where Obj is the controlling formal parameter, S is the dispatch
12087 -- table slot number of the dispatching operation, P is the wrapped
12088 -- parameter block, D is the duration, M is the duration mode, C is
12089 -- the call kind and B is the call status.
12091 Params
:= New_List
;
12093 Append_To
(Params
, New_Copy_Tree
(Obj
));
12094 Append_To
(Params
, New_Reference_To
(S
, Loc
));
12096 Make_Attribute_Reference
(Loc
,
12097 Prefix
=> New_Reference_To
(P
, Loc
),
12098 Attribute_Name
=> Name_Address
));
12099 Append_To
(Params
, New_Reference_To
(D
, Loc
));
12100 Append_To
(Params
, New_Reference_To
(M
, Loc
));
12101 Append_To
(Params
, New_Reference_To
(C
, Loc
));
12102 Append_To
(Params
, New_Reference_To
(B
, Loc
));
12104 Append_To
(Conc_Typ_Stmts
,
12105 Make_Procedure_Call_Statement
(Loc
,
12109 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12110 Parameter_Associations
=> Params
));
12113 -- if C = POK_Protected_Entry
12114 -- or else C = POK_Task_Entry
12116 -- Param1 := P.Param1;
12118 -- ParamN := P.ParamN;
12121 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12123 -- Generate the if statement only when the packed parameters need
12124 -- explicit assignments to their corresponding actuals.
12126 if Present
(Unpack
) then
12127 Append_To
(Conc_Typ_Stmts
,
12128 Make_Implicit_If_Statement
(N
,
12134 Left_Opnd
=> New_Reference_To
(C
, Loc
),
12137 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12141 Left_Opnd
=> New_Reference_To
(C
, Loc
),
12143 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
12145 Then_Statements
=> Unpack
));
12151 -- if C = POK_Procedure
12152 -- or else C = POK_Protected_Procedure
12153 -- or else C = POK_Task_Procedure
12155 -- <dispatching-call>
12157 -- <triggering-statements>
12159 -- <timed-statements>
12162 N_Stats
:= Copy_Separate_List
(E_Stats
);
12164 Prepend_To
(N_Stats
,
12165 Make_Implicit_If_Statement
(N
,
12171 Left_Opnd
=> New_Reference_To
(C
, Loc
),
12173 New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
)),
12179 Left_Opnd
=> New_Reference_To
(C
, Loc
),
12181 New_Reference_To
(RTE
(
12182 RE_POK_Protected_Procedure
), Loc
)),
12185 Left_Opnd
=> New_Reference_To
(C
, Loc
),
12188 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12190 Then_Statements
=> New_List
(E_Call
)));
12192 Append_To
(Conc_Typ_Stmts
,
12193 Make_Implicit_If_Statement
(N
,
12194 Condition
=> New_Reference_To
(B
, Loc
),
12195 Then_Statements
=> N_Stats
,
12196 Else_Statements
=> D_Stats
));
12199 -- <dispatching-call>;
12200 -- <triggering-statements>
12202 Lim_Typ_Stmts
:= Copy_Separate_List
(E_Stats
);
12203 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(E_Call
));
12206 -- if K = Ada.Tags.TK_Limited_Tagged then
12213 Make_Implicit_If_Statement
(N
,
12216 Left_Opnd
=> New_Reference_To
(K
, Loc
),
12218 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
12219 Then_Statements
=> Lim_Typ_Stmts
,
12220 Else_Statements
=> Conc_Typ_Stmts
));
12223 -- Skip assignments to temporaries created for in-out parameters.
12224 -- This makes unwarranted assumptions about the shape of the expanded
12225 -- tree for the call, and should be cleaned up ???
12227 Stmt
:= First
(Stmts
);
12228 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
12232 -- Do the assignment at this stage only because the evaluation
12233 -- of the expression must not occur before (see ACVC C97302A).
12235 Insert_Before
(Stmt
,
12236 Make_Assignment_Statement
(Loc
,
12237 Name
=> New_Reference_To
(D
, Loc
),
12238 Expression
=> D_Conv
));
12241 Params
:= Parameter_Associations
(Call
);
12243 -- For a protected type, we build a Timed_Protected_Entry_Call
12245 if Is_Protected_Type
(Etype
(Concval
)) then
12247 -- Create a new call statement
12249 Param
:= First
(Params
);
12250 while Present
(Param
)
12251 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
12256 Dummy
:= Remove_Next
(Next
(Param
));
12258 -- Remove garbage is following the Cancel_Param if present
12260 Dummy
:= Next
(Param
);
12262 -- Remove the mode of the Protected_Entry_Call call, then remove
12263 -- the Communication_Block of the Protected_Entry_Call call, and
12264 -- finally add Duration and a Delay_Mode parameter
12266 pragma Assert
(Present
(Param
));
12267 Rewrite
(Param
, New_Reference_To
(D
, Loc
));
12269 Rewrite
(Dummy
, New_Reference_To
(M
, Loc
));
12271 -- Add a Boolean flag for successful entry call
12273 Append_To
(Params
, New_Reference_To
(B
, Loc
));
12275 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
12276 when System_Tasking_Protected_Objects_Entries
=>
12278 Make_Procedure_Call_Statement
(Loc
,
12281 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
12282 Parameter_Associations
=> Params
));
12284 when System_Tasking_Protected_Objects_Single_Entry
=>
12285 Param
:= First
(Params
);
12286 while Present
(Param
)
12288 Is_RTE
(Etype
(Param
), RE_Protected_Entry_Index
)
12296 Make_Procedure_Call_Statement
(Loc
,
12299 (RTE
(RE_Timed_Protected_Single_Entry_Call
), Loc
),
12300 Parameter_Associations
=> Params
));
12303 raise Program_Error
;
12306 -- For the task case, build a Timed_Task_Entry_Call
12309 -- Create a new call statement
12311 Append_To
(Params
, New_Reference_To
(D
, Loc
));
12312 Append_To
(Params
, New_Reference_To
(M
, Loc
));
12313 Append_To
(Params
, New_Reference_To
(B
, Loc
));
12316 Make_Procedure_Call_Statement
(Loc
,
12318 New_Reference_To
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
12319 Parameter_Associations
=> Params
));
12323 Make_Implicit_If_Statement
(N
,
12324 Condition
=> New_Reference_To
(B
, Loc
),
12325 Then_Statements
=> E_Stats
,
12326 Else_Statements
=> D_Stats
));
12330 Make_Block_Statement
(Loc
,
12331 Declarations
=> Decls
,
12332 Handled_Statement_Sequence
=>
12333 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
12336 end Expand_N_Timed_Entry_Call
;
12338 ----------------------------------------
12339 -- Expand_Protected_Body_Declarations --
12340 ----------------------------------------
12342 procedure Expand_Protected_Body_Declarations
12344 Spec_Id
: Entity_Id
)
12347 if No_Run_Time_Mode
then
12348 Error_Msg_CRT
("protected body", N
);
12351 elsif Full_Expander_Active
then
12353 -- Associate discriminals with the first subprogram or entry body to
12356 if Present
(First_Protected_Operation
(Declarations
(N
))) then
12357 Set_Discriminals
(Parent
(Spec_Id
));
12360 end Expand_Protected_Body_Declarations
;
12362 -------------------------
12363 -- External_Subprogram --
12364 -------------------------
12366 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
12367 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
12370 -- The internal and external subprograms follow each other on the entity
12371 -- chain. Note that previously private operations had no separate
12372 -- external subprogram. We now create one in all cases, because a
12373 -- private operation may actually appear in an external call, through
12374 -- a 'Access reference used for a callback.
12376 -- If the operation is a function that returns an anonymous access type,
12377 -- the corresponding itype appears before the operation, and must be
12380 -- This mechanism is fragile, there should be a real link between the
12381 -- two versions of the operation, but there is no place to put it ???
12383 if Is_Access_Type
(Next_Entity
(Subp
)) then
12384 return Next_Entity
(Next_Entity
(Subp
));
12386 return Next_Entity
(Subp
);
12388 end External_Subprogram
;
12390 ------------------------------
12391 -- Extract_Dispatching_Call --
12392 ------------------------------
12394 procedure Extract_Dispatching_Call
12396 Call_Ent
: out Entity_Id
;
12397 Object
: out Entity_Id
;
12398 Actuals
: out List_Id
;
12399 Formals
: out List_Id
)
12401 Call_Nam
: Node_Id
;
12404 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
12406 if Present
(Original_Node
(N
)) then
12407 Call_Nam
:= Name
(Original_Node
(N
));
12409 Call_Nam
:= Name
(N
);
12412 -- Retrieve the name of the dispatching procedure. It contains the
12413 -- dispatch table slot number.
12416 case Nkind
(Call_Nam
) is
12417 when N_Identifier
=>
12420 when N_Selected_Component
=>
12421 Call_Nam
:= Selector_Name
(Call_Nam
);
12424 raise Program_Error
;
12429 Actuals
:= Parameter_Associations
(N
);
12430 Call_Ent
:= Entity
(Call_Nam
);
12431 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
12432 Object
:= First
(Actuals
);
12434 if Present
(Original_Node
(Object
)) then
12435 Object
:= Original_Node
(Object
);
12438 -- If the type of the dispatching object is an access type then return
12439 -- an explicit dereference.
12441 if Is_Access_Type
(Etype
(Object
)) then
12442 Object
:= Make_Explicit_Dereference
(Sloc
(N
), Object
);
12445 end Extract_Dispatching_Call
;
12447 -------------------
12448 -- Extract_Entry --
12449 -------------------
12451 procedure Extract_Entry
12453 Concval
: out Node_Id
;
12454 Ename
: out Node_Id
;
12455 Index
: out Node_Id
)
12457 Nam
: constant Node_Id
:= Name
(N
);
12460 -- For a simple entry, the name is a selected component, with the
12461 -- prefix being the task value, and the selector being the entry.
12463 if Nkind
(Nam
) = N_Selected_Component
then
12464 Concval
:= Prefix
(Nam
);
12465 Ename
:= Selector_Name
(Nam
);
12468 -- For a member of an entry family, the name is an indexed component
12469 -- where the prefix is a selected component, whose prefix in turn is
12470 -- the task value, and whose selector is the entry family. The single
12471 -- expression in the expressions list of the indexed component is the
12472 -- subscript for the family.
12474 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
12475 Concval
:= Prefix
(Prefix
(Nam
));
12476 Ename
:= Selector_Name
(Prefix
(Nam
));
12477 Index
:= First
(Expressions
(Nam
));
12481 -------------------
12482 -- Family_Offset --
12483 -------------------
12485 function Family_Offset
12490 Cap
: Boolean) return Node_Id
12496 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
12497 -- If one of the bounds is a reference to a discriminant, replace with
12498 -- corresponding discriminal of type. Within the body of a task retrieve
12499 -- the renamed discriminant by simple visibility, using its generated
12500 -- name. Within a protected object, find the original discriminant and
12501 -- replace it with the discriminal of the current protected operation.
12503 ------------------------------
12504 -- Convert_Discriminant_Ref --
12505 ------------------------------
12507 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
12508 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
12513 if Is_Entity_Name
(Bound
)
12514 and then Ekind
(Entity
(Bound
)) = E_Discriminant
12516 if Is_Task_Type
(Ttyp
)
12517 and then Has_Completion
(Ttyp
)
12519 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
12520 Find_Direct_Name
(B
);
12522 elsif Is_Protected_Type
(Ttyp
) then
12523 D
:= First_Discriminant
(Ttyp
);
12524 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
12525 Next_Discriminant
(D
);
12528 B
:= New_Reference_To
(Discriminal
(D
), Loc
);
12531 B
:= New_Reference_To
(Discriminal
(Entity
(Bound
)), Loc
);
12534 elsif Nkind
(Bound
) = N_Attribute_Reference
then
12538 B
:= New_Copy_Tree
(Bound
);
12542 Make_Attribute_Reference
(Loc
,
12543 Attribute_Name
=> Name_Pos
,
12544 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
12545 Expressions
=> New_List
(B
));
12546 end Convert_Discriminant_Ref
;
12548 -- Start of processing for Family_Offset
12551 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
12552 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
12555 if Is_Task_Type
(Ttyp
) then
12556 Ityp
:= RTE
(RE_Task_Entry_Index
);
12558 Ityp
:= RTE
(RE_Protected_Entry_Index
);
12562 Make_Attribute_Reference
(Loc
,
12563 Prefix
=> New_Reference_To
(Ityp
, Loc
),
12564 Attribute_Name
=> Name_Min
,
12565 Expressions
=> New_List
(
12567 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
12570 Make_Attribute_Reference
(Loc
,
12571 Prefix
=> New_Reference_To
(Ityp
, Loc
),
12572 Attribute_Name
=> Name_Max
,
12573 Expressions
=> New_List
(
12575 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
12578 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
12585 function Family_Size
12590 Cap
: Boolean) return Node_Id
12595 if Is_Task_Type
(Ttyp
) then
12596 Ityp
:= RTE
(RE_Task_Entry_Index
);
12598 Ityp
:= RTE
(RE_Protected_Entry_Index
);
12602 Make_Attribute_Reference
(Loc
,
12603 Prefix
=> New_Reference_To
(Ityp
, Loc
),
12604 Attribute_Name
=> Name_Max
,
12605 Expressions
=> New_List
(
12608 Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
12610 Make_Integer_Literal
(Loc
, 1)),
12611 Make_Integer_Literal
(Loc
, 0)));
12614 ----------------------------
12615 -- Find_Enclosing_Context --
12616 ----------------------------
12618 procedure Find_Enclosing_Context
12620 Context
: out Node_Id
;
12621 Context_Id
: out Entity_Id
;
12622 Context_Decls
: out List_Id
)
12625 -- Traverse the parent chain looking for an enclosing body, block,
12626 -- package or return statement.
12628 Context
:= Parent
(N
);
12629 while not Nkind_In
(Context
, N_Block_Statement
,
12631 N_Extended_Return_Statement
,
12633 N_Package_Declaration
,
12637 Context
:= Parent
(Context
);
12640 -- Extract the constituents of the context
12642 if Nkind
(Context
) = N_Extended_Return_Statement
then
12643 Context_Decls
:= Return_Object_Declarations
(Context
);
12644 Context_Id
:= Return_Statement_Entity
(Context
);
12646 -- Package declarations and bodies use a common library-level activation
12647 -- chain or task master, therefore return the package declaration as the
12648 -- proper carrier for the appropriate flag.
12650 elsif Nkind
(Context
) = N_Package_Body
then
12651 Context_Decls
:= Declarations
(Context
);
12652 Context_Id
:= Corresponding_Spec
(Context
);
12653 Context
:= Parent
(Context_Id
);
12655 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
12656 Context
:= Parent
(Parent
(Context
));
12658 Context
:= Parent
(Context
);
12661 elsif Nkind
(Context
) = N_Package_Declaration
then
12662 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
12663 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
12665 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
12666 Context_Id
:= Defining_Identifier
(Context_Id
);
12670 Context_Decls
:= Declarations
(Context
);
12672 if Nkind
(Context
) = N_Block_Statement
then
12673 Context_Id
:= Entity
(Identifier
(Context
));
12675 elsif Nkind
(Context
) = N_Entry_Body
then
12676 Context_Id
:= Defining_Identifier
(Context
);
12678 elsif Nkind
(Context
) = N_Subprogram_Body
then
12679 if Present
(Corresponding_Spec
(Context
)) then
12680 Context_Id
:= Corresponding_Spec
(Context
);
12682 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
12684 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
12685 Context_Id
:= Defining_Identifier
(Context_Id
);
12689 elsif Nkind
(Context
) = N_Task_Body
then
12690 Context_Id
:= Corresponding_Spec
(Context
);
12693 raise Program_Error
;
12697 pragma Assert
(Present
(Context
));
12698 pragma Assert
(Present
(Context_Id
));
12699 pragma Assert
(Present
(Context_Decls
));
12700 end Find_Enclosing_Context
;
12702 -----------------------
12703 -- Find_Master_Scope --
12704 -----------------------
12706 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
12710 -- In Ada 2005, the master is the innermost enclosing scope that is not
12711 -- transient. If the enclosing block is the rewriting of a call or the
12712 -- scope is an extended return statement this is valid master. The
12713 -- master in an extended return is only used within the return, and is
12714 -- subsequently overwritten in Move_Activation_Chain, but it must exist
12715 -- now before that overwriting occurs.
12719 if Ada_Version
>= Ada_2005
then
12720 while Is_Internal
(S
) loop
12721 if Nkind
(Parent
(S
)) = N_Block_Statement
12723 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
12727 elsif Ekind
(S
) = E_Return_Statement
then
12737 end Find_Master_Scope
;
12739 -------------------------------
12740 -- First_Protected_Operation --
12741 -------------------------------
12743 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
12744 First_Op
: Node_Id
;
12747 First_Op
:= First
(D
);
12748 while Present
(First_Op
)
12749 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
12755 end First_Protected_Operation
;
12757 ---------------------------------------
12758 -- Install_Private_Data_Declarations --
12759 ---------------------------------------
12761 procedure Install_Private_Data_Declarations
12763 Spec_Id
: Entity_Id
;
12764 Conc_Typ
: Entity_Id
;
12765 Body_Nod
: Node_Id
;
12767 Barrier
: Boolean := False;
12768 Family
: Boolean := False)
12770 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
12773 Insert_Node
: Node_Id
:= Empty
;
12774 Obj_Ent
: Entity_Id
;
12776 procedure Add
(Decl
: Node_Id
);
12777 -- Add a single declaration after Insert_Node. If this is the first
12778 -- addition, Decl is added to the front of Decls and it becomes the
12781 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
12782 -- The bounds of an entry index may depend on discriminants, create a
12783 -- reference to the corresponding prival. Otherwise return a duplicate
12784 -- of the original bound.
12790 procedure Add
(Decl
: Node_Id
) is
12792 if No
(Insert_Node
) then
12793 Prepend_To
(Decls
, Decl
);
12795 Insert_After
(Insert_Node
, Decl
);
12798 Insert_Node
:= Decl
;
12801 --------------------------
12802 -- Replace_Discriminant --
12803 --------------------------
12805 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
12807 if Nkind
(Bound
) = N_Identifier
12808 and then Is_Discriminal
(Entity
(Bound
))
12810 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
12812 return Duplicate_Subexpr
(Bound
);
12816 -- Start of processing for Install_Private_Data_Declarations
12819 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
12820 -- formal parameter _O, _object or _task depending on the context.
12822 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
12824 -- Special processing of _O for barrier functions, protected entries
12831 (Ekind
(Spec_Id
) = E_Entry
12832 or else Ekind
(Spec_Id
) = E_Entry_Family
))
12835 Conc_Rec
: constant Entity_Id
:=
12836 Corresponding_Record_Type
(Conc_Typ
);
12837 Typ_Id
: constant Entity_Id
:=
12838 Make_Defining_Identifier
(Loc
,
12839 New_External_Name
(Chars
(Conc_Rec
), 'P'));
12842 -- type prot_typVP is access prot_typV;
12845 Make_Full_Type_Declaration
(Loc
,
12846 Defining_Identifier
=> Typ_Id
,
12848 Make_Access_To_Object_Definition
(Loc
,
12849 Subtype_Indication
=>
12850 New_Reference_To
(Conc_Rec
, Loc
)));
12854 -- _object : prot_typVP := prot_typV (_O);
12857 Make_Object_Declaration
(Loc
,
12858 Defining_Identifier
=>
12859 Make_Defining_Identifier
(Loc
, Name_uObject
),
12860 Object_Definition
=> New_Reference_To
(Typ_Id
, Loc
),
12862 Unchecked_Convert_To
(Typ_Id
,
12863 New_Reference_To
(Obj_Ent
, Loc
)));
12866 -- Set the reference to the concurrent object
12868 Obj_Ent
:= Defining_Identifier
(Decl
);
12872 -- Step 2: Create the Protection object and build its declaration for
12873 -- any protected entry (family) of subprogram. Note for the lock-free
12874 -- implementation, the Protection object is not needed anymore.
12876 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
12878 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
12882 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
12884 -- Determine the proper protection type
12886 if Has_Attach_Handler
(Conc_Typ
)
12887 and then not Restricted_Profile
12888 and then not Restriction_Active
(No_Dynamic_Attachment
)
12890 Prot_Typ
:= RE_Static_Interrupt_Protection
;
12892 elsif Has_Interrupt_Handler
(Conc_Typ
)
12893 and then not Restriction_Active
(No_Dynamic_Attachment
)
12895 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
12897 -- The type has explicit entries or generated primitive entry
12900 elsif Has_Entries
(Conc_Typ
)
12902 (Ada_Version
>= Ada_2005
12903 and then Present
(Interface_List
(Parent
(Conc_Typ
))))
12905 case Corresponding_Runtime_Package
(Conc_Typ
) is
12906 when System_Tasking_Protected_Objects_Entries
=>
12907 Prot_Typ
:= RE_Protection_Entries
;
12909 when System_Tasking_Protected_Objects_Single_Entry
=>
12910 Prot_Typ
:= RE_Protection_Entry
;
12913 raise Program_Error
;
12917 Prot_Typ
:= RE_Protection
;
12921 -- conc_typR : protection_typ renames _object._object;
12924 Make_Object_Renaming_Declaration
(Loc
,
12925 Defining_Identifier
=> Prot_Ent
,
12927 New_Reference_To
(RTE
(Prot_Typ
), Loc
),
12929 Make_Selected_Component
(Loc
,
12930 Prefix
=> New_Reference_To
(Obj_Ent
, Loc
),
12931 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
12936 -- Step 3: Add discriminant renamings (if any)
12938 if Has_Discriminants
(Conc_Typ
) then
12943 D
:= First_Discriminant
(Conc_Typ
);
12944 while Present
(D
) loop
12946 -- Adjust the source location
12948 Set_Sloc
(Discriminal
(D
), Loc
);
12951 -- discr_name : discr_typ renames _object.discr_name;
12953 -- discr_name : discr_typ renames _task.discr_name;
12956 Make_Object_Renaming_Declaration
(Loc
,
12957 Defining_Identifier
=> Discriminal
(D
),
12958 Subtype_Mark
=> New_Reference_To
(Etype
(D
), Loc
),
12960 Make_Selected_Component
(Loc
,
12961 Prefix
=> New_Reference_To
(Obj_Ent
, Loc
),
12962 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
12965 Next_Discriminant
(D
);
12970 -- Step 4: Add private component renamings (if any)
12972 if Is_Protected
then
12973 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
12975 if Present
(Private_Declarations
(Def
)) then
12978 Comp_Id
: Entity_Id
;
12979 Decl_Id
: Entity_Id
;
12982 Comp
:= First
(Private_Declarations
(Def
));
12983 while Present
(Comp
) loop
12984 if Nkind
(Comp
) = N_Component_Declaration
then
12985 Comp_Id
:= Defining_Identifier
(Comp
);
12987 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
12989 -- Minimal decoration
12991 if Ekind
(Spec_Id
) = E_Function
then
12992 Set_Ekind
(Decl_Id
, E_Constant
);
12994 Set_Ekind
(Decl_Id
, E_Variable
);
12997 Set_Prival
(Comp_Id
, Decl_Id
);
12998 Set_Prival_Link
(Decl_Id
, Comp_Id
);
12999 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13002 -- comp_name : comp_typ renames _object.comp_name;
13005 Make_Object_Renaming_Declaration
(Loc
,
13006 Defining_Identifier
=> Decl_Id
,
13008 New_Reference_To
(Etype
(Comp_Id
), Loc
),
13010 Make_Selected_Component
(Loc
,
13012 New_Reference_To
(Obj_Ent
, Loc
),
13014 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
13024 -- Step 5: Add the declaration of the entry index and the associated
13025 -- type for barrier functions and entry families.
13027 if (Barrier
and then Family
)
13028 or else Ekind
(Spec_Id
) = E_Entry_Family
13031 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13032 Index
: constant Entity_Id
:=
13033 Defining_Identifier
(
13034 Entry_Index_Specification
(
13035 Entry_Body_Formal_Part
(Body_Nod
)));
13036 Index_Con
: constant Entity_Id
:=
13037 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13039 Index_Typ
: Entity_Id
;
13043 -- Minimal decoration
13045 Set_Ekind
(Index_Con
, E_Constant
);
13046 Set_Entry_Index_Constant
(Index
, Index_Con
);
13047 Set_Discriminal_Link
(Index_Con
, Index
);
13049 -- Retrieve the bounds of the entry family
13051 High
:= Type_High_Bound
(Etype
(Index
));
13052 Low
:= Type_Low_Bound
(Etype
(Index
));
13054 -- In the simple case the entry family is given by a subtype
13055 -- mark and the index constant has the same type.
13057 if Is_Entity_Name
(Original_Node
(
13058 Discrete_Subtype_Definition
(Parent
(Index
))))
13060 Index_Typ
:= Etype
(Index
);
13062 -- Otherwise a new subtype declaration is required
13065 High
:= Replace_Bound
(High
);
13066 Low
:= Replace_Bound
(Low
);
13068 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13071 -- subtype Jnn is <Etype of Index> range Low .. High;
13074 Make_Subtype_Declaration
(Loc
,
13075 Defining_Identifier
=> Index_Typ
,
13076 Subtype_Indication
=>
13077 Make_Subtype_Indication
(Loc
,
13079 New_Reference_To
(Base_Type
(Etype
(Index
)), Loc
),
13081 Make_Range_Constraint
(Loc
,
13082 Range_Expression
=>
13083 Make_Range
(Loc
, Low
, High
))));
13087 Set_Etype
(Index_Con
, Index_Typ
);
13089 -- Create the object which designates the index:
13090 -- J : constant Jnn :=
13091 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13093 -- where Jnn is the subtype created above or the original type of
13094 -- the index, _E is a formal of the protected body subprogram and
13095 -- <index expr> is the index of the first family member.
13098 Make_Object_Declaration
(Loc
,
13099 Defining_Identifier
=> Index_Con
,
13100 Constant_Present
=> True,
13101 Object_Definition
=>
13102 New_Reference_To
(Index_Typ
, Loc
),
13105 Make_Attribute_Reference
(Loc
,
13107 New_Reference_To
(Index_Typ
, Loc
),
13108 Attribute_Name
=> Name_Val
,
13110 Expressions
=> New_List
(
13114 Make_Op_Subtract
(Loc
,
13116 New_Reference_To
(E
, Loc
),
13118 Entry_Index_Expression
(Loc
,
13119 Defining_Identifier
(Body_Nod
),
13123 Make_Attribute_Reference
(Loc
,
13125 New_Reference_To
(Index_Typ
, Loc
),
13126 Attribute_Name
=> Name_Pos
,
13127 Expressions
=> New_List
(
13128 Make_Attribute_Reference
(Loc
,
13130 New_Reference_To
(Index_Typ
, Loc
),
13131 Attribute_Name
=> Name_First
)))))));
13135 end Install_Private_Data_Declarations
;
13137 -----------------------
13138 -- Is_Exception_Safe --
13139 -----------------------
13141 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean is
13143 function Has_Side_Effect
(N
: Node_Id
) return Boolean;
13144 -- Return True whenever encountering a subprogram call or raise
13145 -- statement of any kind in the sequence of statements
13147 ---------------------
13148 -- Has_Side_Effect --
13149 ---------------------
13151 -- What is this doing buried two levels down in exp_ch9. It seems like a
13152 -- generally useful function, and indeed there may be code duplication
13153 -- going on here ???
13155 function Has_Side_Effect
(N
: Node_Id
) return Boolean is
13159 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean;
13160 -- Indicate whether N is a subprogram call or a raise statement
13162 ----------------------
13163 -- Is_Call_Or_Raise --
13164 ----------------------
13166 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean is
13168 return Nkind_In
(N
, N_Procedure_Call_Statement
,
13171 N_Raise_Constraint_Error
,
13172 N_Raise_Program_Error
,
13173 N_Raise_Storage_Error
);
13174 end Is_Call_Or_Raise
;
13176 -- Start of processing for Has_Side_Effect
13180 while Present
(Stmt
) loop
13181 if Is_Call_Or_Raise
(Stmt
) then
13185 -- An object declaration can also contain a function call or a
13186 -- raise statement.
13188 if Nkind
(Stmt
) = N_Object_Declaration
then
13189 Expr
:= Expression
(Stmt
);
13191 if Present
(Expr
) and then Is_Call_Or_Raise
(Expr
) then
13200 end Has_Side_Effect
;
13202 -- Start of processing for Is_Exception_Safe
13205 -- If the checks handled by the back end are not disabled, we cannot
13206 -- ensure that no exception will be raised.
13208 if not Access_Checks_Suppressed
(Empty
)
13209 or else not Discriminant_Checks_Suppressed
(Empty
)
13210 or else not Range_Checks_Suppressed
(Empty
)
13211 or else not Index_Checks_Suppressed
(Empty
)
13212 or else Opt
.Stack_Checking_Enabled
13217 if Has_Side_Effect
(First
(Declarations
(Subprogram
)))
13220 (First
(Statements
(Handled_Statement_Sequence
(Subprogram
))))
13226 end Is_Exception_Safe
;
13228 ---------------------------------
13229 -- Is_Potentially_Large_Family --
13230 ---------------------------------
13232 function Is_Potentially_Large_Family
13233 (Base_Index
: Entity_Id
;
13234 Conctyp
: Entity_Id
;
13236 Hi
: Node_Id
) return Boolean
13239 return Scope
(Base_Index
) = Standard_Standard
13240 and then Base_Index
= Base_Type
(Standard_Integer
)
13241 and then Has_Discriminants
(Conctyp
)
13243 Present
(Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
13245 (Denotes_Discriminant
(Lo
, True)
13247 Denotes_Discriminant
(Hi
, True));
13248 end Is_Potentially_Large_Family
;
13250 -------------------------------------
13251 -- Is_Private_Primitive_Subprogram --
13252 -------------------------------------
13254 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13257 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13258 and then Is_Private_Primitive
(Id
);
13259 end Is_Private_Primitive_Subprogram
;
13265 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13266 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13267 Formal
: Entity_Id
;
13270 Formal
:= First_Formal
(Bod_Subp
);
13271 while Present
(Formal
) loop
13273 -- Look for formal parameter _E
13275 if Chars
(Formal
) = Name_uE
then
13279 Next_Formal
(Formal
);
13282 -- A protected body subprogram should always have the parameter in
13285 raise Program_Error
;
13288 --------------------------------
13289 -- Make_Initialize_Protection --
13290 --------------------------------
13292 function Make_Initialize_Protection
13293 (Protect_Rec
: Entity_Id
) return List_Id
13295 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
13298 Ptyp
: constant Node_Id
:=
13299 Corresponding_Concurrent_Type
(Protect_Rec
);
13301 L
: constant List_Id
:= New_List
;
13302 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
13303 Restricted
: constant Boolean := Restricted_Profile
;
13306 -- We may need two calls to properly initialize the object, one to
13307 -- Initialize_Protection, and possibly one to Install_Handlers if we
13308 -- have a pragma Attach_Handler.
13310 -- Get protected declaration. In the case of a task type declaration,
13311 -- this is simply the parent of the protected type entity. In the single
13312 -- protected object declaration, this parent will be the implicit type,
13313 -- and we can find the corresponding single protected object declaration
13314 -- by searching forward in the declaration list in the tree.
13316 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13317 -- of this type should have been removed during semantic analysis.
13319 Pdec
:= Parent
(Ptyp
);
13320 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
13321 N_Single_Protected_Declaration
)
13326 -- Build the parameter list for the call. Note that _Init is the name
13327 -- of the formal for the object to be initialized, which is the task
13328 -- value record itself.
13332 -- For lock-free implementation, skip initializations of the Protection
13335 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13336 -- Object parameter. This is a pointer to the object of type
13337 -- Protection used by the GNARL to control the protected object.
13340 Make_Attribute_Reference
(Loc
,
13342 Make_Selected_Component
(Loc
,
13343 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13344 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
13345 Attribute_Name
=> Name_Unchecked_Access
));
13347 -- Priority parameter. Set to Unspecified_Priority unless there is a
13348 -- Priority rep item, in which case we take the value from the pragma
13349 -- or attribute definition clause, or there is an Interrupt_Priority
13350 -- rep item and no Priority rep item, and we set the ceiling to
13351 -- Interrupt_Priority'Last, an implementation-defined value, see
13354 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
13356 Prio_Clause
: constant Node_Id
:=
13358 (Ptyp
, Name_Priority
, Check_Parents
=> False);
13366 if Nkind
(Prio_Clause
) = N_Pragma
then
13369 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
13371 -- Attribute definition clause Priority
13374 Prio
:= Expression
(Prio_Clause
);
13377 -- If priority is a static expression, then we can duplicate it
13378 -- with no problem and simply append it to the argument list.
13380 if Is_Static_Expression
(Prio
) then
13382 Duplicate_Subexpr_No_Checks
(Prio
));
13384 -- Otherwise, the priority may be a per-object expression, if
13385 -- it depends on a discriminant of the type. In this case,
13386 -- create local variable to capture the expression. Note that
13387 -- it is really necessary to create this variable explicitly.
13388 -- It might be thought that removing side effects would the
13389 -- appropriate approach, but that could generate declarations
13390 -- improperly placed in the enclosing scope.
13392 -- Note: Use System.Any_Priority as the expected type for the
13393 -- non-static priority expression, in case the expression has
13394 -- not been analyzed yet (as occurs for example with pragma
13395 -- Interrupt_Priority).
13398 Temp
:= Make_Temporary
(Loc
, 'R', Prio
);
13400 Make_Object_Declaration
(Loc
,
13401 Defining_Identifier
=> Temp
,
13402 Object_Definition
=>
13403 New_Occurrence_Of
(RTE
(RE_Any_Priority
), Loc
),
13404 Expression
=> Relocate_Node
(Prio
)));
13406 Append_To
(Args
, New_Occurrence_Of
(Temp
, Loc
));
13410 -- When no priority is specified but an xx_Handler pragma is, we
13411 -- default to System.Interrupts.Default_Interrupt_Priority, see
13414 elsif Has_Attach_Handler
(Ptyp
)
13415 or else Has_Interrupt_Handler
(Ptyp
)
13418 New_Reference_To
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
13420 -- Normal case, no priority or xx_Handler specified, default priority
13424 New_Reference_To
(RTE
(RE_Unspecified_Priority
), Loc
));
13427 -- Test for Compiler_Info parameter. This parameter allows entry body
13428 -- procedures and barrier functions to be called from the runtime. It
13429 -- is a pointer to the record generated by the compiler to represent
13430 -- the protected object.
13432 -- A protected type without entries that covers an interface and
13433 -- overrides the abstract routines with protected procedures is
13434 -- considered equivalent to a protected type with entries in the
13435 -- context of dispatching select statements.
13438 or else Has_Interfaces
(Protect_Rec
)
13440 ((Has_Attach_Handler
(Ptyp
) or else Has_Interrupt_Handler
(Ptyp
))
13441 and then not Restriction_Active
(No_Dynamic_Attachment
))
13444 Pkg_Id
: constant RTU_Id
:=
13445 Corresponding_Runtime_Package
(Ptyp
);
13447 Called_Subp
: RE_Id
;
13451 when System_Tasking_Protected_Objects_Entries
=>
13452 Called_Subp
:= RE_Initialize_Protection_Entries
;
13454 when System_Tasking_Protected_Objects
=>
13455 Called_Subp
:= RE_Initialize_Protection
;
13457 when System_Tasking_Protected_Objects_Single_Entry
=>
13458 Called_Subp
:= RE_Initialize_Protection_Entry
;
13461 raise Program_Error
;
13465 or else not Restricted
13466 or else Has_Interfaces
(Protect_Rec
)
13469 Make_Attribute_Reference
(Loc
,
13470 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13471 Attribute_Name
=> Name_Address
));
13474 -- Entry_Bodies parameter. This is a pointer to an array of
13475 -- pointers to the entry body procedures and barrier functions
13476 -- of the object. If the protected type has no entries this
13477 -- object will not exist, in this case, pass a null.
13480 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
13483 Make_Attribute_Reference
(Loc
,
13484 Prefix
=> New_Reference_To
(P_Arr
, Loc
),
13485 Attribute_Name
=> Name_Unrestricted_Access
));
13487 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
13489 -- Find index mapping function (clumsy but ok for now)
13491 while Ekind
(P_Arr
) /= E_Function
loop
13492 Next_Entity
(P_Arr
);
13496 Make_Attribute_Reference
(Loc
,
13497 Prefix
=> New_Reference_To
(P_Arr
, Loc
),
13498 Attribute_Name
=> Name_Unrestricted_Access
));
13500 -- Build_Entry_Names generation flag. When set to true,
13501 -- the runtime will allocate an array to hold the string
13502 -- names of protected entries.
13504 if not Restricted_Profile
then
13505 if Entry_Names_OK
then
13507 New_Reference_To
(Standard_True
, Loc
));
13510 New_Reference_To
(Standard_False
, Loc
));
13516 System_Tasking_Protected_Objects_Single_Entry
13518 Append_To
(Args
, Make_Null
(Loc
));
13520 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
13521 Append_To
(Args
, Make_Null
(Loc
));
13522 Append_To
(Args
, Make_Null
(Loc
));
13523 Append_To
(Args
, New_Reference_To
(Standard_False
, Loc
));
13527 Make_Procedure_Call_Statement
(Loc
,
13528 Name
=> New_Reference_To
(RTE
(Called_Subp
), Loc
),
13529 Parameter_Associations
=> Args
));
13533 Make_Procedure_Call_Statement
(Loc
,
13534 Name
=> New_Reference_To
(RTE
(RE_Initialize_Protection
), Loc
),
13535 Parameter_Associations
=> Args
));
13539 if Has_Attach_Handler
(Ptyp
) then
13541 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
13542 -- make the following call:
13544 -- Install_Handlers (_object,
13545 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
13547 -- or, in the case of Ravenscar:
13549 -- Install_Restricted_Handlers
13550 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
13553 Args
: constant List_Id
:= New_List
;
13554 Table
: constant List_Id
:= New_List
;
13555 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
13558 -- Build the Attach_Handler table argument
13560 while Present
(Ritem
) loop
13561 if Nkind
(Ritem
) = N_Pragma
13562 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
13565 Handler
: constant Node_Id
:=
13566 First
(Pragma_Argument_Associations
(Ritem
));
13568 Interrupt
: constant Node_Id
:= Next
(Handler
);
13569 Expr
: constant Node_Id
:= Expression
(Interrupt
);
13573 Make_Aggregate
(Loc
, Expressions
=> New_List
(
13574 Unchecked_Convert_To
13575 (RTE
(RE_System_Interrupt_Id
), Expr
),
13576 Make_Attribute_Reference
(Loc
,
13577 Prefix
=> Make_Selected_Component
(Loc
,
13578 Make_Identifier
(Loc
, Name_uInit
),
13579 Duplicate_Subexpr_No_Checks
13580 (Expression
(Handler
))),
13581 Attribute_Name
=> Name_Access
))));
13585 Next_Rep_Item
(Ritem
);
13588 -- Append the table argument we just built
13590 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
13592 -- Append the Install_Handlers (or Install_Restricted_Handlers)
13593 -- call to the statements.
13596 -- Call a simplified version of Install_Handlers to be used
13597 -- when the Ravenscar restrictions are in effect
13598 -- (Install_Restricted_Handlers).
13601 Make_Procedure_Call_Statement
(Loc
,
13604 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
13605 Parameter_Associations
=> Args
));
13608 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13609 -- First, prepends the _object argument
13612 Make_Attribute_Reference
(Loc
,
13614 Make_Selected_Component
(Loc
,
13615 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13617 Make_Identifier
(Loc
, Name_uObject
)),
13618 Attribute_Name
=> Name_Unchecked_Access
));
13621 -- Then, insert call to Install_Handlers
13624 Make_Procedure_Call_Statement
(Loc
,
13625 Name
=> New_Reference_To
(RTE
(RE_Install_Handlers
), Loc
),
13626 Parameter_Associations
=> Args
));
13632 end Make_Initialize_Protection
;
13634 ---------------------------
13635 -- Make_Task_Create_Call --
13636 ---------------------------
13638 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
13639 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
13649 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
13650 Tnam
:= Chars
(Ttyp
);
13652 -- Get task declaration. In the case of a task type declaration, this is
13653 -- simply the parent of the task type entity. In the single task
13654 -- declaration, this parent will be the implicit type, and we can find
13655 -- the corresponding single task declaration by searching forward in the
13656 -- declaration list in the tree.
13658 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
13659 -- this type should have been removed during semantic analysis.
13661 Tdec
:= Parent
(Ttyp
);
13662 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
13663 N_Single_Task_Declaration
)
13668 -- Now we can find the task definition from this declaration
13670 Tdef
:= Task_Definition
(Tdec
);
13672 -- Build the parameter list for the call. Note that _Init is the name
13673 -- of the formal for the object to be initialized, which is the task
13674 -- value record itself.
13678 -- Priority parameter. Set to Unspecified_Priority unless there is a
13679 -- Priority rep item, in which case we take the value from the rep item.
13681 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
13683 Make_Selected_Component
(Loc
,
13684 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13685 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
13688 New_Reference_To
(RTE
(RE_Unspecified_Priority
), Loc
));
13691 -- Optional Stack parameter
13693 if Restricted_Profile
then
13695 -- If the stack has been preallocated by the expander then
13696 -- pass its address. Otherwise, pass a null address.
13698 if Preallocated_Stacks_On_Target
then
13700 Make_Attribute_Reference
(Loc
,
13702 Make_Selected_Component
(Loc
,
13703 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13704 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
13705 Attribute_Name
=> Name_Address
));
13709 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
13713 -- Size parameter. If no Storage_Size pragma is present, then
13714 -- the size is taken from the taskZ variable for the type, which
13715 -- is either Unspecified_Size, or has been reset by the use of
13716 -- a Storage_Size attribute definition clause. If a pragma is
13717 -- present, then the size is taken from the _Size field of the
13718 -- task value record, which was set from the pragma value.
13721 and then Has_Storage_Size_Pragma
(Tdef
)
13724 Make_Selected_Component
(Loc
,
13725 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13726 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
13730 New_Reference_To
(Storage_Size_Variable
(Ttyp
), Loc
));
13733 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
13734 -- Task_Info pragma, in which case we take the value from the pragma.
13736 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
13738 Make_Selected_Component
(Loc
,
13739 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13740 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
13744 New_Reference_To
(RTE
(RE_Unspecified_Task_Info
), Loc
));
13747 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
13748 -- in which case we take the value from the rep item. The parameter is
13749 -- passed as an Integer because in the case of unspecified CPU the
13750 -- value is not in the range of CPU_Range.
13752 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
13754 Convert_To
(Standard_Integer
,
13755 Make_Selected_Component
(Loc
,
13756 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13757 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
13760 New_Reference_To
(RTE
(RE_Unspecified_CPU
), Loc
));
13763 if not Restricted_Profile
then
13765 -- Deadline parameter. If no Relative_Deadline pragma is present,
13766 -- then the deadline is Time_Span_Zero. If a pragma is present, then
13767 -- the deadline is taken from the _Relative_Deadline field of the
13768 -- task value record, which was set from the pragma value. Note that
13769 -- this parameter must not be generated for the restricted profiles
13770 -- since Ravenscar does not allow deadlines.
13772 -- Case where pragma Relative_Deadline applies: use given value
13775 and then Has_Relative_Deadline_Pragma
(Tdef
)
13778 Make_Selected_Component
(Loc
,
13780 Make_Identifier
(Loc
, Name_uInit
),
13782 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
13784 -- No pragma Relative_Deadline apply to the task
13788 New_Reference_To
(RTE
(RE_Time_Span_Zero
), Loc
));
13791 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
13792 -- present, then the dispatching domain is null. If a rep item is
13793 -- present, then the dispatching domain is taken from the
13794 -- _Dispatching_Domain field of the task value record, which was set
13795 -- from the rep item value. Note that this parameter must not be
13796 -- generated for the restricted profiles since Ravenscar does not
13797 -- allow dispatching domains.
13799 -- Case where Dispatching_Domain rep item applies: use given value
13802 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
13805 Make_Selected_Component
(Loc
,
13807 Make_Identifier
(Loc
, Name_uInit
),
13809 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
13811 -- No pragma or aspect Dispatching_Domain apply to the task
13814 Append_To
(Args
, Make_Null
(Loc
));
13817 -- Number of entries. This is an expression of the form:
13819 -- n + _Init.a'Length + _Init.a'B'Length + ...
13821 -- where a,b... are the entry family names for the task definition
13824 Build_Entry_Count_Expression
13829 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
13831 Append_To
(Args
, Ecount
);
13833 -- Master parameter. This is a reference to the _Master parameter of
13834 -- the initialization procedure, except in the case of the pragma
13835 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
13836 -- System.Tasking.Library_Task_Level.
13838 if Restriction_Active
(No_Task_Hierarchy
) = False then
13839 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
13842 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
13846 -- State parameter. This is a pointer to the task body procedure. The
13847 -- required value is obtained by taking 'Unrestricted_Access of the task
13848 -- body procedure and converting it (with an unchecked conversion) to
13849 -- the type required by the task kernel. For further details, see the
13850 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
13851 -- than 'Address in order to avoid creating trampolines.
13854 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
13855 Subp_Ptr_Typ
: constant Node_Id
:=
13856 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
13857 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
13860 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
13861 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
13863 -- Be sure to freeze a reference to the access-to-subprogram type,
13864 -- otherwise gigi will complain that it's in the wrong scope, because
13865 -- it's actually inside the init procedure for the record type that
13866 -- corresponds to the task type.
13868 -- This processing is causing a crash in the .NET/JVM back ends that
13869 -- is not yet understood, so skip it in these cases ???
13871 if VM_Target
= No_VM
then
13872 Set_Itype
(Ref
, Subp_Ptr_Typ
);
13873 Append_Freeze_Action
(Task_Rec
, Ref
);
13876 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
13877 Make_Qualified_Expression
(Loc
,
13878 Subtype_Mark
=> New_Reference_To
(Subp_Ptr_Typ
, Loc
),
13880 Make_Attribute_Reference
(Loc
,
13882 New_Occurrence_Of
(Body_Proc
, Loc
),
13883 Attribute_Name
=> Name_Unrestricted_Access
))));
13885 -- For the .NET/JVM cases revert to the original code below ???
13889 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
13890 Make_Attribute_Reference
(Loc
,
13892 New_Occurrence_Of
(Body_Proc
, Loc
),
13893 Attribute_Name
=> Name_Address
)));
13897 -- Discriminants parameter. This is just the address of the task
13898 -- value record itself (which contains the discriminant values
13901 Make_Attribute_Reference
(Loc
,
13902 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13903 Attribute_Name
=> Name_Address
));
13905 -- Elaborated parameter. This is an access to the elaboration Boolean
13908 Make_Attribute_Reference
(Loc
,
13909 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
13910 Attribute_Name
=> Name_Unchecked_Access
));
13912 -- Chain parameter. This is a reference to the _Chain parameter of
13913 -- the initialization procedure.
13915 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
13917 -- Task name parameter. Take this from the _Task_Id parameter to the
13918 -- init call unless there is a Task_Name pragma, in which case we take
13919 -- the value from the pragma.
13921 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
13922 -- Copy expression in full, because it may be dynamic and have
13929 (Pragma_Argument_Associations
13931 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
13934 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
13937 -- Created_Task parameter. This is the _Task_Id field of the task
13941 Make_Selected_Component
(Loc
,
13942 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13943 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
13945 -- Build_Entry_Names generation flag. When set to true, the runtime
13946 -- will allocate an array to hold the string names of task entries.
13948 if not Restricted_Profile
then
13951 (Boolean_Literals
(Has_Entries
(Ttyp
) and then Entry_Names_OK
),
13955 if Restricted_Profile
then
13956 Name
:= New_Reference_To
(RTE
(RE_Create_Restricted_Task
), Loc
);
13958 Name
:= New_Reference_To
(RTE
(RE_Create_Task
), Loc
);
13962 Make_Procedure_Call_Statement
(Loc
,
13964 Parameter_Associations
=> Args
);
13965 end Make_Task_Create_Call
;
13967 ------------------------------
13968 -- Next_Protected_Operation --
13969 ------------------------------
13971 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
13975 Next_Op
:= Next
(N
);
13976 while Present
(Next_Op
)
13977 and then not Nkind_In
(Next_Op
, N_Subprogram_Body
, N_Entry_Body
)
13983 end Next_Protected_Operation
;
13985 ---------------------
13986 -- Null_Statements --
13987 ---------------------
13989 function Null_Statements
(Stats
: List_Id
) return Boolean is
13993 Stmt
:= First
(Stats
);
13994 while Nkind
(Stmt
) /= N_Empty
13995 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
13997 (Nkind
(Stmt
) = N_Pragma
13998 and then (Pragma_Name
(Stmt
) = Name_Unreferenced
14000 Pragma_Name
(Stmt
) = Name_Unmodified
14002 Pragma_Name
(Stmt
) = Name_Warnings
)))
14007 return Nkind
(Stmt
) = N_Empty
;
14008 end Null_Statements
;
14010 --------------------------
14011 -- Parameter_Block_Pack --
14012 --------------------------
14014 function Parameter_Block_Pack
14016 Blk_Typ
: Entity_Id
;
14020 Stmts
: List_Id
) return Node_Id
14022 Actual
: Entity_Id
;
14023 Expr
: Node_Id
:= Empty
;
14024 Formal
: Entity_Id
;
14025 Has_Param
: Boolean := False;
14028 Temp_Asn
: Node_Id
;
14029 Temp_Nam
: Node_Id
;
14032 Actual
:= First
(Actuals
);
14033 Formal
:= Defining_Identifier
(First
(Formals
));
14034 Params
:= New_List
;
14036 while Present
(Actual
) loop
14037 if Is_By_Copy_Type
(Etype
(Actual
)) then
14039 -- Jnn : aliased <formal-type>
14041 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14044 Make_Object_Declaration
(Loc
,
14047 Defining_Identifier
=>
14049 Object_Definition
=>
14050 New_Reference_To
(Etype
(Formal
), Loc
)));
14052 if Ekind
(Formal
) /= E_Out_Parameter
then
14058 New_Reference_To
(Temp_Nam
, Loc
);
14060 Set_Assignment_OK
(Temp_Asn
);
14063 Make_Assignment_Statement
(Loc
,
14067 New_Copy_Tree
(Actual
)));
14071 -- Jnn'unchecked_access
14074 Make_Attribute_Reference
(Loc
,
14076 Name_Unchecked_Access
,
14078 New_Reference_To
(Temp_Nam
, Loc
)));
14082 -- The controlling parameter is omitted
14085 if not Is_Controlling_Actual
(Actual
) then
14087 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14093 Next_Actual
(Actual
);
14094 Next_Formal_With_Extras
(Formal
);
14098 Expr
:= Make_Aggregate
(Loc
, Params
);
14103 -- J1'unchecked_access;
14104 -- <actual2>'reference;
14107 P
:= Make_Temporary
(Loc
, 'P');
14110 Make_Object_Declaration
(Loc
,
14111 Defining_Identifier
=>
14113 Object_Definition
=>
14114 New_Reference_To
(Blk_Typ
, Loc
),
14119 end Parameter_Block_Pack
;
14121 ----------------------------
14122 -- Parameter_Block_Unpack --
14123 ----------------------------
14125 function Parameter_Block_Unpack
14129 Formals
: List_Id
) return List_Id
14131 Actual
: Entity_Id
;
14133 Formal
: Entity_Id
;
14134 Has_Asnmt
: Boolean := False;
14135 Result
: constant List_Id
:= New_List
;
14138 Actual
:= First
(Actuals
);
14139 Formal
:= Defining_Identifier
(First
(Formals
));
14140 while Present
(Actual
) loop
14141 if Is_By_Copy_Type
(Etype
(Actual
))
14142 and then Ekind
(Formal
) /= E_In_Parameter
14145 -- <actual> := P.<formal>;
14148 Make_Assignment_Statement
(Loc
,
14152 Make_Explicit_Dereference
(Loc
,
14153 Make_Selected_Component
(Loc
,
14155 New_Reference_To
(P
, Loc
),
14157 Make_Identifier
(Loc
, Chars
(Formal
)))));
14159 Set_Assignment_OK
(Name
(Asnmt
));
14160 Append_To
(Result
, Asnmt
);
14165 Next_Actual
(Actual
);
14166 Next_Formal_With_Extras
(Formal
);
14172 return New_List
(Make_Null_Statement
(Loc
));
14174 end Parameter_Block_Unpack
;
14176 ----------------------
14177 -- Set_Discriminals --
14178 ----------------------
14180 procedure Set_Discriminals
(Dec
: Node_Id
) is
14183 D_Minal
: Entity_Id
;
14186 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
14187 Pdef
:= Defining_Identifier
(Dec
);
14189 if Has_Discriminants
(Pdef
) then
14190 D
:= First_Discriminant
(Pdef
);
14191 while Present
(D
) loop
14193 Make_Defining_Identifier
(Sloc
(D
),
14194 Chars
=> New_External_Name
(Chars
(D
), 'D'));
14196 Set_Ekind
(D_Minal
, E_Constant
);
14197 Set_Etype
(D_Minal
, Etype
(D
));
14198 Set_Scope
(D_Minal
, Pdef
);
14199 Set_Discriminal
(D
, D_Minal
);
14200 Set_Discriminal_Link
(D_Minal
, D
);
14202 Next_Discriminant
(D
);
14205 end Set_Discriminals
;
14207 -----------------------
14208 -- Trivial_Accept_OK --
14209 -----------------------
14211 function Trivial_Accept_OK
return Boolean is
14213 case Opt
.Task_Dispatching_Policy
is
14215 -- If we have the default task dispatching policy in effect, we can
14216 -- definitely do the optimization (one way of looking at this is to
14217 -- think of the formal definition of the default policy being allowed
14218 -- to run any task it likes after a rendezvous, so even if notionally
14219 -- a full rescheduling occurs, we can say that our dispatching policy
14220 -- (i.e. the default dispatching policy) reorders the queue to be the
14221 -- same as just before the call.
14226 -- FIFO_Within_Priorities certainly does not permit this
14227 -- optimization since the Rendezvous is a scheduling action that may
14228 -- require some other task to be run.
14233 -- For now, disallow the optimization for all other policies. This
14234 -- may be over-conservative, but it is certainly not incorrect.
14240 end Trivial_Accept_OK
;