1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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 Aspects
; use Aspects
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Elists
; use Elists
;
33 with Errout
; use Errout
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch11
; use Exp_Ch11
;
37 with Exp_Dbug
; use Exp_Dbug
;
38 with Exp_Sel
; use Exp_Sel
;
39 with Exp_Smem
; use Exp_Smem
;
40 with Exp_Tss
; use Exp_Tss
;
41 with Exp_Util
; use Exp_Util
;
42 with Freeze
; use Freeze
;
44 with Itypes
; use Itypes
;
45 with Namet
; use Namet
;
46 with Nlists
; use Nlists
;
47 with Nmake
; use Nmake
;
49 with Restrict
; use Restrict
;
50 with Rident
; use Rident
;
51 with Rtsfind
; use Rtsfind
;
53 with Sem_Aux
; use Sem_Aux
;
54 with Sem_Ch5
; use Sem_Ch5
;
55 with Sem_Ch6
; use Sem_Ch6
;
56 with Sem_Ch8
; use Sem_Ch8
;
57 with Sem_Ch9
; use Sem_Ch9
;
58 with Sem_Ch11
; use Sem_Ch11
;
59 with Sem_Ch13
; use Sem_Ch13
;
60 with Sem_Elab
; use Sem_Elab
;
61 with Sem_Eval
; use Sem_Eval
;
62 with Sem_Res
; use Sem_Res
;
63 with Sem_Util
; use Sem_Util
;
64 with Sinfo
; use Sinfo
;
65 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
66 with Sinfo
.Utils
; use Sinfo
.Utils
;
67 with Snames
; use Snames
;
68 with Stand
; use Stand
;
69 with Targparm
; use Targparm
;
70 with Tbuild
; use Tbuild
;
71 with Uintp
; use Uintp
;
72 with Validsw
; use Validsw
;
74 package body Exp_Ch9
is
76 -- The following constant establishes the upper bound for the index of
77 -- an entry family. It is used to limit the allocated size of protected
78 -- types with defaulted discriminant of an integer type, when the bound
79 -- of some entry family depends on a discriminant. The limitation to entry
80 -- families of 128K should be reasonable in all cases, and is a documented
81 -- implementation restriction.
83 Entry_Family_Bound
: constant Pos
:= 2**16;
85 -----------------------
86 -- Local Subprograms --
87 -----------------------
89 function Actual_Index_Expression
93 Tsk
: Entity_Id
) return Node_Id
;
94 -- Compute the index position for an entry call. Tsk is the target task. If
95 -- the bounds of some entry family depend on discriminants, the expression
96 -- computed by this function uses the discriminants of the target task.
98 procedure Add_Object_Pointer
100 Conc_Typ
: Entity_Id
;
102 -- Prepend an object pointer declaration to the declaration list Decls.
103 -- This object pointer is initialized to a type conversion of the System.
104 -- Address pointer passed to entry barrier functions and entry body
107 procedure Add_Formal_Renamings
112 -- Create renaming declarations for the formals, inside the procedure that
113 -- implements an entry body. The renamings make the original names of the
114 -- formals accessible to gdb, and serve no other purpose.
115 -- Spec is the specification of the procedure being built.
116 -- Decls is the list of declarations to be enhanced.
117 -- Ent is the entity for the original entry body.
119 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
;
120 -- Transform accept statement into a block with added exception handler.
121 -- Used both for simple accept statements and for accept alternatives in
122 -- select statements. Astat is the accept statement.
124 function Build_Barrier_Function
127 Pid
: Entity_Id
) return Node_Id
;
128 -- Build the function body returning the value of the barrier expression
129 -- for the specified entry body.
131 function Build_Barrier_Function_Specification
133 Def_Id
: Entity_Id
) return Node_Id
;
134 -- Build a specification for a function implementing the protected entry
135 -- barrier of the specified entry body.
137 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
);
138 -- Build the body of a wrapper procedure for an entry or entry family that
139 -- has contract cases, preconditions, or postconditions. The body gathers
140 -- the executable contract items and expands them in the usual way, and
141 -- performs the entry call itself. This way preconditions are evaluated
142 -- before the call is queued. E is the entry in question, and Decl is the
143 -- enclosing synchronized type declaration at whose freeze point the
144 -- generated body is analyzed.
146 function Build_Corresponding_Record
149 Loc
: Source_Ptr
) return Node_Id
;
150 -- Common to tasks and protected types. Copy discriminant specifications,
151 -- build record declaration. N is the type declaration, Ctyp is the
152 -- concurrent entity (task type or protected type).
154 function Build_Dispatching_Tag_Check
156 N
: Node_Id
) return Node_Id
;
157 -- Utility to create the tree to check whether the dispatching call in
158 -- a timed entry call, a conditional entry call, or an asynchronous
159 -- transfer of control is a call to a primitive of a non-synchronized type.
160 -- K is the temporary that holds the tagged kind of the target object, and
161 -- N is the enclosing construct.
163 function Build_Entry_Count_Expression
164 (Concurrent_Type
: Node_Id
;
165 Component_List
: List_Id
;
166 Loc
: Source_Ptr
) return Node_Id
;
167 -- Compute number of entries for concurrent object. This is a count of
168 -- simple entries, followed by an expression that computes the length
169 -- of the range of each entry family. A single array with that size is
170 -- allocated for each concurrent object of the type.
172 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
;
173 -- Build the function that translates the entry index in the call
174 -- (which depends on the size of entry families) into an index into the
175 -- Entry_Bodies_Array, to determine the body and barrier function used
176 -- in a protected entry call. A pointer to this function appears in every
179 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
;
180 -- Build subprogram declaration for previous one
182 function Build_Lock_Free_Protected_Subprogram_Body
185 Unprot_Spec
: Node_Id
) return Node_Id
;
186 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
187 -- the subprogram specification of the unprotected version of N. Transform
188 -- N such that it invokes the unprotected version of the body.
190 function Build_Lock_Free_Unprotected_Subprogram_Body
192 Prot_Typ
: Node_Id
) return Node_Id
;
193 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
194 -- of N where the original statements of N are synchronized through atomic
195 -- actions such as compare and exchange. Prior to invoking this routine, it
196 -- has been established that N can be implemented in a lock-free fashion.
198 function Build_Parameter_Block
202 Decls
: List_Id
) return Entity_Id
;
203 -- Generate an access type for each actual parameter in the list Actuals.
204 -- Create an encapsulating record that contains all the actuals and return
205 -- its type. Generate:
206 -- type Ann1 is access all <actual1-type>
208 -- type AnnN is access all <actualN-type>
209 -- type Pnn is record
215 function Build_Protected_Entry
218 Pid
: Node_Id
) return Node_Id
;
219 -- Build the procedure implementing the statement sequence of the specified
222 function Build_Protected_Entry_Specification
225 Ent_Id
: Entity_Id
) return Node_Id
;
226 -- Build a specification for the procedure implementing the statements of
227 -- the specified entry body. Add attributes associating it with the entry
228 -- defining identifier Ent_Id.
230 function Build_Protected_Spec
232 Obj_Type
: Entity_Id
;
234 Unprotected
: Boolean := False) return List_Id
;
235 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
236 -- Subprogram_Type. Builds signature of protected subprogram, adding the
237 -- formal that corresponds to the object itself. For an access to protected
238 -- subprogram, there is no object type to specify, so the parameter has
239 -- type Address and mode In. An indirect call through such a pointer will
240 -- convert the address to a reference to the actual object. The object is
241 -- a limited record and therefore a by_reference type.
243 function Build_Protected_Subprogram_Body
246 N_Op_Spec
: Node_Id
) return Node_Id
;
247 -- This function is used to construct the protected version of a protected
248 -- subprogram. Its statement sequence first defers abort, then locks the
249 -- associated protected object, and then enters a block that contains a
250 -- call to the unprotected version of the subprogram (for details, see
251 -- Build_Unprotected_Subprogram_Body). This block statement requires a
252 -- cleanup handler that unlocks the object in all cases. For details,
253 -- see Exp_Ch7.Expand_Cleanup_Actions.
255 function Build_Renamed_Formal_Declaration
259 Renamed_Formal
: Node_Id
) return Node_Id
;
260 -- Create a renaming declaration for a formal, within a protected entry
261 -- body or an accept body. The renamed object is a component of the
262 -- parameter block that is a parameter in the entry call.
264 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
265 -- does not dereference the corresponding component to prevent an illegal
266 -- use of the incomplete type (AI05-0151).
268 function Build_Selected_Name
270 Selector
: Entity_Id
;
271 Append_Char
: Character := ' ') return Name_Id
;
272 -- Build a name in the form of Prefix__Selector, with an optional character
273 -- appended. This is used for internal subprograms generated for operations
274 -- of protected types, including barrier functions. For the subprograms
275 -- generated for entry bodies and entry barriers, the generated name
276 -- includes a sequence number that makes names unique in the presence of
277 -- entry overloading. This is necessary because entry body procedures and
278 -- barrier functions all have the same signature.
280 procedure Build_Simple_Entry_Call
285 -- Build the call corresponding to the task entry call. N is the task entry
286 -- call, Concval is the concurrent object, Ename is the entry name and
287 -- Index is the entry family index.
288 -- Note that N might be expanded into an N_Block_Statement if it gets
291 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
;
292 -- This routine constructs a specification for the procedure that we will
293 -- build for the task body for task type T. The spec has the form:
295 -- procedure tnameB (_Task : access tnameV);
297 -- where name is the character name taken from the task type entity that
298 -- is passed as the argument to the procedure, and tnameV is the task
299 -- value type that is associated with the task type.
301 function Build_Unprotected_Subprogram_Body
303 Pid
: Node_Id
) return Node_Id
;
304 -- This routine constructs the unprotected version of a protected
305 -- subprogram body, which contains all of the code in the original,
306 -- unexpanded body. This is the version of the protected subprogram that is
307 -- called from all protected operations on the same object, including the
308 -- protected version of the same subprogram.
310 procedure Build_Wrapper_Bodies
314 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
315 -- record of a concurrent type. N is the insertion node where all bodies
316 -- will be placed. This routine builds the bodies of the subprograms which
317 -- serve as an indirection mechanism to overriding primitives of concurrent
318 -- types, entries and protected procedures. Any new body is analyzed.
320 procedure Build_Wrapper_Specs
324 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
325 -- record of a concurrent type. N is the insertion node where all specs
326 -- will be placed. This routine builds the specs of the subprograms which
327 -- serve as an indirection mechanism to overriding primitives of concurrent
328 -- types, entries and protected procedures. Any new spec is analyzed.
330 procedure Collect_Entry_Families
333 Current_Node
: in out Node_Id
;
334 Conctyp
: Entity_Id
);
335 -- For each entry family in a concurrent type, create an anonymous array
336 -- type of the right size, and add a component to the corresponding_record.
338 function Concurrent_Object
339 (Spec_Id
: Entity_Id
;
340 Conc_Typ
: Entity_Id
) return Entity_Id
;
341 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
342 -- the entity associated with the concurrent object in the Protected_Body_
343 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
344 -- denotes formal parameter _O, _object or _task.
346 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
;
347 -- Copy the result type of a function specification, when building the
348 -- internal operation corresponding to a protected function, or when
349 -- expanding an access to protected function. If the result is an anonymous
350 -- access to subprogram itself, we need to create a new signature with the
351 -- same parameter names and the same resolved types, but with new entities
354 function Create_Secondary_Stack_For_Task
(T
: Node_Id
) return Boolean;
355 -- Return whether a secondary stack for the task T should be created by the
356 -- expander. The secondary stack for a task will be created by the expander
357 -- if the size of the stack has been specified by the Secondary_Stack_Size
358 -- representation aspect and either the No_Implicit_Heap_Allocations or
359 -- No_Implicit_Task_Allocations restrictions are in effect and the
360 -- No_Secondary_Stack restriction is not.
362 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
363 -- Decls is a list which may contain the declarations created by Install_
364 -- Private_Data_Declarations. All generated entities are marked as needing
365 -- debug info and debug nodes are manually generation where necessary. This
366 -- step of the expansion must to be done after private data has been moved
367 -- to its final resting scope to ensure proper visibility of debug objects.
369 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
);
370 -- If control flow optimizations are suppressed, and Alt is an accept,
371 -- delay, or entry call alternative with no trailing statements, insert
372 -- a null trailing statement with the given Loc (which is the sloc of
373 -- the accept, delay, or entry call statement). There might not be any
374 -- generated code for the accept, delay, or entry call itself (the effect
375 -- of these statements is part of the general processing done for the
376 -- enclosing selective accept, timed entry call, or asynchronous select),
377 -- and the null statement is there to carry the sloc of that statement to
378 -- the back-end for trace-based coverage analysis purposes.
380 procedure Extract_Dispatching_Call
382 Call_Ent
: out Entity_Id
;
383 Object
: out Entity_Id
;
384 Actuals
: out List_Id
;
385 Formals
: out List_Id
);
386 -- Given a dispatching call, extract the entity of the name of the call,
387 -- its actual dispatching object, its actual parameters and the formal
388 -- parameters of the overridden interface-level version. If the type of
389 -- the dispatching object is an access type then an explicit dereference
390 -- is returned in Object.
392 procedure Extract_Entry
394 Concval
: out Node_Id
;
396 Index
: out Node_Id
);
397 -- Given an entry call, returns the associated concurrent object, the entry
398 -- name, and the entry family index.
400 function Family_Offset
405 Cap
: Boolean) return Node_Id
;
406 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
407 -- accept statement, or the upper bound in the discrete subtype of an entry
408 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
409 -- type of the entry. If Cap is true, the result is capped according to
410 -- Entry_Family_Bound.
417 Cap
: Boolean) return Node_Id
;
418 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
419 -- family, and handle properly the superflat case. This is equivalent to
420 -- the use of 'Length on the index type, but must use Family_Offset to
421 -- handle properly the case of bounds that depend on discriminants. If
422 -- Cap is true, the result is capped according to Entry_Family_Bound.
424 procedure Find_Enclosing_Context
426 Context
: out Node_Id
;
427 Context_Id
: out Entity_Id
;
428 Context_Decls
: out List_Id
);
429 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
430 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
431 -- nearest enclosing body, block, package, or return statement and return
432 -- its constituents. Context is the enclosing construct, Context_Id is
433 -- the scope of Context_Id and Context_Decls is the declarative list of
436 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
437 -- Given a subprogram identifier, return the entity which is associated
438 -- with the protection entry index in the Protected_Body_Subprogram or
439 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
442 function Is_Potentially_Large_Family
443 (Base_Index
: Entity_Id
;
446 Hi
: Node_Id
) return Boolean;
447 -- Determine whether an entry family is potentially large because one of
448 -- its bounds denotes a discrminant.
450 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
451 -- Determine whether Id is a function or a procedure and is marked as a
452 -- private primitive.
454 function Null_Statements
(Stats
: List_Id
) return Boolean;
455 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
456 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
457 -- to still count as null. Returns True for a null sequence. The argument
458 -- is the list of statements from the DO-END sequence.
460 function Parameter_Block_Pack
466 Stmts
: List_Id
) return Entity_Id
;
467 -- Set the components of the generated parameter block with the values
468 -- of the actual parameters. Generate aliased temporaries to capture the
469 -- values for types that are passed by copy. Otherwise generate a reference
470 -- to the actual's value. Return the address of the aggregate block.
472 -- Jnn1 : alias <formal-type1>;
473 -- Jnn1 := <actual1>;
476 -- Jnn1'unchecked_access;
477 -- <actual2>'reference;
480 function Parameter_Block_Unpack
484 Formals
: List_Id
) return List_Id
;
485 -- Retrieve the values of the components from the parameter block and
486 -- assign then to the original actual parameters. Generate:
487 -- <actual1> := P.<formal1>;
489 -- <actualN> := P.<formalN>;
491 procedure Reset_Scopes_To
(Bod
: Node_Id
; E
: Entity_Id
);
492 -- Reset the scope of declarations and blocks at the top level of Bod to
493 -- be E. Bod is either a block or a subprogram body. Used after expanding
494 -- various kinds of entry bodies into their corresponding constructs. This
495 -- is needed during unnesting to determine whether a body generated for an
496 -- entry or an accept alternative includes uplevel references.
498 function Trivial_Accept_OK
return Boolean;
499 -- If there is no DO-END block for an accept, or if the DO-END block has
500 -- only null statements, then it is possible to do the Rendezvous with much
501 -- less overhead using the Accept_Trivial routine in the run-time library.
502 -- However, this is not always a valid optimization. Whether it is valid or
503 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
504 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
505 -- a rescheduling is required, so this optimization is not allowed. This
506 -- function returns True if the optimization is permitted.
508 -----------------------------
509 -- Actual_Index_Expression --
510 -----------------------------
512 function Actual_Index_Expression
516 Tsk
: Entity_Id
) return Node_Id
518 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
526 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
527 -- Compute difference between bounds of entry family
529 --------------------------
530 -- Actual_Family_Offset --
531 --------------------------
533 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
535 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
536 -- Replace a reference to a discriminant with a selected component
537 -- denoting the discriminant of the target task.
539 -----------------------------
540 -- Actual_Discriminant_Ref --
541 -----------------------------
543 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
544 Typ
: constant Entity_Id
:= Etype
(Bound
);
548 if not Is_Entity_Name
(Bound
)
549 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
551 if Nkind
(Bound
) = N_Attribute_Reference
then
554 B
:= New_Copy_Tree
(Bound
);
559 Make_Selected_Component
(Sloc
,
560 Prefix
=> New_Copy_Tree
(Tsk
),
561 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
563 Analyze_And_Resolve
(B
, Typ
);
567 Make_Attribute_Reference
(Sloc
,
568 Attribute_Name
=> Name_Pos
,
569 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
570 Expressions
=> New_List
(B
));
571 end Actual_Discriminant_Ref
;
573 -- Start of processing for Actual_Family_Offset
577 Make_Op_Subtract
(Sloc
,
578 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
579 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
580 end Actual_Family_Offset
;
582 -- Start of processing for Actual_Index_Expression
585 -- The queues of entries and entry families appear in textual order in
586 -- the associated record. The entry index is computed as the sum of the
587 -- number of queues for all entries that precede the designated one, to
588 -- which is added the index expression, if this expression denotes a
589 -- member of a family.
591 -- The following is a place holder for the count of simple entries
593 Num
:= Make_Integer_Literal
(Sloc
, 1);
595 -- We construct an expression which is a series of addition operations.
596 -- See comments in Entry_Index_Expression, which is identical in
599 if Present
(Index
) then
600 S
:= Entry_Index_Type
(Ent
);
602 -- First make sure the index is in range if requested. The index type
603 -- has been directly set on the prefix, see Resolve_Entry.
605 if Do_Range_Check
(Index
) then
607 (Index
, Etype
(Prefix
(Parent
(Index
))), CE_Range_Check_Failed
);
614 Actual_Family_Offset
(
615 Make_Attribute_Reference
(Sloc
,
616 Attribute_Name
=> Name_Pos
,
617 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
618 Expressions
=> New_List
(Relocate_Node
(Index
))),
619 Type_Low_Bound
(S
)));
624 -- Now add lengths of preceding entries and entry families
626 Prev
:= First_Entity
(Ttyp
);
627 while Chars
(Prev
) /= Chars
(Ent
)
628 or else (Ekind
(Prev
) /= Ekind
(Ent
))
629 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
631 if Ekind
(Prev
) = E_Entry
then
632 Set_Intval
(Num
, Intval
(Num
) + 1);
634 elsif Ekind
(Prev
) = E_Entry_Family
then
635 S
:= Entry_Index_Type
(Prev
);
637 -- The need for the following full view retrieval stems from this
638 -- complex case of nested generics and tasking:
641 -- type Formal_Index is range <>;
644 -- type Index is private;
651 -- type Index is new Formal_Index range 1 .. 10;
654 -- package body Outer is
656 -- entry Fam (Index); -- (2)
659 -- package body Inner is -- (3)
667 -- We are currently building the index expression for the entry
668 -- call "T.E" (1). Part of the expansion must mention the range
669 -- of the discrete type "Index" (2) of entry family "Fam".
671 -- However only the private view of type "Index" is available to
672 -- the inner generic (3) because there was no prior mention of
673 -- the type inside "Inner". This visibility requirement is
674 -- implicit and cannot be detected during the construction of
675 -- the generic trees and needs special handling.
678 and then Is_Private_Type
(S
)
679 and then Present
(Full_View
(S
))
684 Lo
:= Type_Low_Bound
(S
);
685 Hi
:= Type_High_Bound
(S
);
692 Left_Opnd
=> Actual_Family_Offset
(Hi
, Lo
),
693 Right_Opnd
=> Make_Integer_Literal
(Sloc
, 1)));
695 -- Other components are anonymous types to be ignored
705 end Actual_Index_Expression
;
707 --------------------------
708 -- Add_Formal_Renamings --
709 --------------------------
711 procedure Add_Formal_Renamings
717 Ptr
: constant Entity_Id
:=
719 (Next
(First
(Parameter_Specifications
(Spec
))));
720 -- The name of the formal that holds the address of the parameter block
727 Renamed_Formal
: Node_Id
;
730 Formal
:= First_Formal
(Ent
);
731 while Present
(Formal
) loop
732 Comp
:= Entry_Component
(Formal
);
734 Make_Defining_Identifier
(Sloc
(Formal
),
735 Chars
=> Chars
(Formal
));
736 Set_Etype
(New_F
, Etype
(Formal
));
737 Set_Scope
(New_F
, Ent
);
739 -- Now we set debug info needed on New_F even though it does not come
740 -- from source, so that the debugger will get the right information
741 -- for these generated names.
743 Set_Debug_Info_Needed
(New_F
);
745 if Ekind
(Formal
) = E_In_Parameter
then
746 Mutate_Ekind
(New_F
, E_Constant
);
748 Mutate_Ekind
(New_F
, E_Variable
);
749 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
752 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
755 Make_Selected_Component
(Loc
,
757 Make_Explicit_Dereference
(Loc
,
758 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
759 Make_Identifier
(Loc
, Chars
(Ptr
)))),
760 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
763 Build_Renamed_Formal_Declaration
764 (New_F
, Formal
, Comp
, Renamed_Formal
);
766 Append
(Decl
, Decls
);
767 Set_Renamed_Object
(Formal
, New_F
);
768 Next_Formal
(Formal
);
770 end Add_Formal_Renamings
;
772 ------------------------
773 -- Add_Object_Pointer --
774 ------------------------
776 procedure Add_Object_Pointer
778 Conc_Typ
: Entity_Id
;
781 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
786 -- Create the renaming declaration for the Protection object of a
787 -- protected type. _Object is used by Complete_Entry_Body.
788 -- ??? An attempt to make this a renaming was unsuccessful.
790 -- Build the entity for the access type
793 Make_Defining_Identifier
(Loc
,
794 New_External_Name
(Chars
(Rec_Typ
), 'P'));
797 -- _object : poVP := poVP!O;
800 Make_Object_Declaration
(Loc
,
801 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uObject
),
802 Object_Definition
=> New_Occurrence_Of
(Obj_Ptr
, Loc
),
804 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
805 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
806 Prepend_To
(Decls
, Decl
);
809 -- type poVP is access poV;
812 Make_Full_Type_Declaration
(Loc
,
813 Defining_Identifier
=>
816 Make_Access_To_Object_Definition
(Loc
,
817 Subtype_Indication
=>
818 New_Occurrence_Of
(Rec_Typ
, Loc
)));
819 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
820 Prepend_To
(Decls
, Decl
);
821 end Add_Object_Pointer
;
823 -----------------------
824 -- Build_Accept_Body --
825 -----------------------
827 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
828 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
829 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
836 -- At the end of the statement sequence, Complete_Rendezvous is called.
837 -- A label skipping the Complete_Rendezvous, and all other accept
838 -- processing, has already been added for the expansion of requeue
839 -- statements. The Sloc is copied from the last statement since it
840 -- is really part of this last statement.
844 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
845 Insert_Before
(Last
(Statements
(Stats
)), Call
);
848 -- Ada 2022 (AI12-0279)
850 if Has_Yield_Aspect
(Entity
(Entry_Direct_Name
(Astat
)))
851 and then RTE_Available
(RE_Yield
)
853 Insert_Action_After
(Call
,
854 Make_Procedure_Call_Statement
(Loc
,
855 New_Occurrence_Of
(RTE
(RE_Yield
), Loc
)));
858 -- If exception handlers are present, then append Complete_Rendezvous
859 -- calls to the handlers, and construct the required outer block. As
860 -- above, the Sloc is copied from the last statement in the sequence.
862 if Present
(Exception_Handlers
(Stats
)) then
863 Hand
:= First
(Exception_Handlers
(Stats
));
864 while Present
(Hand
) loop
867 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
868 Append
(Call
, Statements
(Hand
));
871 -- Ada 2022 (AI12-0279)
873 if Has_Yield_Aspect
(Entity
(Entry_Direct_Name
(Astat
)))
874 and then RTE_Available
(RE_Yield
)
876 Insert_Action_After
(Call
,
877 Make_Procedure_Call_Statement
(Loc
,
878 New_Occurrence_Of
(RTE
(RE_Yield
), Loc
)));
885 Make_Handled_Sequence_Of_Statements
(Loc
,
886 Statements
=> New_List
(
887 Make_Block_Statement
(Loc
,
888 Handled_Statement_Sequence
=> Stats
)));
894 -- At this stage we know that the new statement sequence does
895 -- not have an exception handler part, so we supply one to call
896 -- Exceptional_Complete_Rendezvous. This handler is
898 -- when all others =>
899 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
901 -- We handle Abort_Signal to make sure that we properly catch the abort
902 -- case and wake up the caller.
905 Make_Procedure_Call_Statement
(Sloc
(Stats
),
906 Name
=> New_Occurrence_Of
(
907 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
908 Parameter_Associations
=> New_List
(
909 Make_Function_Call
(Sloc
(Stats
),
912 (RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))));
914 Ohandle
:= Make_Others_Choice
(Loc
);
915 Set_All_Others
(Ohandle
);
917 Set_Exception_Handlers
(New_S
,
919 Make_Implicit_Exception_Handler
(Loc
,
920 Exception_Choices
=> New_List
(Ohandle
),
922 Statements
=> New_List
(Call
))));
924 -- Ada 2022 (AI12-0279)
926 if Has_Yield_Aspect
(Entity
(Entry_Direct_Name
(Astat
)))
927 and then RTE_Available
(RE_Yield
)
929 Insert_Action_After
(Call
,
930 Make_Procedure_Call_Statement
(Loc
,
931 New_Occurrence_Of
(RTE
(RE_Yield
), Loc
)));
934 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
935 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
936 Expand_Exception_Handlers
(New_S
);
938 -- Exceptional_Complete_Rendezvous must be called with abort still
939 -- deferred, which is the case for a "when all others" handler.
942 end Build_Accept_Body
;
944 -----------------------------------
945 -- Build_Activation_Chain_Entity --
946 -----------------------------------
948 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
949 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean;
950 -- Determine whether an extended return statement has activation chain
952 --------------------------
953 -- Has_Activation_Chain --
954 --------------------------
956 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean is
960 Decl
:= First
(Return_Object_Declarations
(Stmt
));
961 while Present
(Decl
) loop
962 if Nkind
(Decl
) = N_Object_Declaration
963 and then Chars
(Defining_Identifier
(Decl
)) = Name_uChain
972 end Has_Activation_Chain
;
977 Context_Id
: Entity_Id
;
980 -- Start of processing for Build_Activation_Chain_Entity
983 -- No action needed if the run-time has no tasking support
985 if Global_No_Tasking
then
989 -- Activation chain is never used for sequential elaboration policy, see
990 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
992 if Partition_Elaboration_Policy
= 'S' then
996 Find_Enclosing_Context
(N
, Context
, Context_Id
, Decls
);
998 -- If activation chain entity has not been declared already, create one
1000 if Nkind
(Context
) = N_Extended_Return_Statement
1001 or else No
(Activation_Chain_Entity
(Context
))
1003 -- Since extended return statements do not store the entity of the
1004 -- chain, examine the return object declarations to avoid creating
1007 if Nkind
(Context
) = N_Extended_Return_Statement
1008 and then Has_Activation_Chain
(Context
)
1014 Loc
: constant Source_Ptr
:= Sloc
(Context
);
1019 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
1021 -- Note: An extended return statement is not really a task
1022 -- activator, but it does have an activation chain on which to
1023 -- store the tasks temporarily. On successful return, the tasks
1024 -- on this chain are moved to the chain passed in by the caller.
1025 -- We do not build an Activation_Chain_Entity for an extended
1026 -- return statement, because we do not want to build a call to
1027 -- Activate_Tasks. Task activation is the responsibility of the
1030 if Nkind
(Context
) /= N_Extended_Return_Statement
then
1031 Set_Activation_Chain_Entity
(Context
, Chain
);
1035 Make_Object_Declaration
(Loc
,
1036 Defining_Identifier
=> Chain
,
1037 Aliased_Present
=> True,
1038 Object_Definition
=>
1039 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
));
1041 Prepend_To
(Decls
, Decl
);
1043 -- Ensure that _chain appears in the proper scope of the context
1045 if Context_Id
/= Current_Scope
then
1046 Push_Scope
(Context_Id
);
1054 end Build_Activation_Chain_Entity
;
1056 ----------------------------
1057 -- Build_Barrier_Function --
1058 ----------------------------
1060 function Build_Barrier_Function
1063 Pid
: Entity_Id
) return Node_Id
1065 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
1066 Cond
: constant Node_Id
:= Condition
(Ent_Formals
);
1067 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
1068 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
1069 Op_Decls
: constant List_Id
:= New_List
;
1071 Func_Body
: Node_Id
;
1074 -- Add a declaration for the Protection object, renaming declarations
1075 -- for the discriminals and privals and finally a declaration for the
1076 -- entry family index (if applicable).
1078 Install_Private_Data_Declarations
(Sloc
(N
),
1084 Family
=> Ekind
(Ent
) = E_Entry_Family
);
1086 -- If compiling with -fpreserve-control-flow, make sure we insert an
1087 -- IF statement so that the back-end knows to generate a conditional
1088 -- branch instruction, even if the condition is just the name of a
1089 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1090 -- such redundant IF statements under -fpreserve-control-flow
1091 -- (whether coming from this routine, or directly from source).
1093 if Opt
.Suppress_Control_Flow_Optimizations
then
1095 Make_Implicit_If_Statement
(Cond
,
1097 Then_Statements
=> New_List
(
1098 Make_Simple_Return_Statement
(Loc
,
1099 New_Occurrence_Of
(Standard_True
, Loc
))),
1101 Else_Statements
=> New_List
(
1102 Make_Simple_Return_Statement
(Loc
,
1103 New_Occurrence_Of
(Standard_False
, Loc
))));
1106 Stmt
:= Make_Simple_Return_Statement
(Loc
, Cond
);
1109 -- Note: the condition in the barrier function needs to be properly
1110 -- processed for the C/Fortran boolean possibility, but this happens
1111 -- automatically since the return statement does this normalization.
1114 Make_Subprogram_Body
(Loc
,
1116 Build_Barrier_Function_Specification
(Loc
,
1117 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
1118 Declarations
=> Op_Decls
,
1119 Handled_Statement_Sequence
=>
1120 Make_Handled_Sequence_Of_Statements
(Loc
,
1121 Statements
=> New_List
(Stmt
)));
1122 Set_Is_Entry_Barrier_Function
(Func_Body
);
1125 end Build_Barrier_Function
;
1127 ------------------------------------------
1128 -- Build_Barrier_Function_Specification --
1129 ------------------------------------------
1131 function Build_Barrier_Function_Specification
1133 Def_Id
: Entity_Id
) return Node_Id
1136 Set_Debug_Info_Needed
(Def_Id
);
1139 Make_Function_Specification
(Loc
,
1140 Defining_Unit_Name
=> Def_Id
,
1141 Parameter_Specifications
=> New_List
(
1142 Make_Parameter_Specification
(Loc
,
1143 Defining_Identifier
=>
1144 Make_Defining_Identifier
(Loc
, Name_uO
),
1146 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
1148 Make_Parameter_Specification
(Loc
,
1149 Defining_Identifier
=>
1150 Make_Defining_Identifier
(Loc
, Name_uE
),
1152 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
1154 Result_Definition
=>
1155 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1156 end Build_Barrier_Function_Specification
;
1158 --------------------------
1159 -- Build_Call_With_Task --
1160 --------------------------
1162 function Build_Call_With_Task
1164 E
: Entity_Id
) return Node_Id
1166 Loc
: constant Source_Ptr
:= Sloc
(N
);
1169 Make_Function_Call
(Loc
,
1170 Name
=> New_Occurrence_Of
(E
, Loc
),
1171 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
1172 end Build_Call_With_Task
;
1174 -----------------------------
1175 -- Build_Class_Wide_Master --
1176 -----------------------------
1178 procedure Build_Class_Wide_Master
(Typ
: Entity_Id
) is
1179 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1180 Master_Decl
: Node_Id
;
1181 Master_Id
: Entity_Id
;
1182 Master_Scope
: Entity_Id
;
1184 Related_Node
: Node_Id
;
1188 -- No action needed if the run-time has no tasking support
1190 if Global_No_Tasking
then
1194 -- Find the declaration that created the access type, which is either a
1195 -- type declaration, or an object declaration with an access definition,
1196 -- in which case the type is anonymous.
1198 if Is_Itype
(Typ
) then
1199 Related_Node
:= Associated_Node_For_Itype
(Typ
);
1201 Related_Node
:= Parent
(Typ
);
1204 Master_Scope
:= Find_Master_Scope
(Typ
);
1206 -- Nothing to do if the master scope already contains a _master entity.
1207 -- The only exception to this is the following scenario:
1210 -- Transient_Scope_1
1213 -- Transient_Scope_2
1216 -- In this case the source scope is marked as having the master entity
1217 -- even though the actual declaration appears inside an inner scope. If
1218 -- the second transient scope requires a _master, it cannot use the one
1219 -- already declared because the entity is not visible.
1221 Name_Id
:= Make_Identifier
(Loc
, Name_uMaster
);
1222 Master_Decl
:= Empty
;
1224 if not Has_Master_Entity
(Master_Scope
)
1225 or else No
(Current_Entity_In_Scope
(Name_Id
))
1231 Set_Has_Master_Entity
(Master_Scope
);
1232 Master_Decl
:= Build_Master_Declaration
(Loc
);
1234 -- Ensure that the master declaration is placed before its use
1236 Ins_Nod
:= Find_Hook_Context
(Related_Node
);
1237 while not Is_List_Member
(Ins_Nod
) loop
1238 Ins_Nod
:= Parent
(Ins_Nod
);
1241 Insert_Before
(First
(List_Containing
(Ins_Nod
)), Master_Decl
);
1242 Analyze
(Master_Decl
);
1244 -- Mark the containing scope as a task master. Masters associated
1245 -- with return statements are already marked at this stage (see
1246 -- Analyze_Subprogram_Body).
1248 if Ekind
(Current_Scope
) /= E_Return_Statement
then
1250 Par
: Node_Id
:= Related_Node
;
1253 while Nkind
(Par
) /= N_Compilation_Unit
loop
1254 Par
:= Parent
(Par
);
1256 -- If we fall off the top, we are at the outer level,
1257 -- and the environment task is our effective master,
1258 -- so nothing to mark.
1261 N_Block_Statement | N_Subprogram_Body | N_Task_Body
1263 Set_Is_Task_Master
(Par
);
1273 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(Typ
), 'M'));
1276 -- typeMnn renames _master;
1279 Make_Object_Renaming_Declaration
(Loc
,
1280 Defining_Identifier
=> Master_Id
,
1281 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
1284 -- If the master is declared locally, add the renaming declaration
1285 -- immediately after it, to prevent access-before-elaboration in the
1288 if Present
(Master_Decl
) then
1289 Insert_After
(Master_Decl
, Ren_Decl
);
1293 Insert_Action
(Related_Node
, Ren_Decl
);
1296 Set_Master_Id
(Typ
, Master_Id
);
1297 end Build_Class_Wide_Master
;
1299 ----------------------------
1300 -- Build_Contract_Wrapper --
1301 ----------------------------
1303 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1304 Conc_Typ
: constant Entity_Id
:= Scope
(E
);
1305 Loc
: constant Source_Ptr
:= Sloc
(E
);
1307 procedure Add_Discriminant_Renamings
1308 (Obj_Id
: Entity_Id
;
1310 -- Add renaming declarations for all discriminants of concurrent type
1311 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1312 -- represents the concurrent object.
1314 procedure Add_Matching_Formals
1316 Actuals
: in out List_Id
);
1317 -- Add formal parameters that match those of entry E to list Formals.
1318 -- The routine also adds matching actuals for the new formals to list
1321 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
);
1322 -- Relocate pragma Prag to list To. The routine creates a new list if
1323 -- To does not exist.
1325 --------------------------------
1326 -- Add_Discriminant_Renamings --
1327 --------------------------------
1329 procedure Add_Discriminant_Renamings
1330 (Obj_Id
: Entity_Id
;
1336 -- Inspect the discriminants of the concurrent type and generate a
1337 -- renaming for each one.
1339 if Has_Discriminants
(Conc_Typ
) then
1340 Discr
:= First_Discriminant
(Conc_Typ
);
1341 while Present
(Discr
) loop
1343 Make_Object_Renaming_Declaration
(Loc
,
1344 Defining_Identifier
=>
1345 Make_Defining_Identifier
(Loc
, Chars
(Discr
)),
1347 New_Occurrence_Of
(Etype
(Discr
), Loc
),
1349 Make_Selected_Component
(Loc
,
1350 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1352 Make_Identifier
(Loc
, Chars
(Discr
)))));
1354 Next_Discriminant
(Discr
);
1357 end Add_Discriminant_Renamings
;
1359 --------------------------
1360 -- Add_Matching_Formals --
1361 --------------------------
1363 procedure Add_Matching_Formals
1365 Actuals
: in out List_Id
)
1368 New_Formal
: Entity_Id
;
1371 -- Inspect the formal parameters of the entry and generate a new
1372 -- matching formal with the same name for the wrapper. A reference
1373 -- to the new formal becomes an actual in the entry call.
1375 Formal
:= First_Formal
(E
);
1376 while Present
(Formal
) loop
1377 New_Formal
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1379 Make_Parameter_Specification
(Loc
,
1380 Defining_Identifier
=> New_Formal
,
1381 In_Present
=> In_Present
(Parent
(Formal
)),
1382 Out_Present
=> Out_Present
(Parent
(Formal
)),
1384 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
1386 if No
(Actuals
) then
1387 Actuals
:= New_List
;
1390 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
1391 Next_Formal
(Formal
);
1393 end Add_Matching_Formals
;
1395 ---------------------
1396 -- Transfer_Pragma --
1397 ---------------------
1399 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
) is
1407 New_Prag
:= Relocate_Node
(Prag
);
1409 Set_Analyzed
(New_Prag
, False);
1410 Append
(New_Prag
, To
);
1411 end Transfer_Pragma
;
1415 Items
: constant Node_Id
:= Contract
(E
);
1416 Actuals
: List_Id
:= No_List
;
1419 Decls
: List_Id
:= No_List
;
1421 Has_Pragma
: Boolean := False;
1422 Index_Id
: Entity_Id
;
1425 Wrapper_Id
: Entity_Id
;
1427 -- Start of processing for Build_Contract_Wrapper
1430 -- This routine generates a specialized wrapper for a protected or task
1431 -- entry [family] which implements precondition/postcondition semantics.
1432 -- Preconditions and case guards of contract cases are checked before
1433 -- the protected action or rendezvous takes place. Postconditions and
1434 -- consequences of contract cases are checked after the protected action
1435 -- or rendezvous takes place. The structure of the generated wrapper is
1438 -- procedure Wrapper
1439 -- (Obj_Id : Conc_Typ; -- concurrent object
1440 -- [Index : Index_Typ;] -- index of entry family
1441 -- [Formal_1 : ...; -- parameters of original entry
1444 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1445 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1447 -- <precondition checks>
1448 -- <case guard checks>
1450 -- procedure _Postconditions is
1452 -- <postcondition checks>
1453 -- <consequence checks>
1454 -- end _Postconditions;
1457 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1461 -- Create the wrapper only when the entry has at least one executable
1462 -- contract item such as contract cases, precondition or postcondition.
1464 if Present
(Items
) then
1466 -- Inspect the list of pre/postconditions and transfer all available
1467 -- pragmas to the declarative list of the wrapper.
1469 Prag
:= Pre_Post_Conditions
(Items
);
1470 while Present
(Prag
) loop
1471 if Pragma_Name_Unmapped
(Prag
) in Name_Postcondition
1473 and then Is_Checked
(Prag
)
1476 Transfer_Pragma
(Prag
, To
=> Decls
);
1479 Prag
:= Next_Pragma
(Prag
);
1482 -- Inspect the list of test/contract cases and transfer only contract
1483 -- cases pragmas to the declarative part of the wrapper.
1485 Prag
:= Contract_Test_Cases
(Items
);
1486 while Present
(Prag
) loop
1487 if Pragma_Name
(Prag
) = Name_Contract_Cases
1488 and then Is_Checked
(Prag
)
1491 Transfer_Pragma
(Prag
, To
=> Decls
);
1494 Prag
:= Next_Pragma
(Prag
);
1498 -- The entry lacks executable contract items and a wrapper is not needed
1500 if not Has_Pragma
then
1504 -- Create the profile of the wrapper. The first formal parameter is the
1505 -- concurrent object.
1508 Make_Defining_Identifier
(Loc
,
1509 Chars
=> New_External_Name
(Chars
(Conc_Typ
), 'A'));
1511 Formals
:= New_List
(
1512 Make_Parameter_Specification
(Loc
,
1513 Defining_Identifier
=> Obj_Id
,
1514 Out_Present
=> True,
1516 Parameter_Type
=> New_Occurrence_Of
(Conc_Typ
, Loc
)));
1518 -- Construct the call to the original entry. The call will be gradually
1519 -- augmented with an optional entry index and extra parameters.
1522 Make_Selected_Component
(Loc
,
1523 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1524 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1526 -- When creating a wrapper for an entry family, the second formal is the
1529 if Ekind
(E
) = E_Entry_Family
then
1530 Index_Id
:= Make_Defining_Identifier
(Loc
, Name_I
);
1533 Make_Parameter_Specification
(Loc
,
1534 Defining_Identifier
=> Index_Id
,
1536 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1538 -- The call to the original entry becomes an indexed component to
1539 -- accommodate the entry index.
1542 Make_Indexed_Component
(Loc
,
1544 Expressions
=> New_List
(New_Occurrence_Of
(Index_Id
, Loc
)));
1547 -- Add formal parameters to match those of the entry and build actuals
1548 -- for the entry call.
1550 Add_Matching_Formals
(Formals
, Actuals
);
1553 Make_Procedure_Call_Statement
(Loc
,
1555 Parameter_Associations
=> Actuals
);
1557 -- Add renaming declarations for the discriminants of the enclosing type
1558 -- as the various contract items may reference them.
1560 Add_Discriminant_Renamings
(Obj_Id
, Decls
);
1563 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(E
), 'E'));
1564 Set_Contract_Wrapper
(E
, Wrapper_Id
);
1565 Set_Is_Entry_Wrapper
(Wrapper_Id
);
1567 -- The wrapper body is analyzed when the enclosing type is frozen
1569 Append_Freeze_Action
(Defining_Entity
(Decl
),
1570 Make_Subprogram_Body
(Loc
,
1572 Make_Procedure_Specification
(Loc
,
1573 Defining_Unit_Name
=> Wrapper_Id
,
1574 Parameter_Specifications
=> Formals
),
1575 Declarations
=> Decls
,
1576 Handled_Statement_Sequence
=>
1577 Make_Handled_Sequence_Of_Statements
(Loc
,
1578 Statements
=> New_List
(Call
))));
1579 end Build_Contract_Wrapper
;
1581 --------------------------------
1582 -- Build_Corresponding_Record --
1583 --------------------------------
1585 function Build_Corresponding_Record
1588 Loc
: Source_Ptr
) return Node_Id
1590 Rec_Ent
: constant Entity_Id
:=
1591 Make_Defining_Identifier
1592 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1595 New_Disc
: Entity_Id
;
1599 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1600 Mutate_Ekind
(Rec_Ent
, E_Record_Type
);
1601 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1602 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1603 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1604 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1607 -- Use discriminals to create list of discriminants for record, and
1608 -- create new discriminals for use in default expressions, etc. It is
1609 -- worth noting that a task discriminant gives rise to 5 entities;
1611 -- a) The original discriminant.
1612 -- b) The discriminal for use in the task.
1613 -- c) The discriminant of the corresponding record.
1614 -- d) The discriminal for the init proc of the corresponding record.
1615 -- e) The local variable that renames the discriminant in the procedure
1616 -- for the task body.
1618 -- In fact the discriminals b) are used in the renaming declarations
1619 -- for e). See details in einfo (Handling of Discriminants).
1621 if Present
(Discriminant_Specifications
(N
)) then
1623 Disc
:= First_Discriminant
(Ctyp
);
1625 while Present
(Disc
) loop
1626 New_Disc
:= CR_Discriminant
(Disc
);
1629 Make_Discriminant_Specification
(Loc
,
1630 Defining_Identifier
=> New_Disc
,
1631 Discriminant_Type
=>
1632 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1634 New_Copy
(Discriminant_Default_Value
(Disc
))));
1636 Next_Discriminant
(Disc
);
1643 -- Now we can construct the record type declaration. Note that this
1644 -- record is "limited tagged". It is "limited" to reflect the underlying
1645 -- limitedness of the task or protected object that it represents, and
1646 -- ensuring for example that it is properly passed by reference. It is
1647 -- "tagged" to give support to dispatching calls through interfaces. We
1648 -- propagate here the list of interfaces covered by the concurrent type
1649 -- (Ada 2005: AI-345).
1652 Make_Full_Type_Declaration
(Loc
,
1653 Defining_Identifier
=> Rec_Ent
,
1654 Discriminant_Specifications
=> Dlist
,
1656 Make_Record_Definition
(Loc
,
1658 Make_Component_List
(Loc
, Component_Items
=> Cdecls
),
1660 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1661 Interface_List
=> Interface_List
(N
),
1662 Limited_Present
=> True));
1663 end Build_Corresponding_Record
;
1665 ---------------------------------
1666 -- Build_Dispatching_Tag_Check --
1667 ---------------------------------
1669 function Build_Dispatching_Tag_Check
1671 N
: Node_Id
) return Node_Id
1673 Loc
: constant Source_Ptr
:= Sloc
(N
);
1680 New_Occurrence_Of
(K
, Loc
),
1682 New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
1686 New_Occurrence_Of
(K
, Loc
),
1688 New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
)));
1689 end Build_Dispatching_Tag_Check
;
1691 ----------------------------------
1692 -- Build_Entry_Count_Expression --
1693 ----------------------------------
1695 function Build_Entry_Count_Expression
1696 (Concurrent_Type
: Node_Id
;
1697 Component_List
: List_Id
;
1698 Loc
: Source_Ptr
) return Node_Id
1710 -- Count number of non-family entries
1713 Ent
:= First_Entity
(Concurrent_Type
);
1714 while Present
(Ent
) loop
1715 if Ekind
(Ent
) = E_Entry
then
1722 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1724 -- Loop through entry families building the addition nodes
1726 Ent
:= First_Entity
(Concurrent_Type
);
1727 Comp
:= First
(Component_List
);
1728 while Present
(Ent
) loop
1729 if Ekind
(Ent
) = E_Entry_Family
then
1730 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1734 Typ
:= Entry_Index_Type
(Ent
);
1735 Hi
:= Type_High_Bound
(Typ
);
1736 Lo
:= Type_Low_Bound
(Typ
);
1737 Large
:= Is_Potentially_Large_Family
1738 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1741 Left_Opnd
=> Ecount
,
1743 Family_Size
(Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1750 end Build_Entry_Count_Expression
;
1752 ------------------------------
1753 -- Build_Master_Declaration --
1754 ------------------------------
1756 function Build_Master_Declaration
(Loc
: Source_Ptr
) return Node_Id
is
1757 Master_Decl
: Node_Id
;
1760 -- Generate a dummy master if tasks or tasking hierarchies are
1763 -- _Master : constant Integer := Library_Task_Level;
1765 if not Tasking_Allowed
1766 or else Restrictions
.Set
(No_Task_Hierarchy
)
1767 or else not RTE_Available
(RE_Current_Master
)
1770 Make_Object_Declaration
(Loc
,
1771 Defining_Identifier
=>
1772 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1773 Constant_Present
=> True,
1774 Object_Definition
=>
1775 New_Occurrence_Of
(Standard_Integer
, Loc
),
1777 Make_Integer_Literal
(Loc
, Library_Task_Level
));
1780 -- _master : constant Integer := Current_Master.all;
1784 Make_Object_Declaration
(Loc
,
1785 Defining_Identifier
=>
1786 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1787 Constant_Present
=> True,
1788 Object_Definition
=>
1789 New_Occurrence_Of
(Standard_Integer
, Loc
),
1791 Make_Explicit_Dereference
(Loc
,
1792 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
1796 end Build_Master_Declaration
;
1798 ---------------------------
1799 -- Build_Parameter_Block --
1800 ---------------------------
1802 function Build_Parameter_Block
1806 Decls
: List_Id
) return Entity_Id
1812 Has_Comp
: Boolean := False;
1816 Actual
:= First
(Actuals
);
1818 Formal
:= Defining_Identifier
(First
(Formals
));
1820 while Present
(Actual
) loop
1821 if not Is_Controlling_Actual
(Actual
) then
1824 -- type Ann is access all <actual-type>
1826 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
1827 Set_Is_Param_Block_Component_Type
(Comp_Nam
);
1830 Make_Full_Type_Declaration
(Loc
,
1831 Defining_Identifier
=> Comp_Nam
,
1833 Make_Access_To_Object_Definition
(Loc
,
1834 All_Present
=> True,
1835 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
1836 Subtype_Indication
=>
1837 New_Occurrence_Of
(Etype
(Actual
), Loc
))));
1843 Make_Component_Declaration
(Loc
,
1844 Defining_Identifier
=>
1845 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
1846 Component_Definition
=>
1847 Make_Component_Definition
(Loc
,
1850 Subtype_Indication
=>
1851 New_Occurrence_Of
(Comp_Nam
, Loc
))));
1856 Next_Actual
(Actual
);
1857 Next_Formal_With_Extras
(Formal
);
1860 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
1865 -- type Pnn is record
1870 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1871 -- the original parameter names and Ann1 .. AnnN are the access to
1875 Make_Full_Type_Declaration
(Loc
,
1876 Defining_Identifier
=>
1879 Make_Record_Definition
(Loc
,
1881 Make_Component_List
(Loc
, Comps
))));
1884 -- type Pnn is null record;
1887 Make_Full_Type_Declaration
(Loc
,
1888 Defining_Identifier
=>
1891 Make_Record_Definition
(Loc
,
1892 Null_Present
=> True,
1893 Component_List
=> Empty
)));
1897 end Build_Parameter_Block
;
1899 --------------------------------------
1900 -- Build_Renamed_Formal_Declaration --
1901 --------------------------------------
1903 function Build_Renamed_Formal_Declaration
1907 Renamed_Formal
: Node_Id
) return Node_Id
1909 Loc
: constant Source_Ptr
:= Sloc
(New_F
);
1913 -- If the formal is a tagged incomplete type, it is already passed
1914 -- by reference, so it is sufficient to rename the pointer component
1915 -- that corresponds to the actual. Otherwise we need to dereference
1916 -- the pointer component to obtain the actual.
1918 if Is_Incomplete_Type
(Etype
(Formal
))
1919 and then Is_Tagged_Type
(Etype
(Formal
))
1922 Make_Object_Renaming_Declaration
(Loc
,
1923 Defining_Identifier
=> New_F
,
1924 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Comp
), Loc
),
1925 Name
=> Renamed_Formal
);
1929 Make_Object_Renaming_Declaration
(Loc
,
1930 Defining_Identifier
=> New_F
,
1931 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Formal
), Loc
),
1933 Make_Explicit_Dereference
(Loc
, Renamed_Formal
));
1937 end Build_Renamed_Formal_Declaration
;
1939 --------------------------
1940 -- Build_Wrapper_Bodies --
1941 --------------------------
1943 procedure Build_Wrapper_Bodies
1948 Rec_Typ
: Entity_Id
;
1950 function Build_Wrapper_Body
1952 Subp_Id
: Entity_Id
;
1953 Obj_Typ
: Entity_Id
;
1954 Formals
: List_Id
) return Node_Id
;
1955 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1956 -- associated with a protected or task type. Subp_Id is the subprogram
1957 -- name which will be wrapped. Obj_Typ is the type of the new formal
1958 -- parameter which handles dispatching and object notation. Formals are
1959 -- the original formals of Subp_Id which will be explicitly replicated.
1961 ------------------------
1962 -- Build_Wrapper_Body --
1963 ------------------------
1965 function Build_Wrapper_Body
1967 Subp_Id
: Entity_Id
;
1968 Obj_Typ
: Entity_Id
;
1969 Formals
: List_Id
) return Node_Id
1971 Body_Spec
: Node_Id
;
1974 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
1976 -- The subprogram is not overriding or is not a primitive declared
1977 -- between two views.
1979 if No
(Body_Spec
) then
1984 Actuals
: List_Id
:= No_List
;
1986 First_Form
: Node_Id
;
1991 -- Map formals to actuals. Use the list built for the wrapper
1992 -- spec, skipping the object notation parameter.
1994 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
1996 Formal
:= First_Form
;
1999 if Present
(Formal
) then
2000 Actuals
:= New_List
;
2001 while Present
(Formal
) loop
2003 Make_Identifier
(Loc
,
2004 Chars
=> Chars
(Defining_Identifier
(Formal
))));
2009 -- Special processing for primitives declared between a private
2010 -- type and its completion: the wrapper needs a properly typed
2011 -- parameter if the wrapped operation has a controlling first
2012 -- parameter. Note that this might not be the case for a function
2013 -- with a controlling result.
2015 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
2016 if No
(Actuals
) then
2017 Actuals
:= New_List
;
2020 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
2021 Prepend_To
(Actuals
,
2022 Unchecked_Convert_To
2023 (Corresponding_Concurrent_Type
(Obj_Typ
),
2024 Make_Identifier
(Loc
, Name_uO
)));
2027 Prepend_To
(Actuals
,
2028 Make_Identifier
(Loc
,
2029 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
2032 Nam
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2034 -- An access-to-variable object parameter requires an explicit
2035 -- dereference in the unchecked conversion. This case occurs
2036 -- when a protected entry wrapper must override an interface
2037 -- level procedure with interface access as first parameter.
2039 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
2041 if Nkind
(Parameter_Type
(First_Form
)) =
2045 Make_Explicit_Dereference
(Loc
,
2046 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
2048 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
2052 Make_Selected_Component
(Loc
,
2054 Unchecked_Convert_To
2055 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
2056 Selector_Name
=> New_Occurrence_Of
(Subp_Id
, Loc
));
2059 -- Create the subprogram body. For a function, the call to the
2060 -- actual subprogram has to be converted to the corresponding
2061 -- record if it is a controlling result.
2063 if Ekind
(Subp_Id
) = E_Function
then
2069 Make_Function_Call
(Loc
,
2071 Parameter_Associations
=> Actuals
);
2073 if Has_Controlling_Result
(Subp_Id
) then
2075 Unchecked_Convert_To
2076 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
2080 Make_Subprogram_Body
(Loc
,
2081 Specification
=> Body_Spec
,
2082 Declarations
=> Empty_List
,
2083 Handled_Statement_Sequence
=>
2084 Make_Handled_Sequence_Of_Statements
(Loc
,
2085 Statements
=> New_List
(
2086 Make_Simple_Return_Statement
(Loc
, Res
))));
2091 Make_Subprogram_Body
(Loc
,
2092 Specification
=> Body_Spec
,
2093 Declarations
=> Empty_List
,
2094 Handled_Statement_Sequence
=>
2095 Make_Handled_Sequence_Of_Statements
(Loc
,
2096 Statements
=> New_List
(
2097 Make_Procedure_Call_Statement
(Loc
,
2099 Parameter_Associations
=> Actuals
))));
2102 end Build_Wrapper_Body
;
2104 -- Start of processing for Build_Wrapper_Bodies
2107 if Is_Concurrent_Type
(Typ
) then
2108 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2113 -- Generate wrapper bodies for a concurrent type which implements an
2116 if Present
(Interfaces
(Rec_Typ
)) then
2118 Insert_Nod
: Node_Id
;
2120 Prim_Elmt
: Elmt_Id
;
2121 Prim_Decl
: Node_Id
;
2123 Wrap_Body
: Node_Id
;
2124 Wrap_Id
: Entity_Id
;
2129 -- Examine all primitive operations of the corresponding record
2130 -- type, looking for wrapper specs. Generate bodies in order to
2133 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
2134 while Present
(Prim_Elmt
) loop
2135 Prim
:= Node
(Prim_Elmt
);
2137 if (Ekind
(Prim
) = E_Function
2138 or else Ekind
(Prim
) = E_Procedure
)
2139 and then Is_Primitive_Wrapper
(Prim
)
2141 Subp
:= Wrapped_Entity
(Prim
);
2142 Prim_Decl
:= Parent
(Parent
(Prim
));
2145 Build_Wrapper_Body
(Loc
,
2148 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
2149 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
2151 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
2152 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
2154 Insert_After
(Insert_Nod
, Wrap_Body
);
2155 Insert_Nod
:= Wrap_Body
;
2157 Analyze
(Wrap_Body
);
2160 Next_Elmt
(Prim_Elmt
);
2164 end Build_Wrapper_Bodies
;
2166 ------------------------
2167 -- Build_Wrapper_Spec --
2168 ------------------------
2170 function Build_Wrapper_Spec
2171 (Subp_Id
: Entity_Id
;
2172 Obj_Typ
: Entity_Id
;
2173 Formals
: List_Id
) return Node_Id
2175 function Overriding_Possible
2176 (Iface_Op
: Entity_Id
;
2177 Wrapper
: Entity_Id
) return Boolean;
2178 -- Determine whether a primitive operation can be overridden by Wrapper.
2179 -- Iface_Op is the candidate primitive operation of an interface type,
2180 -- Wrapper is the generated entry wrapper.
2182 function Replicate_Formals
2184 Formals
: List_Id
) return List_Id
;
2185 -- An explicit parameter replication is required due to the Is_Entry_
2186 -- Formal flag being set for all the formals of an entry. The explicit
2187 -- replication removes the flag that would otherwise cause a different
2188 -- path of analysis.
2190 -------------------------
2191 -- Overriding_Possible --
2192 -------------------------
2194 function Overriding_Possible
2195 (Iface_Op
: Entity_Id
;
2196 Wrapper
: Entity_Id
) return Boolean
2198 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2199 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2201 function Type_Conformant_Parameters
2202 (Iface_Op_Params
: List_Id
;
2203 Wrapper_Params
: List_Id
) return Boolean;
2204 -- Determine whether the parameters of the generated entry wrapper
2205 -- and those of a primitive operation are type conformant. During
2206 -- this check, the first parameter of the primitive operation is
2207 -- skipped if it is a controlling argument: protected functions
2208 -- may have a controlling result.
2210 --------------------------------
2211 -- Type_Conformant_Parameters --
2212 --------------------------------
2214 function Type_Conformant_Parameters
2215 (Iface_Op_Params
: List_Id
;
2216 Wrapper_Params
: List_Id
) return Boolean
2218 Iface_Op_Param
: Node_Id
;
2219 Iface_Op_Typ
: Entity_Id
;
2220 Wrapper_Param
: Node_Id
;
2221 Wrapper_Typ
: Entity_Id
;
2224 -- Skip the first (controlling) parameter of primitive operation
2226 Iface_Op_Param
:= First
(Iface_Op_Params
);
2228 if Present
(First_Formal
(Iface_Op
))
2229 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2231 Next
(Iface_Op_Param
);
2234 Wrapper_Param
:= First
(Wrapper_Params
);
2235 while Present
(Iface_Op_Param
)
2236 and then Present
(Wrapper_Param
)
2238 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2239 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2241 -- The two parameters must be mode conformant
2243 if not Conforming_Types
2244 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2249 Next
(Iface_Op_Param
);
2250 Next
(Wrapper_Param
);
2253 -- One of the lists is longer than the other
2255 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2260 end Type_Conformant_Parameters
;
2262 -- Start of processing for Overriding_Possible
2265 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2269 -- If an inherited subprogram is implemented by a protected procedure
2270 -- or an entry, then the first parameter of the inherited subprogram
2271 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2273 if Ekind
(Iface_Op
) = E_Procedure
2274 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2277 Obj_Param
: constant Node_Id
:=
2278 First
(Parameter_Specifications
(Iface_Op_Spec
));
2280 if not Out_Present
(Obj_Param
)
2281 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2290 Type_Conformant_Parameters
2291 (Parameter_Specifications
(Iface_Op_Spec
),
2292 Parameter_Specifications
(Wrapper_Spec
));
2293 end Overriding_Possible
;
2295 -----------------------
2296 -- Replicate_Formals --
2297 -----------------------
2299 function Replicate_Formals
2301 Formals
: List_Id
) return List_Id
2303 New_Formals
: constant List_Id
:= New_List
;
2305 Param_Type
: Node_Id
;
2308 Formal
:= First
(Formals
);
2310 -- Skip the object parameter when dealing with primitives declared
2311 -- between two views.
2313 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2314 and then not Has_Controlling_Result
(Subp_Id
)
2319 while Present
(Formal
) loop
2321 -- Create an explicit copy of the entry parameter
2323 -- When creating the wrapper subprogram for a primitive operation
2324 -- of a protected interface we must construct an equivalent
2325 -- signature to that of the overriding operation. For regular
2326 -- parameters we can just use the type of the formal, but for
2327 -- access to subprogram parameters we need to reanalyze the
2328 -- parameter type to create local entities for the signature of
2329 -- the subprogram type. Using the entities of the overriding
2330 -- subprogram will result in out-of-scope errors in the back-end.
2332 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2333 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2336 New_Occurrence_Of
(Etype
(Parameter_Type
(Formal
)), Loc
);
2339 Append_To
(New_Formals
,
2340 Make_Parameter_Specification
(Loc
,
2341 Defining_Identifier
=>
2342 Make_Defining_Identifier
(Loc
,
2343 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2344 In_Present
=> In_Present
(Formal
),
2345 Out_Present
=> Out_Present
(Formal
),
2346 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
2347 Parameter_Type
=> Param_Type
));
2353 end Replicate_Formals
;
2357 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2358 First_Param
: Node_Id
:= Empty
;
2360 Iface_Elmt
: Elmt_Id
;
2361 Iface_Op
: Entity_Id
;
2362 Iface_Op_Elmt
: Elmt_Id
;
2363 Overridden_Subp
: Entity_Id
;
2365 -- Start of processing for Build_Wrapper_Spec
2368 -- No point in building wrappers for untagged concurrent types
2370 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2372 -- Check if this subprogram has a profile that matches some interface
2375 Check_Synchronized_Overriding
(Subp_Id
, Overridden_Subp
);
2377 if Present
(Overridden_Subp
) then
2379 First
(Parameter_Specifications
(Parent
(Overridden_Subp
)));
2381 -- An entry or a protected procedure can override a routine where the
2382 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2383 -- type. Since the wrapper must have the exact same signature as that of
2384 -- the overridden subprogram, we try to find the overriding candidate
2385 -- and use its controlling formal.
2387 -- Check every implemented interface
2389 elsif Present
(Interfaces
(Obj_Typ
)) then
2390 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2391 Search
: while Present
(Iface_Elmt
) loop
2392 Iface
:= Node
(Iface_Elmt
);
2394 -- Check every interface primitive
2396 if Present
(Primitive_Operations
(Iface
)) then
2397 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2398 while Present
(Iface_Op_Elmt
) loop
2399 Iface_Op
:= Node
(Iface_Op_Elmt
);
2401 -- Ignore predefined primitives
2403 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2404 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2406 -- The current primitive operation can be overridden by
2407 -- the generated entry wrapper.
2409 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2411 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2417 Next_Elmt
(Iface_Op_Elmt
);
2421 Next_Elmt
(Iface_Elmt
);
2425 -- Do not generate the wrapper if no interface primitive is covered by
2426 -- the subprogram and it is not a primitive declared between two views
2427 -- (see Process_Full_View).
2430 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2436 Wrapper_Id
: constant Entity_Id
:=
2437 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2438 New_Formals
: List_Id
;
2439 Obj_Param
: Node_Id
;
2440 Obj_Param_Typ
: Entity_Id
;
2443 -- Minimum decoration is needed to catch the entity in
2444 -- Sem_Ch6.Override_Dispatching_Operation.
2446 if Ekind
(Subp_Id
) = E_Function
then
2447 Mutate_Ekind
(Wrapper_Id
, E_Function
);
2449 Mutate_Ekind
(Wrapper_Id
, E_Procedure
);
2452 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2453 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2454 Set_Is_Private_Primitive
(Wrapper_Id
,
2455 Is_Private_Primitive_Subprogram
(Subp_Id
));
2457 -- Process the formals
2459 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2461 -- A function with a controlling result and no first controlling
2462 -- formal needs no additional parameter.
2464 if Has_Controlling_Result
(Subp_Id
)
2466 (No
(First_Formal
(Subp_Id
))
2467 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2471 -- Routine Subp_Id has been found to override an interface primitive.
2472 -- If the interface operation has an access parameter, create a copy
2473 -- of it, with the same null exclusion indicator if present.
2475 elsif Present
(First_Param
) then
2476 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2478 Make_Access_Definition
(Loc
,
2480 New_Occurrence_Of
(Obj_Typ
, Loc
),
2481 Null_Exclusion_Present
=>
2482 Null_Exclusion_Present
(Parameter_Type
(First_Param
)),
2484 Constant_Present
(Parameter_Type
(First_Param
)));
2486 Obj_Param_Typ
:= New_Occurrence_Of
(Obj_Typ
, Loc
);
2490 Make_Parameter_Specification
(Loc
,
2491 Defining_Identifier
=>
2492 Make_Defining_Identifier
(Loc
,
2494 In_Present
=> In_Present
(First_Param
),
2495 Out_Present
=> Out_Present
(First_Param
),
2496 Parameter_Type
=> Obj_Param_Typ
);
2498 Prepend_To
(New_Formals
, Obj_Param
);
2500 -- If we are dealing with a primitive declared between two views,
2501 -- implemented by a synchronized operation, we need to create
2502 -- a default parameter. The mode of the parameter must match that
2503 -- of the primitive operation.
2506 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2509 Make_Parameter_Specification
(Loc
,
2510 Defining_Identifier
=>
2511 Make_Defining_Identifier
(Loc
, Name_uO
),
2513 In_Present
(Parent
(First_Entity
(Subp_Id
))),
2514 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2515 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2517 Prepend_To
(New_Formals
, Obj_Param
);
2520 -- Build the final spec. If it is a function with a controlling
2521 -- result, it is a primitive operation of the corresponding
2522 -- record type, so mark the spec accordingly.
2524 if Ekind
(Subp_Id
) = E_Function
then
2529 if Has_Controlling_Result
(Subp_Id
) then
2532 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2534 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2538 Make_Function_Specification
(Loc
,
2539 Defining_Unit_Name
=> Wrapper_Id
,
2540 Parameter_Specifications
=> New_Formals
,
2541 Result_Definition
=> Res_Def
);
2545 Make_Procedure_Specification
(Loc
,
2546 Defining_Unit_Name
=> Wrapper_Id
,
2547 Parameter_Specifications
=> New_Formals
);
2550 end Build_Wrapper_Spec
;
2552 -------------------------
2553 -- Build_Wrapper_Specs --
2554 -------------------------
2556 procedure Build_Wrapper_Specs
2562 Rec_Typ
: Entity_Id
;
2563 procedure Scan_Declarations
(L
: List_Id
);
2564 -- Common processing for visible and private declarations
2565 -- of a protected type.
2567 procedure Scan_Declarations
(L
: List_Id
) is
2569 Wrap_Decl
: Node_Id
;
2570 Wrap_Spec
: Node_Id
;
2578 while Present
(Decl
) loop
2581 if Nkind
(Decl
) = N_Entry_Declaration
2582 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2586 (Subp_Id
=> Defining_Identifier
(Decl
),
2588 Formals
=> Parameter_Specifications
(Decl
));
2590 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2593 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2596 Parameter_Specifications
(Specification
(Decl
)));
2599 if Present
(Wrap_Spec
) then
2601 Make_Subprogram_Declaration
(Loc
,
2602 Specification
=> Wrap_Spec
);
2604 Insert_After
(N
, Wrap_Decl
);
2607 Analyze
(Wrap_Decl
);
2612 end Scan_Declarations
;
2614 -- start of processing for Build_Wrapper_Specs
2617 if Is_Protected_Type
(Typ
) then
2618 Def
:= Protected_Definition
(Parent
(Typ
));
2619 else pragma Assert
(Is_Task_Type
(Typ
));
2620 Def
:= Task_Definition
(Parent
(Typ
));
2623 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2625 -- Generate wrapper specs for a concurrent type which implements an
2626 -- interface. Operations in both the visible and private parts may
2627 -- implement progenitor operations.
2629 if Present
(Interfaces
(Rec_Typ
)) and then Present
(Def
) then
2630 Scan_Declarations
(Visible_Declarations
(Def
));
2631 Scan_Declarations
(Private_Declarations
(Def
));
2633 end Build_Wrapper_Specs
;
2635 ---------------------------
2636 -- Build_Find_Body_Index --
2637 ---------------------------
2639 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2640 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2643 Has_F
: Boolean := False;
2645 If_St
: Node_Id
:= Empty
;
2648 Decls
: List_Id
:= New_List
;
2649 Ret
: Node_Id
:= Empty
;
2651 Siz
: Node_Id
:= Empty
;
2653 procedure Add_If_Clause
(Expr
: Node_Id
);
2654 -- Add test for range of current entry
2656 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2657 -- If a bound of an entry is given by a discriminant, retrieve the
2658 -- actual value of the discriminant from the enclosing object.
2664 procedure Add_If_Clause
(Expr
: Node_Id
) is
2666 Stats
: constant List_Id
:=
2668 Make_Simple_Return_Statement
(Loc
,
2669 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2672 -- Index for current entry body
2676 -- Compute total length of entry queues so far
2684 Right_Opnd
=> Expr
);
2689 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2692 -- Map entry queue indexes in the range of the current family
2693 -- into the current index, that designates the entry body.
2697 Make_Implicit_If_Statement
(Typ
,
2699 Then_Statements
=> Stats
,
2700 Elsif_Parts
=> New_List
);
2704 Append_To
(Elsif_Parts
(If_St
),
2705 Make_Elsif_Part
(Loc
,
2707 Then_Statements
=> Stats
));
2711 ------------------------------
2712 -- Convert_Discriminant_Ref --
2713 ------------------------------
2715 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2719 if Is_Entity_Name
(Bound
)
2720 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2723 Make_Selected_Component
(Loc
,
2725 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2726 Make_Explicit_Dereference
(Loc
,
2727 Make_Identifier
(Loc
, Name_uObject
))),
2728 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
2729 Set_Etype
(B
, Etype
(Entity
(Bound
)));
2731 B
:= New_Copy_Tree
(Bound
);
2735 end Convert_Discriminant_Ref
;
2737 -- Start of processing for Build_Find_Body_Index
2740 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
2742 Ent
:= First_Entity
(Typ
);
2743 while Present
(Ent
) loop
2744 if Ekind
(Ent
) = E_Entry_Family
then
2754 -- If the protected type has no entry families, there is a one-one
2755 -- correspondence between entry queue and entry body.
2758 Make_Simple_Return_Statement
(Loc
,
2759 Expression
=> Make_Identifier
(Loc
, Name_uE
));
2762 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2765 -- if E <= l1 then return 1;
2766 -- elsif E <= l1 + l2 then return 2;
2771 Ent
:= First_Entity
(Typ
);
2773 Add_Object_Pointer
(Loc
, Typ
, Decls
);
2775 while Present
(Ent
) loop
2776 if Ekind
(Ent
) = E_Entry
then
2777 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
2779 elsif Ekind
(Ent
) = E_Entry_Family
then
2780 E_Typ
:= Entry_Index_Type
(Ent
);
2781 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
2782 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
2783 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
2792 Make_Simple_Return_Statement
(Loc
,
2793 Expression
=> Make_Integer_Literal
(Loc
, 1));
2796 pragma Assert
(Present
(Ret
));
2798 if Nkind
(Ret
) = N_If_Statement
then
2800 -- Ranges are in increasing order, so last one doesn't need
2804 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
2807 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
2814 Make_Subprogram_Body
(Loc
,
2815 Specification
=> Spec
,
2816 Declarations
=> Decls
,
2817 Handled_Statement_Sequence
=>
2818 Make_Handled_Sequence_Of_Statements
(Loc
,
2819 Statements
=> New_List
(Ret
)));
2820 end Build_Find_Body_Index
;
2822 --------------------------------
2823 -- Build_Find_Body_Index_Spec --
2824 --------------------------------
2826 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
2827 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2828 Id
: constant Entity_Id
:=
2829 Make_Defining_Identifier
(Loc
,
2830 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
2831 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
2832 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
2836 Make_Function_Specification
(Loc
,
2837 Defining_Unit_Name
=> Id
,
2838 Parameter_Specifications
=> New_List
(
2839 Make_Parameter_Specification
(Loc
,
2840 Defining_Identifier
=> Parm1
,
2842 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2844 Make_Parameter_Specification
(Loc
,
2845 Defining_Identifier
=> Parm2
,
2847 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
2849 Result_Definition
=> New_Occurrence_Of
(
2850 RTE
(RE_Protected_Entry_Index
), Loc
));
2851 end Build_Find_Body_Index_Spec
;
2853 -----------------------------------------------
2854 -- Build_Lock_Free_Protected_Subprogram_Body --
2855 -----------------------------------------------
2857 function Build_Lock_Free_Protected_Subprogram_Body
2860 Unprot_Spec
: Node_Id
) return Node_Id
2862 Actuals
: constant List_Id
:= New_List
;
2863 Loc
: constant Source_Ptr
:= Sloc
(N
);
2864 Spec
: constant Node_Id
:= Specification
(N
);
2865 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
2867 Prot_Spec
: Node_Id
;
2871 -- Create the protected version of the body
2874 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
2876 -- Build the actual parameters which appear in the call to the
2877 -- unprotected version of the body.
2879 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
2880 while Present
(Formal
) loop
2882 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
2887 -- Function case, generate:
2888 -- return <Unprot_Func_Call>;
2890 if Nkind
(Spec
) = N_Function_Specification
then
2892 Make_Simple_Return_Statement
(Loc
,
2894 Make_Function_Call
(Loc
,
2896 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2897 Parameter_Associations
=> Actuals
));
2899 -- Procedure case, call the unprotected version
2903 Make_Procedure_Call_Statement
(Loc
,
2905 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2906 Parameter_Associations
=> Actuals
);
2910 Make_Subprogram_Body
(Loc
,
2911 Declarations
=> Empty_List
,
2912 Specification
=> Prot_Spec
,
2913 Handled_Statement_Sequence
=>
2914 Make_Handled_Sequence_Of_Statements
(Loc
,
2915 Statements
=> New_List
(Stmt
)));
2916 end Build_Lock_Free_Protected_Subprogram_Body
;
2918 -------------------------------------------------
2919 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2920 -------------------------------------------------
2922 -- Procedures which meet the lock-free implementation requirements and
2923 -- reference a unique scalar component Comp are expanded in the following
2926 -- procedure P (...) is
2927 -- Expected_Comp : constant Comp_Type :=
2929 -- (System.Atomic_Primitives.Lock_Free_Read_N
2930 -- (_Object.Comp'Address));
2934 -- <original declarations before the object renaming declaration
2937 -- Desired_Comp : Comp_Type := Expected_Comp;
2938 -- Comp : Comp_Type renames Desired_Comp;
2940 -- <original declarations after the object renaming declaration
2944 -- <original statements>
2945 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2946 -- (_Object.Comp'Address,
2947 -- Interfaces.Unsigned_N (Expected_Comp),
2948 -- Interfaces.Unsigned_N (Desired_Comp));
2953 -- Each return and raise statement of P is transformed into an atomic
2956 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2957 -- (_Object.Comp'Address,
2958 -- Interfaces.Unsigned_N (Expected_Comp),
2959 -- Interfaces.Unsigned_N (Desired_Comp));
2961 -- <original statement>
2966 -- Functions which meet the lock-free implementation requirements and
2967 -- reference a unique scalar component Comp are expanded in the following
2970 -- function F (...) return ... is
2971 -- <original declarations before the object renaming declaration
2974 -- Expected_Comp : constant Comp_Type :=
2976 -- (System.Atomic_Primitives.Lock_Free_Read_N
2977 -- (_Object.Comp'Address));
2978 -- Comp : Comp_Type renames Expected_Comp;
2980 -- <original declarations after the object renaming declaration of
2984 -- <original statements>
2987 function Build_Lock_Free_Unprotected_Subprogram_Body
2989 Prot_Typ
: Node_Id
) return Node_Id
2991 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
2992 -- Subprograms which meet the lock-free implementation criteria are
2993 -- allowed to reference only one unique component. Return the prival
2994 -- of the said component.
2996 --------------------------
2997 -- Referenced_Component --
2998 --------------------------
3000 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
3003 Source_Comp
: Entity_Id
:= Empty
;
3006 -- Find the unique source component which N references in its
3009 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
3011 Element
: Lock_Free_Subprogram
renames
3012 Lock_Free_Subprogram_Table
.Table
(Index
);
3014 if Element
.Sub_Body
= N
then
3015 Source_Comp
:= Element
.Comp_Id
;
3021 if No
(Source_Comp
) then
3025 -- Find the prival which corresponds to the source component within
3026 -- the declarations of N.
3028 Decl
:= First
(Declarations
(N
));
3029 while Present
(Decl
) loop
3031 -- Privals appear as object renamings
3033 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
3034 Comp
:= Defining_Identifier
(Decl
);
3036 if Present
(Prival_Link
(Comp
))
3037 and then Prival_Link
(Comp
) = Source_Comp
3047 end Referenced_Component
;
3051 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
3052 Loc
: constant Source_Ptr
:= Sloc
(N
);
3053 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
3054 Decls
: List_Id
:= Declarations
(N
);
3056 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
3059 -- Add renamings for the protection object, discriminals, privals, and
3060 -- the entry index constant for use by debugger.
3062 Debug_Private_Data_Declarations
(Decls
);
3064 -- Perform the lock-free expansion when the subprogram references a
3065 -- protected component.
3067 if Present
(Comp
) then
3068 Protected_Component_Ref
: declare
3069 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3070 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
3071 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
3073 Is_Procedure
: constant Boolean :=
3074 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
3075 -- Indicates if N is a protected procedure body
3077 Block_Decls
: List_Id
:= No_List
;
3078 Try_Write
: Entity_Id
;
3079 Desired_Comp
: Entity_Id
;
3082 Label_Id
: Entity_Id
:= Empty
;
3084 Expected_Comp
: Entity_Id
;
3087 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
3089 Unsigned
: Entity_Id
;
3091 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
3092 -- Transform a single node if it is a return statement, a raise
3093 -- statement or a reference to Comp.
3095 procedure Process_Stmts
(Stmts
: List_Id
);
3096 -- Given a statement sequence Stmts, wrap any return or raise
3097 -- statements in the following manner:
3099 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3100 -- (_Object.Comp'Address,
3101 -- Interfaces.Unsigned_N (Expected_Comp),
3102 -- Interfaces.Unsigned_N (Desired_Comp))
3113 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3115 procedure Wrap_Statement
(Stmt
: Node_Id
);
3116 -- Wrap an arbitrary statement inside an if statement where the
3117 -- condition does an atomic check on the state of the object.
3119 --------------------
3120 -- Wrap_Statement --
3121 --------------------
3123 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3125 -- The first time through, create the declaration of a label
3126 -- which is used to skip the remainder of source statements
3127 -- if the state of the object has changed.
3129 if No
(Label_Id
) then
3131 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3132 Set_Entity
(Label_Id
,
3133 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3137 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3138 -- (_Object.Comp'Address,
3139 -- Interfaces.Unsigned_N (Expected_Comp),
3140 -- Interfaces.Unsigned_N (Desired_Comp))
3148 Make_Implicit_If_Statement
(N
,
3150 Make_Function_Call
(Loc
,
3152 New_Occurrence_Of
(Try_Write
, Loc
),
3153 Parameter_Associations
=> New_List
(
3154 Make_Attribute_Reference
(Loc
,
3155 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3156 Attribute_Name
=> Name_Address
),
3158 Unchecked_Convert_To
(Unsigned
,
3159 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3161 Unchecked_Convert_To
(Unsigned
,
3162 New_Occurrence_Of
(Desired_Comp
, Loc
)))),
3164 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3166 Else_Statements
=> New_List
(
3167 Make_Goto_Statement
(Loc
,
3169 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3172 -- Start of processing for Process_Node
3175 -- Wrap each return and raise statement that appear inside a
3176 -- procedure. Skip the last return statement which is added by
3177 -- default since it is transformed into an exit statement.
3180 and then ((Nkind
(N
) = N_Simple_Return_Statement
3181 and then N
/= Last
(Stmts
))
3182 or else Nkind
(N
) = N_Extended_Return_Statement
3183 or else (Nkind
(N
) in
3184 N_Raise_xxx_Error | N_Raise_Statement
3185 and then Comes_From_Source
(N
)))
3193 Set_Analyzed
(N
, False);
3198 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3204 procedure Process_Stmts
(Stmts
: List_Id
) is
3207 Stmt
:= First
(Stmts
);
3208 while Present
(Stmt
) loop
3209 Process_Nodes
(Stmt
);
3214 -- Start of processing for Protected_Component_Ref
3217 -- Get the type size
3219 if Known_Static_Esize
(Comp_Type
) then
3220 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3222 -- If the Esize (Object_Size) is unknown at compile time, look at
3223 -- the RM_Size (Value_Size) since it may have been set by an
3224 -- explicit representation clause.
3226 elsif Known_Static_RM_Size
(Comp_Type
) then
3227 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3229 -- Should not happen since this has already been checked in
3230 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3233 raise Program_Error
;
3236 -- Retrieve all relevant atomic routines and types
3240 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3241 Read
:= RTE
(RE_Lock_Free_Read_8
);
3242 Unsigned
:= RTE
(RE_Uint8
);
3245 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3246 Read
:= RTE
(RE_Lock_Free_Read_16
);
3247 Unsigned
:= RTE
(RE_Uint16
);
3250 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3251 Read
:= RTE
(RE_Lock_Free_Read_32
);
3252 Unsigned
:= RTE
(RE_Uint32
);
3255 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3256 Read
:= RTE
(RE_Lock_Free_Read_64
);
3257 Unsigned
:= RTE
(RE_Uint64
);
3260 raise Program_Error
;
3264 -- Expected_Comp : constant Comp_Type :=
3266 -- (System.Atomic_Primitives.Lock_Free_Read_N
3267 -- (_Object.Comp'Address));
3270 Make_Defining_Identifier
(Loc
,
3271 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3274 Make_Object_Declaration
(Loc
,
3275 Defining_Identifier
=> Expected_Comp
,
3276 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3277 Constant_Present
=> True,
3279 Unchecked_Convert_To
(Comp_Type
,
3280 Make_Function_Call
(Loc
,
3281 Name
=> New_Occurrence_Of
(Read
, Loc
),
3282 Parameter_Associations
=> New_List
(
3283 Make_Attribute_Reference
(Loc
,
3284 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3285 Attribute_Name
=> Name_Address
)))));
3287 -- Protected procedures
3289 if Is_Procedure
then
3290 -- Move the original declarations inside the generated block
3292 Block_Decls
:= Decls
;
3294 -- Reset the declarations list of the protected procedure to
3295 -- contain only Decl.
3297 Decls
:= New_List
(Decl
);
3300 -- Desired_Comp : Comp_Type := Expected_Comp;
3303 Make_Defining_Identifier
(Loc
,
3304 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3306 -- Insert the declarations of Expected_Comp and Desired_Comp in
3307 -- the block declarations right before the renaming of the
3308 -- protected component.
3310 Insert_Before
(Comp_Decl
,
3311 Make_Object_Declaration
(Loc
,
3312 Defining_Identifier
=> Desired_Comp
,
3313 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3315 New_Occurrence_Of
(Expected_Comp
, Loc
)));
3317 -- Protected function
3320 Desired_Comp
:= Expected_Comp
;
3322 -- Insert the declaration of Expected_Comp in the function
3323 -- declarations right before the renaming of the protected
3326 Insert_Before
(Comp_Decl
, Decl
);
3329 -- Rewrite the protected component renaming declaration to be a
3330 -- renaming of Desired_Comp.
3333 -- Comp : Comp_Type renames Desired_Comp;
3336 Make_Object_Renaming_Declaration
(Loc
,
3337 Defining_Identifier
=>
3338 Defining_Identifier
(Comp_Decl
),
3340 New_Occurrence_Of
(Comp_Type
, Loc
),
3342 New_Occurrence_Of
(Desired_Comp
, Loc
)));
3344 -- Wrap any return or raise statements in Stmts in same the manner
3345 -- described in Process_Stmts.
3347 Process_Stmts
(Stmts
);
3350 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3351 -- (_Object.Comp'Address,
3352 -- Interfaces.Unsigned_N (Expected_Comp),
3353 -- Interfaces.Unsigned_N (Desired_Comp))
3355 if Is_Procedure
then
3357 Make_Exit_Statement
(Loc
,
3359 Make_Function_Call
(Loc
,
3361 New_Occurrence_Of
(Try_Write
, Loc
),
3362 Parameter_Associations
=> New_List
(
3363 Make_Attribute_Reference
(Loc
,
3364 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3365 Attribute_Name
=> Name_Address
),
3367 Unchecked_Convert_To
(Unsigned
,
3368 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3370 Unchecked_Convert_To
(Unsigned
,
3371 New_Occurrence_Of
(Desired_Comp
, Loc
)))));
3373 -- Small optimization: transform the default return statement
3374 -- of a procedure into the atomic exit statement.
3376 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3377 Rewrite
(Last
(Stmts
), Stmt
);
3379 Append_To
(Stmts
, Stmt
);
3383 -- Create the declaration of the label used to skip the rest of
3384 -- the source statements when the object state changes.
3386 if Present
(Label_Id
) then
3387 Label
:= Make_Label
(Loc
, Label_Id
);
3389 Make_Implicit_Label_Declaration
(Loc
,
3390 Defining_Identifier
=> Entity
(Label_Id
),
3391 Label_Construct
=> Label
));
3392 Append_To
(Stmts
, Label
);
3404 if Is_Procedure
then
3407 Make_Loop_Statement
(Loc
,
3408 Statements
=> New_List
(
3409 Make_Block_Statement
(Loc
,
3410 Declarations
=> Block_Decls
,
3411 Handled_Statement_Sequence
=>
3412 Make_Handled_Sequence_Of_Statements
(Loc
,
3413 Statements
=> Stmts
))),
3414 End_Label
=> Empty
));
3418 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3419 end Protected_Component_Ref
;
3422 -- Make an unprotected version of the subprogram for use within the same
3423 -- object, with new name and extra parameter representing the object.
3426 Make_Subprogram_Body
(Loc
,
3428 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3429 Declarations
=> Decls
,
3430 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3431 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3433 -------------------------
3434 -- Build_Master_Entity --
3435 -------------------------
3437 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3438 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3440 Context_Id
: Entity_Id
;
3446 -- No action needed if the run-time has no tasking support
3448 if Global_No_Tasking
then
3452 if Is_Itype
(Obj_Or_Typ
) then
3453 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3455 Par
:= Parent
(Obj_Or_Typ
);
3458 -- For transient scopes check if the master entity is already defined
3460 if Is_Type
(Obj_Or_Typ
)
3461 and then Ekind
(Scope
(Obj_Or_Typ
)) = E_Block
3462 and then Is_Internal
(Scope
(Obj_Or_Typ
))
3465 Master_Scope
: constant Entity_Id
:=
3466 Find_Master_Scope
(Obj_Or_Typ
);
3468 if Has_Master_Entity
(Master_Scope
)
3469 or else Is_Finalizer
(Master_Scope
)
3474 if Present
(Current_Entity_In_Scope
(Name_uMaster
)) then
3480 -- When creating a master for a record component which is either a task
3481 -- or access-to-task, the enclosing record is the master scope and the
3482 -- proper insertion point is the component list.
3484 if Is_Record_Type
(Current_Scope
) then
3486 Context_Id
:= Current_Scope
;
3487 Decls
:= List_Containing
(Context
);
3489 -- Default case for object declarations and access types. Note that the
3490 -- context is updated to the nearest enclosing body, block, package, or
3491 -- return statement.
3494 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3497 -- Nothing to do if the context already has a master; internally built
3498 -- finalizers don't need a master.
3500 if Has_Master_Entity
(Context_Id
)
3501 or else Is_Finalizer
(Context_Id
)
3506 Decl
:= Build_Master_Declaration
(Loc
);
3508 -- The master is inserted at the start of the declarative list of the
3511 Prepend_To
(Decls
, Decl
);
3513 -- In certain cases where transient scopes are involved, the immediate
3514 -- scope is not always the proper master scope. Ensure that the master
3515 -- declaration and entity appear in the same context.
3517 if Context_Id
/= Current_Scope
then
3518 Push_Scope
(Context_Id
);
3525 -- Mark the enclosing scope and its associated construct as being task
3528 Set_Has_Master_Entity
(Context_Id
);
3530 while Present
(Context
)
3531 and then Nkind
(Context
) /= N_Compilation_Unit
3533 if Nkind
(Context
) in
3534 N_Block_Statement | N_Subprogram_Body | N_Task_Body
3536 Set_Is_Task_Master
(Context
);
3539 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3540 Context
:= Corresponding_Stub
(Parent
(Context
));
3543 Context
:= Parent
(Context
);
3545 end Build_Master_Entity
;
3547 ---------------------------
3548 -- Build_Master_Renaming --
3549 ---------------------------
3551 procedure Build_Master_Renaming
3552 (Ptr_Typ
: Entity_Id
;
3553 Ins_Nod
: Node_Id
:= Empty
)
3555 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3557 Master_Decl
: Node_Id
;
3558 Master_Id
: Entity_Id
;
3561 -- No action needed if the run-time has no tasking support
3563 if Global_No_Tasking
then
3567 -- Determine the proper context to insert the master renaming
3569 if Present
(Ins_Nod
) then
3572 elsif Is_Itype
(Ptr_Typ
) then
3573 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3575 -- When the context references a discriminant or a component of a
3576 -- private type and we are processing declarations in the private
3577 -- part of the enclosing package, we must insert the master renaming
3578 -- before the full declaration of the private type; otherwise the
3579 -- master renaming would be inserted in the public part of the
3580 -- package (and hence before the declaration of _master).
3582 if In_Private_Part
(Current_Scope
) then
3584 Ctx
: Node_Id
:= Context
;
3587 if Nkind
(Context
) = N_Discriminant_Specification
then
3588 Ctx
:= Parent
(Ctx
);
3590 while Nkind
(Ctx
) in
3591 N_Component_Declaration | N_Component_List
3593 Ctx
:= Parent
(Ctx
);
3597 if Nkind
(Ctx
) in N_Private_Type_Declaration
3598 | N_Private_Extension_Declaration
3600 Context
:= Parent
(Full_View
(Defining_Identifier
(Ctx
)));
3606 Context
:= Parent
(Ptr_Typ
);
3610 -- <Ptr_Typ>M : Master_Id renames _Master;
3611 -- and add a numeric suffix to the name to ensure that it is
3612 -- unique in case other access types in nested constructs
3613 -- are homonyms of this one.
3616 Make_Defining_Identifier
(Loc
,
3617 New_External_Name
(Chars
(Ptr_Typ
), 'M', -1));
3620 Make_Object_Renaming_Declaration
(Loc
,
3621 Defining_Identifier
=> Master_Id
,
3623 New_Occurrence_Of
(Standard_Integer
, Loc
),
3624 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3626 Insert_Action
(Context
, Master_Decl
);
3628 -- The renamed master now services the access type
3630 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3631 end Build_Master_Renaming
;
3633 ---------------------------
3634 -- Build_Protected_Entry --
3635 ---------------------------
3637 function Build_Protected_Entry
3640 Pid
: Node_Id
) return Node_Id
3642 Bod_Decls
: constant List_Id
:= New_List
;
3643 Decls
: constant List_Id
:= Declarations
(N
);
3644 End_Lab
: constant Node_Id
:=
3645 End_Label
(Handled_Statement_Sequence
(N
));
3646 End_Loc
: constant Source_Ptr
:=
3647 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3648 -- Used for the generated call to Complete_Entry_Body
3650 Loc
: constant Source_Ptr
:= Sloc
(N
);
3654 Bod_Stmts
: List_Id
;
3657 Proc_Body
: Node_Id
;
3659 EH_Loc
: Source_Ptr
;
3660 -- Used for the exception handler, inserted at end of the body
3663 -- Set the source location on the exception handler only when debugging
3664 -- the expanded code (see Make_Implicit_Exception_Handler).
3666 if Debug_Generated_Code
then
3669 -- Otherwise the inserted code should not be visible to the debugger
3672 EH_Loc
:= No_Location
;
3676 Make_Defining_Identifier
(Loc
,
3677 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3678 Bod_Spec
:= Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Empty
);
3680 -- Add the following declarations:
3682 -- type poVP is access poV;
3683 -- _object : poVP := poVP (_O);
3685 -- where _O is the formal parameter associated with the concurrent
3686 -- object. These declarations are needed for Complete_Entry_Body.
3688 Add_Object_Pointer
(Loc
, Pid
, Bod_Decls
);
3690 -- Add renamings for all formals, the Protection object, discriminals,
3691 -- privals and the entry index constant for use by debugger.
3693 Add_Formal_Renamings
(Bod_Spec
, Bod_Decls
, Ent
, Loc
);
3694 Debug_Private_Data_Declarations
(Decls
);
3696 -- Put the declarations and the statements from the entry
3700 Make_Block_Statement
(Loc
,
3701 Declarations
=> Decls
,
3702 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
)));
3704 -- Analyze now and reset scopes for declarations so that Scope fields
3705 -- currently denoting the entry will now denote the block scope, and
3706 -- the block's scope will be set to the new procedure entity.
3708 Analyze_Statements
(Bod_Stmts
);
3710 Set_Scope
(Entity
(Identifier
(First
(Bod_Stmts
))), Bod_Id
);
3713 (First
(Bod_Stmts
), Entity
(Identifier
(First
(Bod_Stmts
))));
3715 case Corresponding_Runtime_Package
(Pid
) is
3716 when System_Tasking_Protected_Objects_Entries
=>
3717 Append_To
(Bod_Stmts
,
3718 Make_Procedure_Call_Statement
(End_Loc
,
3720 New_Occurrence_Of
(RTE
(RE_Complete_Entry_Body
), Loc
),
3721 Parameter_Associations
=> New_List
(
3722 Make_Attribute_Reference
(End_Loc
,
3724 Make_Selected_Component
(End_Loc
,
3726 Make_Identifier
(End_Loc
, Name_uObject
),
3728 Make_Identifier
(End_Loc
, Name_uObject
)),
3729 Attribute_Name
=> Name_Unchecked_Access
))));
3731 when System_Tasking_Protected_Objects_Single_Entry
=>
3733 -- Historically, a call to Complete_Single_Entry_Body was
3734 -- inserted, but it was a null procedure.
3739 raise Program_Error
;
3742 -- When exceptions cannot be propagated, we never need to call
3743 -- Exception_Complete_Entry_Body.
3745 if No_Exception_Handlers_Set
then
3747 Make_Subprogram_Body
(Loc
,
3748 Specification
=> Bod_Spec
,
3749 Declarations
=> Bod_Decls
,
3750 Handled_Statement_Sequence
=>
3751 Make_Handled_Sequence_Of_Statements
(Loc
,
3752 Statements
=> Bod_Stmts
,
3753 End_Label
=> End_Lab
));
3756 Ohandle
:= Make_Others_Choice
(Loc
);
3757 Set_All_Others
(Ohandle
);
3759 case Corresponding_Runtime_Package
(Pid
) is
3760 when System_Tasking_Protected_Objects_Entries
=>
3763 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
3765 when System_Tasking_Protected_Objects_Single_Entry
=>
3768 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
3771 raise Program_Error
;
3774 -- Create body of entry procedure. The renaming declarations are
3775 -- placed ahead of the block that contains the actual entry body.
3778 Make_Subprogram_Body
(Loc
,
3779 Specification
=> Bod_Spec
,
3780 Declarations
=> Bod_Decls
,
3781 Handled_Statement_Sequence
=>
3782 Make_Handled_Sequence_Of_Statements
(Loc
,
3783 Statements
=> Bod_Stmts
,
3784 End_Label
=> End_Lab
,
3785 Exception_Handlers
=> New_List
(
3786 Make_Implicit_Exception_Handler
(EH_Loc
,
3787 Exception_Choices
=> New_List
(Ohandle
),
3789 Statements
=> New_List
(
3790 Make_Procedure_Call_Statement
(EH_Loc
,
3792 Parameter_Associations
=> New_List
(
3793 Make_Attribute_Reference
(EH_Loc
,
3795 Make_Selected_Component
(EH_Loc
,
3797 Make_Identifier
(EH_Loc
, Name_uObject
),
3799 Make_Identifier
(EH_Loc
, Name_uObject
)),
3800 Attribute_Name
=> Name_Unchecked_Access
),
3802 Make_Function_Call
(EH_Loc
,
3805 (RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
3807 -- Establish link between subprogram body and source entry body
3809 Set_Corresponding_Entry_Body
(Proc_Body
, N
);
3811 Reset_Scopes_To
(Proc_Body
, Protected_Body_Subprogram
(Ent
));
3814 end Build_Protected_Entry
;
3816 -----------------------------------------
3817 -- Build_Protected_Entry_Specification --
3818 -----------------------------------------
3820 function Build_Protected_Entry_Specification
3823 Ent_Id
: Entity_Id
) return Node_Id
3825 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
3828 Set_Debug_Info_Needed
(Def_Id
);
3830 if Present
(Ent_Id
) then
3831 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
3835 Make_Procedure_Specification
(Loc
,
3836 Defining_Unit_Name
=> Def_Id
,
3837 Parameter_Specifications
=> New_List
(
3838 Make_Parameter_Specification
(Loc
,
3839 Defining_Identifier
=>
3840 Make_Defining_Identifier
(Loc
, Name_uO
),
3842 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3844 Make_Parameter_Specification
(Loc
,
3845 Defining_Identifier
=> P
,
3847 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3849 Make_Parameter_Specification
(Loc
,
3850 Defining_Identifier
=>
3851 Make_Defining_Identifier
(Loc
, Name_uE
),
3853 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))));
3854 end Build_Protected_Entry_Specification
;
3856 --------------------------
3857 -- Build_Protected_Spec --
3858 --------------------------
3860 function Build_Protected_Spec
3862 Obj_Type
: Entity_Id
;
3864 Unprotected
: Boolean := False) return List_Id
3866 Loc
: constant Source_Ptr
:= Sloc
(N
);
3869 New_Plist
: List_Id
;
3870 New_Param
: Node_Id
;
3873 New_Plist
:= New_List
;
3875 Formal
:= First_Formal
(Ident
);
3876 while Present
(Formal
) loop
3878 Make_Parameter_Specification
(Loc
,
3879 Defining_Identifier
=>
3880 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
3881 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
3882 In_Present
=> In_Present
(Parent
(Formal
)),
3883 Out_Present
=> Out_Present
(Parent
(Formal
)),
3884 Parameter_Type
=> New_Occurrence_Of
(Etype
(Formal
), Loc
));
3887 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
3888 Mutate_Ekind
(Defining_Identifier
(New_Param
), Ekind
(Formal
));
3891 Append
(New_Param
, New_Plist
);
3892 Next_Formal
(Formal
);
3895 -- If the subprogram is a procedure and the context is not an access
3896 -- to protected subprogram, the parameter is in-out. Otherwise it is
3900 Make_Parameter_Specification
(Loc
,
3901 Defining_Identifier
=>
3902 Make_Defining_Identifier
(Loc
, Name_uObject
),
3905 (Etype
(Ident
) = Standard_Void_Type
3906 and then not Is_RTE
(Obj_Type
, RE_Address
)),
3908 New_Occurrence_Of
(Obj_Type
, Loc
));
3909 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
3910 Prepend_To
(New_Plist
, Decl
);
3913 end Build_Protected_Spec
;
3915 ---------------------------------------
3916 -- Build_Protected_Sub_Specification --
3917 ---------------------------------------
3919 function Build_Protected_Sub_Specification
3921 Prot_Typ
: Entity_Id
;
3922 Mode
: Subprogram_Protection_Mode
) return Node_Id
3924 Loc
: constant Source_Ptr
:= Sloc
(N
);
3928 New_Plist
: List_Id
;
3931 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
3932 (Dispatching_Mode
=> ' ',
3933 Protected_Mode
=> 'P',
3934 Unprotected_Mode
=> 'N');
3937 if Ekind
(Defining_Unit_Name
(Specification
(N
))) = E_Subprogram_Body
3939 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
3944 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
3947 Build_Protected_Spec
3948 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
3949 Mode
= Unprotected_Mode
);
3951 Make_Defining_Identifier
(Loc
,
3952 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
3954 -- Reference the original nondispatching subprogram since the analysis
3955 -- of the object.operation notation may need its original name (see
3956 -- Sem_Ch4.Names_Match).
3958 if Mode
= Dispatching_Mode
then
3959 Mutate_Ekind
(New_Id
, Ekind
(Def_Id
));
3960 Set_Original_Protected_Subprogram
(New_Id
, Def_Id
);
3963 -- Link the protected or unprotected version to the original subprogram
3966 Mutate_Ekind
(New_Id
, Ekind
(Def_Id
));
3967 Set_Protected_Subprogram
(New_Id
, Def_Id
);
3969 -- The unprotected operation carries the user code, and debugging
3970 -- information must be generated for it, even though this spec does
3971 -- not come from source. It is also convenient to allow gdb to step
3972 -- into the protected operation, even though it only contains lock/
3975 Set_Debug_Info_Needed
(New_Id
);
3977 -- If a pragma Eliminate applies to the source entity, the internal
3978 -- subprograms will be eliminated as well.
3980 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
3982 -- It seems we should set Has_Nested_Subprogram here, but instead we
3983 -- currently set it in Expand_N_Protected_Body, because the entity
3984 -- created here isn't the one that Corresponding_Spec of the body
3985 -- will later be set to, and that's the entity where it's needed. ???
3987 Set_Has_Nested_Subprogram
(New_Id
, Has_Nested_Subprogram
(Def_Id
));
3989 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
3991 Make_Procedure_Specification
(Loc
,
3992 Defining_Unit_Name
=> New_Id
,
3993 Parameter_Specifications
=> New_Plist
);
3995 -- Create a new specification for the anonymous subprogram type
3999 Make_Function_Specification
(Loc
,
4000 Defining_Unit_Name
=> New_Id
,
4001 Parameter_Specifications
=> New_Plist
,
4002 Result_Definition
=>
4003 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
4005 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
4009 end Build_Protected_Sub_Specification
;
4011 -------------------------------------
4012 -- Build_Protected_Subprogram_Body --
4013 -------------------------------------
4015 function Build_Protected_Subprogram_Body
4018 N_Op_Spec
: Node_Id
) return Node_Id
4020 Exc_Safe
: constant Boolean := not Might_Raise
(N
);
4021 -- True if N cannot raise an exception
4023 Loc
: constant Source_Ptr
:= Sloc
(N
);
4024 Op_Spec
: constant Node_Id
:= Specification
(N
);
4025 P_Op_Spec
: constant Node_Id
:=
4026 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
4029 Lock_Name
: Node_Id
;
4030 Lock_Stmt
: Node_Id
;
4031 Object_Parm
: Node_Id
;
4034 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
4035 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
4039 Unprot_Call
: Node_Id
;
4042 -- Build a list of the formal parameters of the protected version of
4043 -- the subprogram to use as the actual parameters of the unprotected
4046 Uactuals
:= New_List
;
4047 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
4048 while Present
(Pformal
) loop
4049 Append_To
(Uactuals
,
4050 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
4054 -- Make a call to the unprotected version of the subprogram built above
4055 -- for use by the protected version built below.
4057 if Nkind
(Op_Spec
) = N_Function_Specification
then
4059 R
:= Make_Temporary
(Loc
, 'R');
4062 Make_Object_Declaration
(Loc
,
4063 Defining_Identifier
=> R
,
4064 Constant_Present
=> True,
4065 Object_Definition
=>
4066 New_Copy
(Result_Definition
(N_Op_Spec
)),
4068 Make_Function_Call
(Loc
,
4070 Make_Identifier
(Loc
,
4071 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4072 Parameter_Associations
=> Uactuals
));
4075 Make_Simple_Return_Statement
(Loc
,
4076 Expression
=> New_Occurrence_Of
(R
, Loc
));
4080 Make_Simple_Return_Statement
(Loc
,
4082 Make_Function_Call
(Loc
,
4084 Make_Identifier
(Loc
,
4085 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4086 Parameter_Associations
=> Uactuals
));
4089 if Has_Aspect
(Pid
, Aspect_Exclusive_Functions
)
4091 (No
(Find_Value_Of_Aspect
(Pid
, Aspect_Exclusive_Functions
))
4093 Is_True
(Static_Boolean
(Find_Value_Of_Aspect
4094 (Pid
, Aspect_Exclusive_Functions
))))
4096 Lock_Kind
:= RE_Lock
;
4098 Lock_Kind
:= RE_Lock_Read_Only
;
4102 Make_Procedure_Call_Statement
(Loc
,
4104 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4105 Parameter_Associations
=> Uactuals
);
4107 Lock_Kind
:= RE_Lock
;
4110 -- Wrap call in block that will be covered by an at_end handler
4112 if not Exc_Safe
then
4114 Make_Block_Statement
(Loc
,
4115 Handled_Statement_Sequence
=>
4116 Make_Handled_Sequence_Of_Statements
(Loc
,
4117 Statements
=> New_List
(Unprot_Call
)));
4120 -- Make the protected subprogram body. This locks the protected
4121 -- object and calls the unprotected version of the subprogram.
4123 case Corresponding_Runtime_Package
(Pid
) is
4124 when System_Tasking_Protected_Objects_Entries
=>
4125 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entries
), Loc
);
4127 when System_Tasking_Protected_Objects_Single_Entry
=>
4128 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entry
), Loc
);
4130 when System_Tasking_Protected_Objects
=>
4131 Lock_Name
:= New_Occurrence_Of
(RTE
(Lock_Kind
), Loc
);
4134 raise Program_Error
;
4138 Make_Attribute_Reference
(Loc
,
4140 Make_Selected_Component
(Loc
,
4141 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4142 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4143 Attribute_Name
=> Name_Unchecked_Access
);
4146 Make_Procedure_Call_Statement
(Loc
,
4148 Parameter_Associations
=> New_List
(Object_Parm
));
4150 if Abort_Allowed
then
4152 Build_Runtime_Call
(Loc
, RE_Abort_Defer
),
4156 Stmts
:= New_List
(Lock_Stmt
);
4159 if not Exc_Safe
then
4160 Append
(Unprot_Call
, Stmts
);
4162 if Nkind
(Op_Spec
) = N_Function_Specification
then
4164 Stmts
:= Empty_List
;
4166 Append
(Unprot_Call
, Stmts
);
4169 -- Historical note: Previously, call to the cleanup was inserted
4170 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4171 -- which is also shared by the 'not Exc_Safe' path.
4173 Build_Protected_Subprogram_Call_Cleanup
(Op_Spec
, Pid
, Loc
, Stmts
);
4175 if Nkind
(Op_Spec
) = N_Function_Specification
then
4176 Append_To
(Stmts
, Return_Stmt
);
4177 Append_To
(Pre_Stmts
,
4178 Make_Block_Statement
(Loc
,
4179 Declarations
=> New_List
(Unprot_Call
),
4180 Handled_Statement_Sequence
=>
4181 Make_Handled_Sequence_Of_Statements
(Loc
,
4182 Statements
=> Stmts
)));
4188 Make_Subprogram_Body
(Loc
,
4189 Declarations
=> Empty_List
,
4190 Specification
=> P_Op_Spec
,
4191 Handled_Statement_Sequence
=>
4192 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4194 -- Mark this subprogram as a protected subprogram body so that the
4195 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4196 -- path as otherwise the cleanup has already been inserted.
4198 if not Exc_Safe
then
4199 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4203 end Build_Protected_Subprogram_Body
;
4205 -------------------------------------
4206 -- Build_Protected_Subprogram_Call --
4207 -------------------------------------
4209 procedure Build_Protected_Subprogram_Call
4213 External
: Boolean := True)
4215 Loc
: constant Source_Ptr
:= Sloc
(N
);
4216 Sub
: constant Entity_Id
:= Entity
(Name
);
4222 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4225 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4228 if Present
(Parameter_Associations
(N
)) then
4229 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4234 -- If the type is an untagged derived type, convert to the root type,
4235 -- which is the one on which the operations are defined.
4237 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4238 and then not Is_Tagged_Type
(Etype
(Rec
))
4239 and then Is_Derived_Type
(Etype
(Rec
))
4241 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4242 Set_Subtype_Mark
(Rec
,
4243 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4246 Prepend
(Rec
, Params
);
4248 if Ekind
(Sub
) = E_Procedure
then
4250 Make_Procedure_Call_Statement
(Loc
,
4252 Parameter_Associations
=> Params
));
4255 pragma Assert
(Ekind
(Sub
) = E_Function
);
4257 Make_Function_Call
(Loc
,
4259 Parameter_Associations
=> Params
));
4261 -- Preserve type of call for subsequent processing (required for
4262 -- call to Wrap_Transient_Expression in the case of a shared passive
4265 Set_Etype
(N
, Etype
(New_Sub
));
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_Protected_Subprogram_Call_Cleanup --
4279 ---------------------------------------------
4281 procedure Build_Protected_Subprogram_Call_Cleanup
4290 -- If the associated protected object has entries, a protected
4291 -- procedure has to service entry queues. In this case generate:
4293 -- Service_Entries (_object._object'Access);
4295 if Nkind
(Op_Spec
) = N_Procedure_Specification
4296 and then Has_Entries
(Conc_Typ
)
4298 case Corresponding_Runtime_Package
(Conc_Typ
) is
4299 when System_Tasking_Protected_Objects_Entries
=>
4300 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entries
), Loc
);
4302 when System_Tasking_Protected_Objects_Single_Entry
=>
4303 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entry
), Loc
);
4306 raise Program_Error
;
4310 Make_Procedure_Call_Statement
(Loc
,
4312 Parameter_Associations
=> New_List
(
4313 Make_Attribute_Reference
(Loc
,
4315 Make_Selected_Component
(Loc
,
4316 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4317 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4318 Attribute_Name
=> Name_Unchecked_Access
))));
4322 -- Unlock (_object._object'Access);
4324 case Corresponding_Runtime_Package
(Conc_Typ
) is
4325 when System_Tasking_Protected_Objects_Entries
=>
4326 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entries
), Loc
);
4328 when System_Tasking_Protected_Objects_Single_Entry
=>
4329 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entry
), Loc
);
4331 when System_Tasking_Protected_Objects
=>
4332 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock
), Loc
);
4335 raise Program_Error
;
4339 Make_Procedure_Call_Statement
(Loc
,
4341 Parameter_Associations
=> New_List
(
4342 Make_Attribute_Reference
(Loc
,
4344 Make_Selected_Component
(Loc
,
4345 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4346 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4347 Attribute_Name
=> Name_Unchecked_Access
))));
4353 if Abort_Allowed
then
4354 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
4356 end Build_Protected_Subprogram_Call_Cleanup
;
4358 -------------------------
4359 -- Build_Selected_Name --
4360 -------------------------
4362 function Build_Selected_Name
4363 (Prefix
: Entity_Id
;
4364 Selector
: Entity_Id
;
4365 Append_Char
: Character := ' ') return Name_Id
4367 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4368 Select_Len
: Natural;
4371 Get_Name_String
(Chars
(Selector
));
4372 Select_Len
:= Name_Len
;
4373 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4374 Get_Name_String
(Chars
(Prefix
));
4376 -- If scope is anonymous type, discard suffix to recover name of
4377 -- single protected object. Otherwise use protected type name.
4379 if Name_Buffer
(Name_Len
) = 'T' then
4380 Name_Len
:= Name_Len
- 1;
4383 Add_Str_To_Name_Buffer
("__");
4384 for J
in 1 .. Select_Len
loop
4385 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4388 -- Now add the Append_Char if specified. The encoding to follow
4389 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4390 -- then the entity is associated to a protected type subprogram.
4391 -- Otherwise, it is a protected type entry. For each case, the
4392 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4394 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4396 if Append_Char
/= ' ' then
4397 if Append_Char
= 'P' or Append_Char
= 'N' then
4398 Add_Char_To_Name_Buffer
(Append_Char
);
4401 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4402 return New_External_Name
(Name_Find
, ' ', -1);
4407 end Build_Selected_Name
;
4409 -----------------------------
4410 -- Build_Simple_Entry_Call --
4411 -----------------------------
4413 -- A task entry call is converted to a call to Call_Simple
4416 -- P : parms := (parm, parm, parm);
4418 -- Call_Simple (acceptor-task, entry-index, P'Address);
4424 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4425 -- the parameters, and the constructed aggregate value contains either the
4426 -- parameters or, in the case of non-elementary types, references to these
4427 -- parameters. Then the address of this aggregate is passed to the runtime
4428 -- routine, along with the task id value and the task entry index value.
4429 -- Pnn is only required if parameters are present.
4431 -- The assignments after the call are present only in the case of in-out
4432 -- or out parameters for elementary types, and are used to assign back the
4433 -- resulting values of such parameters.
4435 -- Note: the reason that we insert a block here is that in the context
4436 -- of selects, conditional entry calls etc. the entry call statement
4437 -- appears on its own, not as an element of a list.
4439 -- A protected entry call is converted to a Protected_Entry_Call:
4442 -- P : E1_Params := (param, param, param);
4444 -- Bnn : Communications_Block;
4447 -- P : E1_Params := (param, param, param);
4448 -- Bnn : Communications_Block;
4451 -- Protected_Entry_Call (
4452 -- Object => po._object'Access,
4453 -- E => <entry index>;
4454 -- Uninterpreted_Data => P'Address;
4455 -- Mode => Simple_Call;
4462 procedure Build_Simple_Entry_Call
4471 -- If call has been inlined, nothing left to do
4473 if Nkind
(N
) = N_Block_Statement
then
4477 -- Convert entry call to Call_Simple call
4480 Loc
: constant Source_Ptr
:= Sloc
(N
);
4481 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4482 Stats
: constant List_Id
:= New_List
;
4485 Comm_Name
: Entity_Id
;
4489 Ent_Acc
: Entity_Id
;
4491 Iface_Tag
: Entity_Id
;
4492 Iface_Typ
: Entity_Id
;
4505 -- Simple entry and entry family cases merge here
4507 Ent
:= Entity
(Ename
);
4508 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4509 Conctyp
:= Etype
(Concval
);
4511 -- Special case for protected subprogram calls
4513 if Is_Protected_Type
(Conctyp
)
4514 and then Is_Subprogram
(Entity
(Ename
))
4516 if not Is_Eliminated
(Entity
(Ename
)) then
4517 Build_Protected_Subprogram_Call
4518 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4525 -- First parameter is the Task_Id value from the task value or the
4526 -- Object from the protected object value, obtained by selecting
4527 -- the _Task_Id or _Object from the result of doing an unchecked
4528 -- conversion to convert the value to the corresponding record type.
4530 if Nkind
(Concval
) = N_Function_Call
4531 and then Is_Task_Type
(Conctyp
)
4532 and then Ada_Version
>= Ada_2005
4535 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4536 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4541 Make_Object_Declaration
(Loc
,
4542 Defining_Identifier
=> Obj
,
4543 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4544 Expression
=> ExpR
);
4545 Set_Etype
(Obj
, Conctyp
);
4546 Decls
:= New_List
(Decl
);
4547 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4554 Parm1
:= Concurrent_Ref
(Concval
);
4556 -- Second parameter is the entry index, computed by the routine
4557 -- provided for this purpose. The value of this expression is
4558 -- assigned to an intermediate variable to assure that any entry
4559 -- family index expressions are evaluated before the entry
4562 if not Is_Protected_Type
(Conctyp
)
4564 Corresponding_Runtime_Package
(Conctyp
) =
4565 System_Tasking_Protected_Objects_Entries
4567 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4570 Make_Object_Declaration
(Loc
,
4571 Defining_Identifier
=> X
,
4572 Object_Definition
=>
4573 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
4574 Expression
=> Actual_Index_Expression
(
4575 Loc
, Entity
(Ename
), Index
, Concval
));
4577 Append_To
(Decls
, Xdecl
);
4578 Parm2
:= New_Occurrence_Of
(X
, Loc
);
4585 -- The third parameter is the packaged parameters. If there are
4586 -- none, then it is just the null address, since nothing is passed.
4589 Parm3
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
4592 -- Case of parameters present, where third argument is the address
4593 -- of a packaged record containing the required parameter values.
4596 -- First build a list of parameter values, which are references to
4597 -- objects of the parameter types.
4601 Actual
:= First_Actual
(N
);
4602 Formal
:= First_Formal
(Ent
);
4603 while Present
(Actual
) loop
4605 -- If it is a by-copy type, copy it to a new variable. The
4606 -- packaged record has a field that points to this variable.
4608 if Is_By_Copy_Type
(Etype
(Actual
)) then
4610 Make_Object_Declaration
(Loc
,
4611 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4612 Aliased_Present
=> True,
4613 Object_Definition
=>
4614 New_Occurrence_Of
(Etype
(Formal
), Loc
));
4616 -- Mark the object as not needing initialization since the
4617 -- initialization is performed separately, avoiding errors
4618 -- on cases such as formals of null-excluding access types.
4620 Set_No_Initialization
(N_Node
);
4622 -- We must make a separate assignment statement for the
4623 -- case of limited types. We cannot assign it unless the
4624 -- Assignment_OK flag is set first. An out formal of an
4625 -- access type or whose type has a Default_Value must also
4626 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4627 -- but no constraint, predicate, or null-exclusion check is
4628 -- applied before the call.
4630 if Ekind
(Formal
) /= E_Out_Parameter
4631 or else Is_Access_Type
(Etype
(Formal
))
4633 (Is_Scalar_Type
(Etype
(Formal
))
4635 Present
(Default_Aspect_Value
(Etype
(Formal
))))
4638 New_Occurrence_Of
(Defining_Identifier
(N_Node
), Loc
);
4639 Set_Assignment_OK
(N_Var
);
4641 Make_Assignment_Statement
(Loc
,
4643 Expression
=> Relocate_Node
(Actual
)));
4645 -- Mark the object as internal, so we don't later reset
4646 -- No_Initialization flag in Default_Initialize_Object,
4647 -- which would lead to needless default initialization.
4648 -- We don't set this outside the if statement, because
4649 -- out scalar parameters without Default_Value do require
4650 -- default initialization if Initialize_Scalars applies.
4652 Set_Is_Internal
(Defining_Identifier
(N_Node
));
4654 -- If actual is an out parameter of a null-excluding
4655 -- access type, there is access check on entry, so set
4656 -- Suppress_Assignment_Checks on the generated statement
4657 -- that assigns the actual to the parameter block.
4659 Set_Suppress_Assignment_Checks
(Last
(Stats
));
4662 Append
(N_Node
, Decls
);
4665 Make_Attribute_Reference
(Loc
,
4666 Attribute_Name
=> Name_Unchecked_Access
,
4669 (Defining_Identifier
(N_Node
), Loc
)));
4672 -- Interface class-wide formal
4674 if Ada_Version
>= Ada_2005
4675 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4676 and then Is_Interface
(Etype
(Formal
))
4678 Iface_Typ
:= Etype
(Etype
(Formal
));
4681 -- formal_iface_type! (actual.iface_tag)'reference
4684 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4685 pragma Assert
(Present
(Iface_Tag
));
4688 Make_Reference
(Loc
,
4689 Unchecked_Convert_To
(Iface_Typ
,
4690 Make_Selected_Component
(Loc
,
4692 Relocate_Node
(Actual
),
4694 New_Occurrence_Of
(Iface_Tag
, Loc
)))));
4700 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4704 Next_Actual
(Actual
);
4705 Next_Formal_With_Extras
(Formal
);
4708 -- Now build the declaration of parameters initialized with the
4709 -- aggregate containing this constructed parameter list.
4711 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4714 Make_Object_Declaration
(Loc
,
4715 Defining_Identifier
=> P
,
4716 Object_Definition
=>
4717 New_Occurrence_Of
(Designated_Type
(Ent_Acc
), Loc
),
4719 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4722 Make_Attribute_Reference
(Loc
,
4723 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4724 Attribute_Name
=> Name_Address
);
4726 Append
(Pdecl
, Decls
);
4729 -- Now we can create the call, case of protected type
4731 if Is_Protected_Type
(Conctyp
) then
4732 case Corresponding_Runtime_Package
(Conctyp
) is
4733 when System_Tasking_Protected_Objects_Entries
=>
4735 -- Change the type of the index declaration
4737 Set_Object_Definition
(Xdecl
,
4738 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
));
4740 -- Some additional declarations for protected entry calls
4746 -- Bnn : Communications_Block;
4748 Comm_Name
:= Make_Temporary
(Loc
, 'B');
4751 Make_Object_Declaration
(Loc
,
4752 Defining_Identifier
=> Comm_Name
,
4753 Object_Definition
=>
4755 (RTE
(RE_Communication_Block
), Loc
)));
4757 -- Some additional statements for protected entry calls
4759 -- Protected_Entry_Call
4760 -- (Object => po._object'Access,
4761 -- E => <entry index>;
4762 -- Uninterpreted_Data => P'Address;
4763 -- Mode => Simple_Call;
4767 Make_Procedure_Call_Statement
(Loc
,
4769 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
4771 Parameter_Associations
=> New_List
(
4772 Make_Attribute_Reference
(Loc
,
4773 Attribute_Name
=> Name_Unchecked_Access
,
4777 New_Occurrence_Of
(RTE
(RE_Simple_Call
), Loc
),
4778 New_Occurrence_Of
(Comm_Name
, Loc
)));
4780 when System_Tasking_Protected_Objects_Single_Entry
=>
4782 -- Protected_Single_Entry_Call
4783 -- (Object => po._object'Access,
4784 -- Uninterpreted_Data => P'Address);
4787 Make_Procedure_Call_Statement
(Loc
,
4790 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
4792 Parameter_Associations
=> New_List
(
4793 Make_Attribute_Reference
(Loc
,
4794 Attribute_Name
=> Name_Unchecked_Access
,
4799 raise Program_Error
;
4802 -- Case of task type
4806 Make_Procedure_Call_Statement
(Loc
,
4808 New_Occurrence_Of
(RTE
(RE_Call_Simple
), Loc
),
4809 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
4813 Append_To
(Stats
, Call
);
4815 -- If there are out or in/out parameters by copy add assignment
4816 -- statements for the result values.
4818 if Present
(Parms
) then
4819 Actual
:= First_Actual
(N
);
4820 Formal
:= First_Formal
(Ent
);
4822 Set_Assignment_OK
(Actual
);
4823 while Present
(Actual
) loop
4824 if Is_By_Copy_Type
(Etype
(Actual
))
4825 and then Ekind
(Formal
) /= E_In_Parameter
4828 Make_Assignment_Statement
(Loc
,
4829 Name
=> New_Copy
(Actual
),
4831 Make_Explicit_Dereference
(Loc
,
4832 Make_Selected_Component
(Loc
,
4833 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4835 Make_Identifier
(Loc
, Chars
(Formal
)))));
4837 -- In all cases (including limited private types) we want
4838 -- the assignment to be valid.
4840 Set_Assignment_OK
(Name
(N_Node
));
4842 -- If the call is the triggering alternative in an
4843 -- asynchronous select, or the entry_call alternative of a
4844 -- conditional entry call, the assignments for in-out
4845 -- parameters are incorporated into the statement list that
4846 -- follows, so that there are executed only if the entry
4849 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
4850 and then N
= Triggering_Statement
(Parent
(N
)))
4852 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
4853 and then N
= Entry_Call_Statement
(Parent
(N
)))
4855 if No
(Statements
(Parent
(N
))) then
4856 Set_Statements
(Parent
(N
), New_List
);
4859 Prepend
(N_Node
, Statements
(Parent
(N
)));
4862 Insert_After
(Call
, N_Node
);
4866 Next_Actual
(Actual
);
4867 Next_Formal_With_Extras
(Formal
);
4871 -- Finally, create block and analyze it
4874 Make_Block_Statement
(Loc
,
4875 Declarations
=> Decls
,
4876 Handled_Statement_Sequence
=>
4877 Make_Handled_Sequence_Of_Statements
(Loc
,
4878 Statements
=> Stats
)));
4882 end Build_Simple_Entry_Call
;
4884 --------------------------------
4885 -- Build_Task_Activation_Call --
4886 --------------------------------
4888 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
4889 function Activation_Call_Loc
return Source_Ptr
;
4890 -- Find a suitable source location for the activation call
4892 -------------------------
4893 -- Activation_Call_Loc --
4894 -------------------------
4896 function Activation_Call_Loc
return Source_Ptr
is
4898 -- The activation call must carry the location of the "end" keyword
4899 -- when the context is a package declaration.
4901 if Nkind
(N
) = N_Package_Declaration
then
4902 return End_Keyword_Location
(N
);
4904 -- Otherwise the activation call must carry the location of the
4908 return Begin_Keyword_Location
(N
);
4910 end Activation_Call_Loc
;
4921 -- Start of processing for Build_Task_Activation_Call
4924 -- For sequential elaboration policy, all the tasks will be activated at
4925 -- the end of the elaboration.
4927 if Partition_Elaboration_Policy
= 'S' then
4930 -- Do not create an activation call for a package spec if the package
4931 -- has a completing body. The activation call will be inserted after
4932 -- the "begin" of the body.
4934 elsif Nkind
(N
) = N_Package_Declaration
4935 and then Present
(Corresponding_Body
(N
))
4940 -- Obtain the activation chain entity. Block statements, entry bodies,
4941 -- subprogram bodies, and task bodies keep the entity in their nodes.
4942 -- Package bodies on the other hand store it in the declaration of the
4943 -- corresponding package spec.
4947 if Nkind
(Owner
) = N_Package_Body
then
4948 Owner
:= Unit_Declaration_Node
(Corresponding_Spec
(Owner
));
4951 Chain
:= Activation_Chain_Entity
(Owner
);
4953 -- Nothing to do when there are no tasks to activate. This is indicated
4954 -- by a missing activation chain entity; also skip generating it when
4955 -- it is a ghost entity.
4957 if No
(Chain
) or else Is_Ignored_Ghost_Entity
(Chain
) then
4960 -- The availability of the activation chain entity does not ensure
4961 -- that we have tasks to activate because it may have been declared
4962 -- by the frontend to pass a required extra formal to a build-in-place
4963 -- subprogram call. If we are within the scope of a protected type and
4964 -- pragma Detect_Blocking is active we can assume that no tasks will be
4965 -- activated; if tasks are created in a protected object and this pragma
4966 -- is active then the frontend emits a warning and Program_Error is
4967 -- raised at runtime.
4969 elsif Detect_Blocking
and then Within_Protected_Type
(Current_Scope
) then
4973 -- The location of the activation call must be as close as possible to
4974 -- the intended semantic location of the activation because the ABE
4975 -- mechanism relies heavily on accurate locations.
4977 Loc
:= Activation_Call_Loc
;
4979 if Restricted_Profile
then
4980 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Restricted_Tasks
), Loc
);
4982 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
);
4986 Make_Procedure_Call_Statement
(Loc
,
4988 Parameter_Associations
=>
4989 New_List
(Make_Attribute_Reference
(Loc
,
4990 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
4991 Attribute_Name
=> Name_Unchecked_Access
)));
4993 if Nkind
(N
) = N_Package_Declaration
then
4994 if Present
(Private_Declarations
(Specification
(N
))) then
4995 Append
(Call
, Private_Declarations
(Specification
(N
)));
4997 Append
(Call
, Visible_Declarations
(Specification
(N
)));
5001 -- The call goes at the start of the statement sequence after the
5002 -- start of exception range label if one is present.
5004 if Present
(Handled_Statement_Sequence
(N
)) then
5005 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
5007 -- A special case, skip exception range label if one is present
5008 -- (from front end zcx processing).
5010 if Nkind
(Stmt
) = N_Label
and then Exception_Junk
(Stmt
) then
5014 -- Another special case, if the first statement is a block from
5015 -- optimization of a local raise to a goto, then the call goes
5016 -- inside this block.
5018 if Nkind
(Stmt
) = N_Block_Statement
5019 and then Exception_Junk
(Stmt
)
5021 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
5024 -- Insertion point is after any exception label pushes, since we
5025 -- want it covered by any local handlers.
5027 while Nkind
(Stmt
) in N_Push_xxx_Label
loop
5031 -- Now we have the proper insertion point
5033 Insert_Before
(Stmt
, Call
);
5036 Set_Handled_Statement_Sequence
(N
,
5037 Make_Handled_Sequence_Of_Statements
(Loc
,
5038 Statements
=> New_List
(Call
)));
5044 if Legacy_Elaboration_Checks
then
5045 Check_Task_Activation
(N
);
5047 end Build_Task_Activation_Call
;
5049 -------------------------------
5050 -- Build_Task_Allocate_Block --
5051 -------------------------------
5053 procedure Build_Task_Allocate_Block
5058 T
: constant Entity_Id
:= Entity
(Expression
(N
));
5059 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
5060 Loc
: constant Source_Ptr
:= Sloc
(N
);
5061 Chain
: constant Entity_Id
:=
5062 Make_Defining_Identifier
(Loc
, Name_uChain
);
5063 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5068 Make_Block_Statement
(Loc
,
5069 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5070 Declarations
=> New_List
(
5072 -- _Chain : Activation_Chain;
5074 Make_Object_Declaration
(Loc
,
5075 Defining_Identifier
=> Chain
,
5076 Aliased_Present
=> True,
5077 Object_Definition
=>
5078 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5080 Handled_Statement_Sequence
=>
5081 Make_Handled_Sequence_Of_Statements
(Loc
,
5083 Statements
=> New_List
(
5087 Make_Procedure_Call_Statement
(Loc
,
5088 Name
=> New_Occurrence_Of
(Init
, Loc
),
5089 Parameter_Associations
=> Args
),
5091 -- Activate_Tasks (_Chain);
5093 Make_Procedure_Call_Statement
(Loc
,
5094 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5095 Parameter_Associations
=> New_List
(
5096 Make_Attribute_Reference
(Loc
,
5097 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5098 Attribute_Name
=> Name_Unchecked_Access
))))),
5100 Has_Created_Identifier
=> True,
5101 Is_Task_Allocation_Block
=> True);
5104 Make_Implicit_Label_Declaration
(Loc
,
5105 Defining_Identifier
=> Blkent
,
5106 Label_Construct
=> Block
));
5108 Append_To
(Actions
, Block
);
5110 Set_Activation_Chain_Entity
(Block
, Chain
);
5111 end Build_Task_Allocate_Block
;
5113 -----------------------------------------------
5114 -- Build_Task_Allocate_Block_With_Init_Stmts --
5115 -----------------------------------------------
5117 procedure Build_Task_Allocate_Block_With_Init_Stmts
5120 Init_Stmts
: List_Id
)
5122 Loc
: constant Source_Ptr
:= Sloc
(N
);
5123 Chain
: constant Entity_Id
:=
5124 Make_Defining_Identifier
(Loc
, Name_uChain
);
5125 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5129 Append_To
(Init_Stmts
,
5130 Make_Procedure_Call_Statement
(Loc
,
5131 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5132 Parameter_Associations
=> New_List
(
5133 Make_Attribute_Reference
(Loc
,
5134 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5135 Attribute_Name
=> Name_Unchecked_Access
))));
5138 Make_Block_Statement
(Loc
,
5139 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5140 Declarations
=> New_List
(
5142 -- _Chain : Activation_Chain;
5144 Make_Object_Declaration
(Loc
,
5145 Defining_Identifier
=> Chain
,
5146 Aliased_Present
=> True,
5147 Object_Definition
=>
5148 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5150 Handled_Statement_Sequence
=>
5151 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5153 Has_Created_Identifier
=> True,
5154 Is_Task_Allocation_Block
=> True);
5157 Make_Implicit_Label_Declaration
(Loc
,
5158 Defining_Identifier
=> Blkent
,
5159 Label_Construct
=> Block
));
5161 Append_To
(Actions
, Block
);
5163 Set_Activation_Chain_Entity
(Block
, Chain
);
5164 end Build_Task_Allocate_Block_With_Init_Stmts
;
5166 -----------------------------------
5167 -- Build_Task_Proc_Specification --
5168 -----------------------------------
5170 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5171 Loc
: constant Source_Ptr
:= Sloc
(T
);
5172 Spec_Id
: Entity_Id
;
5175 -- Case of explicit task type, suffix TB
5177 if Comes_From_Source
(T
) then
5179 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), "TB"));
5181 -- Case of anonymous task type, suffix B
5185 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), 'B'));
5188 Set_Is_Internal
(Spec_Id
);
5190 -- Associate the procedure with the task, if this is the declaration
5191 -- (and not the body) of the procedure.
5193 if No
(Task_Body_Procedure
(T
)) then
5194 Set_Task_Body_Procedure
(T
, Spec_Id
);
5198 Make_Procedure_Specification
(Loc
,
5199 Defining_Unit_Name
=> Spec_Id
,
5200 Parameter_Specifications
=> New_List
(
5201 Make_Parameter_Specification
(Loc
,
5202 Defining_Identifier
=>
5203 Make_Defining_Identifier
(Loc
, Name_uTask
),
5205 Make_Access_Definition
(Loc
,
5207 New_Occurrence_Of
(Corresponding_Record_Type
(T
), Loc
)))));
5208 end Build_Task_Proc_Specification
;
5210 ---------------------------------------
5211 -- Build_Unprotected_Subprogram_Body --
5212 ---------------------------------------
5214 function Build_Unprotected_Subprogram_Body
5216 Pid
: Node_Id
) return Node_Id
5218 Decls
: constant List_Id
:= Declarations
(N
);
5221 -- Add renamings for the Protection object, discriminals, privals, and
5222 -- the entry index constant for use by debugger.
5224 Debug_Private_Data_Declarations
(Decls
);
5226 -- Make an unprotected version of the subprogram for use within the same
5227 -- object, with a new name and an additional parameter representing the
5231 Make_Subprogram_Body
(Sloc
(N
),
5233 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5234 Declarations
=> Decls
,
5235 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5236 end Build_Unprotected_Subprogram_Body
;
5238 ----------------------------
5239 -- Collect_Entry_Families --
5240 ----------------------------
5242 procedure Collect_Entry_Families
5245 Current_Node
: in out Node_Id
;
5246 Conctyp
: Entity_Id
)
5249 Efam_Decl
: Node_Id
;
5250 Efam_Type
: Entity_Id
;
5253 Efam
:= First_Entity
(Conctyp
);
5254 while Present
(Efam
) loop
5255 if Ekind
(Efam
) = E_Entry_Family
then
5256 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5259 Eityp
: constant Entity_Id
:= Entry_Index_Type
(Efam
);
5260 Lo
: constant Node_Id
:= Type_Low_Bound
(Eityp
);
5261 Hi
: constant Node_Id
:= Type_High_Bound
(Eityp
);
5266 Bityp
:= Base_Type
(Eityp
);
5268 if Is_Potentially_Large_Family
(Bityp
, Conctyp
, Lo
, Hi
) then
5269 Bityp
:= Make_Temporary
(Loc
, 'B');
5272 Make_Subtype_Declaration
(Loc
,
5273 Defining_Identifier
=> Bityp
,
5274 Subtype_Indication
=>
5275 Make_Subtype_Indication
(Loc
,
5277 New_Occurrence_Of
(Standard_Integer
, Loc
),
5279 Make_Range_Constraint
(Loc
,
5280 Range_Expression
=> Make_Range
(Loc
,
5281 Make_Integer_Literal
5282 (Loc
, -Entry_Family_Bound
),
5283 Make_Integer_Literal
5284 (Loc
, Entry_Family_Bound
- 1)))));
5286 Insert_After
(Current_Node
, Bdecl
);
5287 Current_Node
:= Bdecl
;
5292 Make_Full_Type_Declaration
(Loc
,
5293 Defining_Identifier
=> Efam_Type
,
5295 Make_Unconstrained_Array_Definition
(Loc
,
5297 (New_List
(New_Occurrence_Of
(Bityp
, Loc
))),
5299 Component_Definition
=>
5300 Make_Component_Definition
(Loc
,
5301 Aliased_Present
=> False,
5302 Subtype_Indication
=>
5303 New_Occurrence_Of
(Standard_Character
, Loc
))));
5306 Insert_After
(Current_Node
, Efam_Decl
);
5307 Current_Node
:= Efam_Decl
;
5308 Analyze
(Efam_Decl
);
5311 Make_Component_Declaration
(Loc
,
5312 Defining_Identifier
=>
5313 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5315 Component_Definition
=>
5316 Make_Component_Definition
(Loc
,
5317 Aliased_Present
=> False,
5318 Subtype_Indication
=>
5319 Make_Subtype_Indication
(Loc
,
5321 New_Occurrence_Of
(Efam_Type
, Loc
),
5324 Make_Index_Or_Discriminant_Constraint
(Loc
,
5325 Constraints
=> New_List
(
5326 New_Occurrence_Of
(Entry_Index_Type
(Efam
),
5332 end Collect_Entry_Families
;
5334 -----------------------
5335 -- Concurrent_Object --
5336 -----------------------
5338 function Concurrent_Object
5339 (Spec_Id
: Entity_Id
;
5340 Conc_Typ
: Entity_Id
) return Entity_Id
5343 -- Parameter _O or _object
5345 if Is_Protected_Type
(Conc_Typ
) then
5346 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5351 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5352 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5354 end Concurrent_Object
;
5356 ----------------------
5357 -- Copy_Result_Type --
5358 ----------------------
5360 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5361 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5366 -- If the result type is an access_to_subprogram, we must create new
5367 -- entities for its spec.
5369 if Nkind
(New_Res
) = N_Access_Definition
5370 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5372 -- Provide new entities for the formals
5374 Par_Spec
:= First
(Parameter_Specifications
5375 (Access_To_Subprogram_Definition
(New_Res
)));
5376 while Present
(Par_Spec
) loop
5377 Formal
:= Defining_Identifier
(Par_Spec
);
5378 Set_Defining_Identifier
(Par_Spec
,
5379 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5385 end Copy_Result_Type
;
5387 --------------------
5388 -- Concurrent_Ref --
5389 --------------------
5391 -- The expression returned for a reference to a concurrent object has the
5394 -- taskV!(name)._Task_Id
5398 -- objectV!(name)._Object
5400 -- for a protected object. For the case of an access to a concurrent
5401 -- object, there is an extra explicit dereference:
5403 -- taskV!(name.all)._Task_Id
5404 -- objectV!(name.all)._Object
5406 -- here taskV and objectV are the types for the associated records, which
5407 -- contain the required _Task_Id and _Object fields for tasks and protected
5408 -- objects, respectively.
5410 -- For the case of a task type name, the expression is
5414 -- i.e. a call to the Self function which returns precisely this Task_Id
5416 -- For the case of a protected type name, the expression is
5420 -- which is a renaming of the _object field of the current object
5421 -- record, passed into protected operations as a parameter.
5423 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5424 Loc
: constant Source_Ptr
:= Sloc
(N
);
5425 Ntyp
: constant Entity_Id
:= Etype
(N
);
5429 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5430 -- Check whether the reference is to the immediately enclosing task
5431 -- type, or to an outer one (rare but legal).
5433 ---------------------
5434 -- Is_Current_Task --
5435 ---------------------
5437 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5441 Scop
:= Current_Scope
;
5442 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
5446 elsif Is_Task_Type
(Scop
) then
5449 -- If this is a procedure nested within the task type, we must
5450 -- assume that it can be called from an inner task, and therefore
5451 -- cannot treat it as a local reference.
5453 elsif Is_Overloadable
(Scop
) and then In_Open_Scopes
(T
) then
5457 Scop
:= Scope
(Scop
);
5461 -- We know that we are within the task body, so should have found it
5464 raise Program_Error
;
5465 end Is_Current_Task
;
5467 -- Start of processing for Concurrent_Ref
5470 if Is_Access_Type
(Ntyp
) then
5471 Dtyp
:= Designated_Type
(Ntyp
);
5473 if Is_Protected_Type
(Dtyp
) then
5474 Sel
:= Name_uObject
;
5476 Sel
:= Name_uTask_Id
;
5480 Make_Selected_Component
(Loc
,
5482 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5483 Make_Explicit_Dereference
(Loc
, N
)),
5484 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5486 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5487 if Is_Task_Type
(Entity
(N
)) then
5489 if Is_Current_Task
(Entity
(N
)) then
5491 Make_Function_Call
(Loc
,
5492 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
));
5497 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5498 T_Body
: constant Node_Id
:=
5499 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5503 Make_Object_Declaration
(Loc
,
5504 Defining_Identifier
=> T_Self
,
5505 Object_Definition
=>
5506 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5508 Make_Function_Call
(Loc
,
5509 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
)));
5510 Prepend
(Decl
, Declarations
(T_Body
));
5512 Set_Scope
(T_Self
, Entity
(N
));
5513 return New_Occurrence_Of
(T_Self
, Loc
);
5518 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5521 New_Occurrence_Of
(Find_Protection_Object
(Current_Scope
), Loc
);
5525 if Is_Protected_Type
(Ntyp
) then
5526 Sel
:= Name_uObject
;
5527 elsif Is_Task_Type
(Ntyp
) then
5528 Sel
:= Name_uTask_Id
;
5530 raise Program_Error
;
5534 Make_Selected_Component
(Loc
,
5536 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5538 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5542 ------------------------
5543 -- Convert_Concurrent --
5544 ------------------------
5546 function Convert_Concurrent
5548 Typ
: Entity_Id
) return Node_Id
5551 if not Is_Concurrent_Type
(Typ
) then
5555 Unchecked_Convert_To
5556 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5558 end Convert_Concurrent
;
5560 -------------------------------------
5561 -- Create_Secondary_Stack_For_Task --
5562 -------------------------------------
5564 function Create_Secondary_Stack_For_Task
(T
: Node_Id
) return Boolean is
5567 (Restriction_Active
(No_Implicit_Heap_Allocations
)
5568 or else Restriction_Active
(No_Implicit_Task_Allocations
))
5569 and then not Restriction_Active
(No_Secondary_Stack
)
5570 and then Has_Rep_Pragma
5571 (T
, Name_Secondary_Stack_Size
, Check_Parents
=> False);
5572 end Create_Secondary_Stack_For_Task
;
5574 -------------------------------------
5575 -- Debug_Private_Data_Declarations --
5576 -------------------------------------
5578 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5579 Debug_Nod
: Node_Id
;
5583 Decl
:= First
(Decls
);
5584 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5586 -- Declaration for concurrent entity _object and its access type,
5587 -- along with the entry index subtype:
5588 -- type prot_typVP is access prot_typV;
5589 -- _object : prot_typVP := prot_typV (_O);
5590 -- subtype Jnn is <Type of Index> range Low .. High;
5592 if Nkind
(Decl
) in N_Full_Type_Declaration | N_Object_Declaration
then
5593 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5595 -- Declaration for the Protection object, discriminals, privals, and
5596 -- entry index constant:
5597 -- conc_typR : protection_typ renames _object._object;
5598 -- discr_nameD : discr_typ renames _object.discr_name;
5599 -- discr_nameD : discr_typ renames _task.discr_name;
5600 -- prival_name : comp_typ renames _object.comp_name;
5601 -- J : constant Jnn :=
5602 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5604 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5605 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5606 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5608 if Present
(Debug_Nod
) then
5609 Insert_After
(Decl
, Debug_Nod
);
5615 end Debug_Private_Data_Declarations
;
5617 ------------------------------
5618 -- Ensure_Statement_Present --
5619 ------------------------------
5621 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5625 if Opt
.Suppress_Control_Flow_Optimizations
5626 and then Is_Empty_List
(Statements
(Alt
))
5628 Stmt
:= Make_Null_Statement
(Loc
);
5630 -- Mark NULL statement as coming from source so that it is not
5631 -- eliminated by GIGI.
5633 -- Another covert channel. If this is a requirement, it must be
5634 -- documented in sinfo/einfo ???
5636 Set_Comes_From_Source
(Stmt
, True);
5638 Set_Statements
(Alt
, New_List
(Stmt
));
5640 end Ensure_Statement_Present
;
5642 ----------------------------
5643 -- Entry_Index_Expression --
5644 ----------------------------
5646 function Entry_Index_Expression
5650 Ttyp
: Entity_Id
) return Node_Id
5660 -- The queues of entries and entry families appear in textual order in
5661 -- the associated record. The entry index is computed as the sum of the
5662 -- number of queues for all entries that precede the designated one, to
5663 -- which is added the index expression, if this expression denotes a
5664 -- member of a family.
5666 -- The following is a place holder for the count of simple entries
5668 Num
:= Make_Integer_Literal
(Sloc
, 1);
5670 -- We construct an expression which is a series of addition operations.
5671 -- The first operand is the number of single entries that precede this
5672 -- one, the second operand is the index value relative to the start of
5673 -- the referenced family, and the remaining operands are the lengths of
5674 -- the entry families that precede this entry, i.e. the constructed
5677 -- number_simple_entries +
5678 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5679 -- family'length + ...
5681 -- where index-value is the given index value, and s is the index
5682 -- subtype (we have to use pos because the subtype might be an
5683 -- enumeration type preventing direct subtraction). Note that the task
5684 -- entry array is one-indexed.
5686 -- The upper bound of the entry family may be a discriminant, so we
5687 -- retrieve the lower bound explicitly to compute offset, rather than
5688 -- using the index subtype which may mention a discriminant.
5690 if Present
(Index
) then
5691 S
:= Entry_Index_Type
(Ent
);
5693 -- First make sure the index is in range if requested. The index type
5694 -- is the pristine Entry_Index_Type of the entry.
5696 if Do_Range_Check
(Index
) then
5697 Generate_Range_Check
(Index
, S
, CE_Range_Check_Failed
);
5706 Make_Attribute_Reference
(Sloc
,
5707 Attribute_Name
=> Name_Pos
,
5708 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
5709 Expressions
=> New_List
(Relocate_Node
(Index
))),
5717 -- Now add lengths of preceding entries and entry families
5719 Prev
:= First_Entity
(Ttyp
);
5720 while Chars
(Prev
) /= Chars
(Ent
)
5721 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5722 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5724 if Ekind
(Prev
) = E_Entry
then
5725 Set_Intval
(Num
, Intval
(Num
) + 1);
5727 elsif Ekind
(Prev
) = E_Entry_Family
then
5728 S
:= Entry_Index_Type
(Prev
);
5729 Lo
:= Type_Low_Bound
(S
);
5730 Hi
:= Type_High_Bound
(S
);
5735 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5737 -- Other components are anonymous types to be ignored
5747 end Entry_Index_Expression
;
5749 ---------------------------
5750 -- Establish_Task_Master --
5751 ---------------------------
5753 procedure Establish_Task_Master
(N
: Node_Id
) is
5757 if Restriction_Active
(No_Task_Hierarchy
) = False then
5758 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5760 -- The block may have no declarations (and nevertheless be a task
5761 -- master) if it contains a call that may return an object that
5764 if No
(Declarations
(N
)) then
5765 Set_Declarations
(N
, New_List
(Call
));
5767 Prepend_To
(Declarations
(N
), Call
);
5772 end Establish_Task_Master
;
5774 --------------------------------
5775 -- Expand_Accept_Declarations --
5776 --------------------------------
5778 -- Part of the expansion of an accept statement involves the creation of
5779 -- a declaration that can be referenced from the statement sequence of
5784 -- This declaration is inserted immediately before the accept statement
5785 -- and it is important that it be inserted before the statements of the
5786 -- statement sequence are analyzed. Thus it would be too late to create
5787 -- this declaration in the Expand_N_Accept_Statement routine, which is
5788 -- why there is a separate procedure to be called directly from Sem_Ch9.
5790 -- Ann is used to hold the address of the record containing the parameters
5791 -- (see Expand_N_Entry_Call for more details on how this record is built).
5792 -- References to the parameters do an unchecked conversion of this address
5793 -- to a pointer to the required record type, and then access the field that
5794 -- holds the value of the required parameter. The entity for the address
5795 -- variable is held as the top stack element (i.e. the last element) of the
5796 -- Accept_Address stack in the corresponding entry entity, and this element
5797 -- must be set in place before the statements are processed.
5799 -- The above description applies to the case of a stand alone accept
5800 -- statement, i.e. one not appearing as part of a select alternative.
5802 -- For the case of an accept that appears as part of a select alternative
5803 -- of a selective accept, we must still create the declaration right away,
5804 -- since Ann is needed immediately, but there is an important difference:
5806 -- The declaration is inserted before the selective accept, not before
5807 -- the accept statement (which is not part of a list anyway, and so would
5808 -- not accommodate inserted declarations)
5810 -- We only need one address variable for the entire selective accept. So
5811 -- the Ann declaration is created only for the first accept alternative,
5812 -- and subsequent accept alternatives reference the same Ann variable.
5814 -- We can distinguish the two cases by seeing whether the accept statement
5815 -- is part of a list. If not, then it must be in an accept alternative.
5817 -- To expand the requeue statement, a label is provided at the end of the
5818 -- accept statement or alternative of which it is a part, so that the
5819 -- statement can be skipped after the requeue is complete. This label is
5820 -- created here rather than during the expansion of the accept statement,
5821 -- because it will be needed by any requeue statements within the accept,
5822 -- which are expanded before the accept.
5824 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
5825 Loc
: constant Source_Ptr
:= Sloc
(N
);
5826 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5827 Ann
: Entity_Id
:= Empty
;
5834 if Expander_Active
then
5836 -- If we have no handled statement sequence, we may need to build
5837 -- a dummy sequence consisting of a null statement. This can be
5838 -- skipped if the trivial accept optimization is permitted.
5840 if not Trivial_Accept_OK
5841 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
5843 Set_Handled_Statement_Sequence
(N
,
5844 Make_Handled_Sequence_Of_Statements
(Loc
,
5845 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5848 -- Create and declare two labels to be placed at the end of the
5849 -- accept statement. The first label is used to allow requeues to
5850 -- skip the remainder of entry processing. The second label is used
5851 -- to skip the remainder of entry processing if the rendezvous
5852 -- completes in the middle of the accept body.
5854 if Present
(Handled_Statement_Sequence
(N
)) then
5859 Ent
:= Make_Temporary
(Loc
, 'L');
5860 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5862 Make_Implicit_Label_Declaration
(Loc
,
5863 Defining_Identifier
=> Ent
,
5864 Label_Construct
=> Lab
);
5865 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5867 Ent
:= Make_Temporary
(Loc
, 'L');
5868 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5870 Make_Implicit_Label_Declaration
(Loc
,
5871 Defining_Identifier
=> Ent
,
5872 Label_Construct
=> Lab
);
5873 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5881 -- Case of stand alone accept statement
5883 if Is_List_Member
(N
) then
5885 if Present
(Handled_Statement_Sequence
(N
)) then
5886 Ann
:= Make_Temporary
(Loc
, 'A');
5889 Make_Object_Declaration
(Loc
,
5890 Defining_Identifier
=> Ann
,
5891 Object_Definition
=>
5892 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5894 Insert_Before_And_Analyze
(N
, Adecl
);
5895 Insert_Before_And_Analyze
(N
, Ldecl
);
5896 Insert_Before_And_Analyze
(N
, Ldecl2
);
5899 -- Case of accept statement which is in an accept alternative
5903 Acc_Alt
: constant Node_Id
:= Parent
(N
);
5904 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
5908 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
5909 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
5911 -- ??? Consider a single label for select statements
5913 if Present
(Handled_Statement_Sequence
(N
)) then
5915 Statements
(Handled_Statement_Sequence
(N
)));
5919 Statements
(Handled_Statement_Sequence
(N
)));
5923 -- Find first accept alternative of the selective accept. A
5924 -- valid selective accept must have at least one accept in it.
5926 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
5928 while Nkind
(Alt
) /= N_Accept_Alternative
loop
5932 -- If this is the first accept statement, then we have to
5933 -- create the Ann variable, as for the stand alone case, except
5934 -- that it is inserted before the selective accept. Similarly,
5935 -- a label for requeue expansion must be declared.
5937 if N
= Accept_Statement
(Alt
) then
5938 Ann
:= Make_Temporary
(Loc
, 'A');
5940 Make_Object_Declaration
(Loc
,
5941 Defining_Identifier
=> Ann
,
5942 Object_Definition
=>
5943 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5945 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
5947 -- If this is not the first accept statement, then find the Ann
5948 -- variable allocated by the first accept and use it.
5952 Node
(Last_Elmt
(Accept_Address
5953 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
5958 -- Merge here with Ann either created or referenced, and Adecl
5959 -- pointing to the corresponding declaration. Remaining processing
5960 -- is the same for the two cases.
5962 if Present
(Ann
) then
5963 Append_Elmt
(Ann
, Accept_Address
(Ent
));
5964 Set_Debug_Info_Needed
(Ann
);
5967 -- Create renaming declarations for the entry formals. Each reference
5968 -- to a formal becomes a dereference of a component of the parameter
5969 -- block, whose address is held in Ann. These declarations are
5970 -- eventually inserted into the accept block, and analyzed there so
5971 -- that they have the proper scope for gdb and do not conflict with
5972 -- other declarations.
5974 if Present
(Parameter_Specifications
(N
))
5975 and then Present
(Handled_Statement_Sequence
(N
))
5982 Renamed_Formal
: Node_Id
;
5986 Formal
:= First_Formal
(Ent
);
5988 while Present
(Formal
) loop
5989 Comp
:= Entry_Component
(Formal
);
5990 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
5992 Set_Etype
(New_F
, Etype
(Formal
));
5993 Set_Scope
(New_F
, Ent
);
5995 -- Now we set debug info needed on New_F even though it does
5996 -- not come from source, so that the debugger will get the
5997 -- right information for these generated names.
5999 Set_Debug_Info_Needed
(New_F
);
6001 if Ekind
(Formal
) = E_In_Parameter
then
6002 Mutate_Ekind
(New_F
, E_Constant
);
6004 Mutate_Ekind
(New_F
, E_Variable
);
6005 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
6008 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
6011 Make_Selected_Component
(Loc
,
6013 Make_Explicit_Dereference
(Loc
,
6014 Unchecked_Convert_To
(
6015 Entry_Parameters_Type
(Ent
),
6016 New_Occurrence_Of
(Ann
, Loc
))),
6018 New_Occurrence_Of
(Comp
, Loc
));
6021 Build_Renamed_Formal_Declaration
6022 (New_F
, Formal
, Comp
, Renamed_Formal
);
6024 if No
(Declarations
(N
)) then
6025 Set_Declarations
(N
, New_List
);
6028 Append
(Decl
, Declarations
(N
));
6029 Set_Renamed_Object
(Formal
, New_F
);
6030 Next_Formal
(Formal
);
6037 end Expand_Accept_Declarations
;
6039 ---------------------------------------------
6040 -- Expand_Access_Protected_Subprogram_Type --
6041 ---------------------------------------------
6043 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
6044 Loc
: constant Source_Ptr
:= Sloc
(N
);
6045 T
: constant Entity_Id
:= Defining_Identifier
(N
);
6046 D_T
: constant Entity_Id
:= Designated_Type
(T
);
6047 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
6048 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
6049 P_List
: constant List_Id
:=
6050 Build_Protected_Spec
(N
, RTE
(RE_Address
), D_T
, False);
6058 -- Create access to subprogram with full signature
6060 if Etype
(D_T
) /= Standard_Void_Type
then
6062 Make_Access_Function_Definition
(Loc
,
6063 Parameter_Specifications
=> P_List
,
6064 Result_Definition
=>
6065 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
6069 Make_Access_Procedure_Definition
(Loc
,
6070 Parameter_Specifications
=> P_List
);
6074 Make_Full_Type_Declaration
(Loc
,
6075 Defining_Identifier
=> D_T2
,
6076 Type_Definition
=> Def1
);
6078 -- Declare the new types before the original one since the latter will
6079 -- refer to them through the Equivalent_Type slot.
6081 Insert_Before_And_Analyze
(N
, Decl1
);
6083 -- Associate the access to subprogram with its original access to
6084 -- protected subprogram type. Needed by the backend to know that this
6085 -- type corresponds with an access to protected subprogram type.
6087 Set_Original_Access_Type
(D_T2
, T
);
6089 -- Create Equivalent_Type, a record with two components for an access to
6090 -- object and an access to subprogram.
6093 Make_Component_Declaration
(Loc
,
6094 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
6095 Component_Definition
=>
6096 Make_Component_Definition
(Loc
,
6097 Aliased_Present
=> False,
6098 Subtype_Indication
=>
6099 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
6101 Make_Component_Declaration
(Loc
,
6102 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
6103 Component_Definition
=>
6104 Make_Component_Definition
(Loc
,
6105 Aliased_Present
=> False,
6106 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
6109 Make_Full_Type_Declaration
(Loc
,
6110 Defining_Identifier
=> E_T
,
6112 Make_Record_Definition
(Loc
,
6114 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
6116 Insert_Before_And_Analyze
(N
, Decl2
);
6117 Set_Equivalent_Type
(T
, E_T
);
6118 end Expand_Access_Protected_Subprogram_Type
;
6120 --------------------------
6121 -- Expand_Entry_Barrier --
6122 --------------------------
6124 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
6125 Cond
: constant Node_Id
:= Condition
(Entry_Body_Formal_Part
(N
));
6126 Prot
: constant Entity_Id
:= Scope
(Ent
);
6127 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
6129 Func_Id
: Entity_Id
:= Empty
;
6130 -- The entity of the barrier function
6132 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
;
6133 -- Check whether entity in Barrier is external to protected type.
6134 -- If so, barrier may not be properly synchronized.
6136 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
;
6137 -- Check whether N meets the Pure_Barriers restriction. Return OK if
6140 function Is_Simple_Barrier
(N
: Node_Id
) return Boolean;
6141 -- Check whether N meets the Simple_Barriers restriction. Return OK if
6144 ----------------------
6145 -- Is_Global_Entity --
6146 ----------------------
6148 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
is
6153 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
6157 if Ekind
(E
) = E_Variable
then
6159 -- If the variable is local to the barrier function generated
6160 -- during expansion, it is ok. If expansion is not performed,
6161 -- then Func is Empty so this test cannot succeed.
6163 if Scope
(E
) = Func_Id
then
6166 -- A protected call from a barrier to another object is ok
6168 elsif Ekind
(Etype
(E
)) = E_Protected_Type
then
6171 -- If the variable is within the package body we consider
6172 -- this safe. This is a common (if dubious) idiom.
6174 elsif S
= Scope
(Prot
)
6175 and then Is_Package_Or_Generic_Package
(S
)
6176 and then Nkind
(Parent
(E
)) = N_Object_Declaration
6177 and then Nkind
(Parent
(Parent
(E
))) = N_Package_Body
6182 Error_Msg_N
("potentially unsynchronized barrier??", N
);
6183 Error_Msg_N
("\& should be private component of type??", N
);
6189 end Is_Global_Entity
;
6191 procedure Check_Unprotected_Barrier
is
6192 new Traverse_Proc
(Is_Global_Entity
);
6194 -----------------------
6195 -- Is_Simple_Barrier --
6196 -----------------------
6198 function Is_Simple_Barrier
(N
: Node_Id
) return Boolean is
6202 if Is_Static_Expression
(N
) then
6204 elsif Ada_Version
>= Ada_2022
6205 and then Nkind
(N
) in N_Selected_Component | N_Indexed_Component
6206 and then Statically_Names_Object
(N
)
6208 -- Restriction relaxed in Ada 2022 to allow statically named
6210 return Is_Simple_Barrier
(Prefix
(N
));
6213 -- Check if the name is a component of the protected object. If
6214 -- the expander is active, the component has been transformed into a
6215 -- renaming of _object.all.component. Original_Node is needed in case
6216 -- validity checking is enabled, in which case the simple object
6217 -- reference will have been rewritten.
6219 if Expander_Active
then
6221 -- The expanded name may have been constant folded in which case
6222 -- the original node is not necessarily an entity name (e.g. an
6223 -- indexed component).
6225 if not Is_Entity_Name
(Original_Node
(N
)) then
6229 Renamed
:= Renamed_Object
(Entity
(Original_Node
(N
)));
6233 and then Nkind
(Renamed
) = N_Selected_Component
6234 and then Chars
(Prefix
(Prefix
(Renamed
))) = Name_uObject
;
6235 elsif not Is_Entity_Name
(N
) then
6238 return Is_Protected_Component
(Entity
(N
));
6240 end Is_Simple_Barrier
;
6242 ---------------------
6243 -- Is_Pure_Barrier --
6244 ---------------------
6246 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
is
6249 when N_Expanded_Name
6253 -- Because of N_Expanded_Name case, return Skip instead of OK.
6255 if No
(Entity
(N
)) then
6258 elsif Is_Numeric_Type
(Entity
(N
)) then
6262 case Ekind
(Entity
(N
)) is
6268 when E_Enumeration_Literal
6272 if not Is_OK_Static_Expression
(N
) then
6281 if Is_Simple_Barrier
(N
) then
6287 -- The count attribute has been transformed into run-time
6290 if Is_RTE
(Entity
(N
), RE_Protected_Count
)
6291 or else Is_RTE
(Entity
(N
), RE_Protected_Count_Entry
)
6300 when N_Function_Call
=>
6302 -- Function call checks are carried out as part of the analysis
6303 -- of the function call name.
6307 when N_Character_Literal
6316 if Ekind
(Entity
(N
)) = E_Operator
then
6320 when N_Short_Circuit
6326 when N_Indexed_Component | N_Selected_Component
=>
6327 if Statically_Names_Object
(N
) then
6328 return Is_Pure_Barrier
(Prefix
(N
));
6333 when N_Case_Expression_Alternative
=>
6334 -- do not traverse Discrete_Choices subtree
6335 if Is_Pure_Barrier
(Expression
(N
)) /= Abandon
then
6339 when N_Expression_With_Actions
=>
6340 -- this may occur in the case of a Count attribute reference
6341 if Original_Node
(N
) /= N
6342 and then Is_Pure_Barrier
(Original_Node
(N
)) /= Abandon
6347 when N_Membership_Test
=>
6348 if Is_Pure_Barrier
(Left_Opnd
(N
)) /= Abandon
6349 and then All_Membership_Choices_Static
(N
)
6354 when N_Type_Conversion
=>
6356 -- Conversions to Universal_Integer do not raise constraint
6357 -- errors. Likewise if the expression's type is statically
6358 -- compatible with the target's type.
6360 if Etype
(N
) = Universal_Integer
6361 or else Subtypes_Statically_Compatible
6362 (Etype
(Expression
(N
)), Etype
(N
))
6367 when N_Unchecked_Type_Conversion
=>
6375 end Is_Pure_Barrier
;
6377 function Check_Pure_Barriers
is new Traverse_Func
(Is_Pure_Barrier
);
6381 Cond_Id
: Entity_Id
;
6382 Entry_Body
: Node_Id
;
6383 Func_Body
: Node_Id
:= Empty
;
6385 -- Start of processing for Expand_Entry_Barrier
6388 if No_Run_Time_Mode
then
6389 Error_Msg_CRT
("entry barrier", N
);
6393 -- Prevent cascaded errors
6395 if Nkind
(Cond
) = N_Error
then
6399 -- The body of the entry barrier must be analyzed in the context of the
6400 -- protected object, but its scope is external to it, just as any other
6401 -- unprotected version of a protected operation. The specification has
6402 -- been produced when the protected type declaration was elaborated. We
6403 -- build the body, insert it in the enclosing scope, but analyze it in
6404 -- the current context. A more uniform approach would be to treat the
6405 -- barrier just as a protected function, and discard the protected
6406 -- version of it because it is never called.
6408 if Expander_Active
then
6409 Func_Body
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6410 Func_Id
:= Barrier_Function
(Ent
);
6411 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
6413 Entry_Body
:= Parent
(Corresponding_Body
(Spec_Decl
));
6415 if Nkind
(Parent
(Entry_Body
)) = N_Subunit
then
6416 Entry_Body
:= Corresponding_Stub
(Parent
(Entry_Body
));
6419 Insert_Before_And_Analyze
(Entry_Body
, Func_Body
);
6421 Set_Discriminals
(Spec_Decl
);
6422 Set_Scope
(Func_Id
, Scope
(Prot
));
6425 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6428 -- Check Simple_Barriers and Pure_Barriers restrictions.
6429 -- Note that it is safe to be calling Check_Restriction from here, even
6430 -- though this is part of the expander, since Expand_Entry_Barrier is
6431 -- called from Sem_Ch9 even in -gnatc mode.
6433 if not Is_Simple_Barrier
(Cond
) then
6434 -- flag restriction violation
6435 Check_Restriction
(Simple_Barriers
, Cond
);
6438 if Check_Pure_Barriers
(Cond
) = Abandon
then
6439 -- flag restriction violation
6440 Check_Restriction
(Pure_Barriers
, Cond
);
6442 -- Emit warning if barrier contains global entities and is thus
6443 -- potentially unsynchronized (if Pure_Barriers restrictions
6444 -- are met then no need to check for this).
6445 Check_Unprotected_Barrier
(Cond
);
6448 if Is_Entity_Name
(Cond
) then
6449 Cond_Id
:= Entity
(Cond
);
6451 -- Perform a small optimization of simple barrier functions. If the
6452 -- scope of the condition's entity is not the barrier function, then
6453 -- the condition does not depend on any of the generated renamings.
6454 -- If this is the case, eliminate the renamings as they are useless.
6455 -- This optimization is not performed when the condition was folded
6456 -- and validity checks are in effect because the original condition
6457 -- may have produced at least one check that depends on the generated
6461 and then Scope
(Cond_Id
) /= Func_Id
6462 and then not Validity_Check_Operands
6464 Set_Declarations
(Func_Body
, Empty_List
);
6467 -- Note that after analysis variables in this context will be
6468 -- replaced by the corresponding prival, that is to say a renaming
6469 -- of a selected component of the form _Object.Var. If expansion is
6470 -- disabled, as within a generic, we check that the entity appears in
6471 -- the current scope.
6473 end Expand_Entry_Barrier
;
6475 ------------------------------
6476 -- Expand_N_Abort_Statement --
6477 ------------------------------
6479 -- Expand abort T1, T2, .. Tn; into:
6480 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6482 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6483 Loc
: constant Source_Ptr
:= Sloc
(N
);
6484 Tlist
: constant List_Id
:= Names
(N
);
6490 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6493 Tasknm
:= First
(Tlist
);
6495 while Present
(Tasknm
) loop
6498 -- A task interface class-wide type object is being aborted. Retrieve
6499 -- its _task_id by calling a dispatching routine.
6501 if Ada_Version
>= Ada_2005
6502 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6503 and then Is_Interface
(Etype
(Tasknm
))
6504 and then Is_Task_Interface
(Etype
(Tasknm
))
6506 Append_To
(Component_Associations
(Aggr
),
6507 Make_Component_Association
(Loc
,
6508 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6511 -- Task_Id (Tasknm._disp_get_task_id)
6513 Unchecked_Convert_To
6514 (RTE
(RO_ST_Task_Id
),
6515 Make_Selected_Component
(Loc
,
6516 Prefix
=> New_Copy_Tree
(Tasknm
),
6518 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6521 Append_To
(Component_Associations
(Aggr
),
6522 Make_Component_Association
(Loc
,
6523 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6524 Expression
=> Concurrent_Ref
(Tasknm
)));
6531 Make_Procedure_Call_Statement
(Loc
,
6532 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Tasks
), Loc
),
6533 Parameter_Associations
=> New_List
(
6534 Make_Qualified_Expression
(Loc
,
6535 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_List
), Loc
),
6536 Expression
=> Aggr
))));
6539 end Expand_N_Abort_Statement
;
6541 -------------------------------
6542 -- Expand_N_Accept_Statement --
6543 -------------------------------
6545 -- This procedure handles expansion of accept statements that stand alone,
6546 -- i.e. they are not part of an accept alternative. The expansion of
6547 -- accept statement in accept alternatives is handled by the routines
6548 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6549 -- following description applies only to stand alone accept statements.
6551 -- If there is no handled statement sequence, or only null statements, then
6552 -- this is called a trivial accept, and the expansion is:
6554 -- Accept_Trivial (entry-index)
6556 -- If there is a handled statement sequence, then the expansion is:
6563 -- Accept_Call (entry-index, Ann);
6564 -- Renaming_Declarations for formals
6565 -- <statement sequence from N_Accept_Statement node>
6566 -- Complete_Rendezvous;
6571 -- <exception handler from N_Accept_Statement node>
6572 -- Complete_Rendezvous;
6574 -- <exception handler from N_Accept_Statement node>
6575 -- Complete_Rendezvous;
6580 -- when all others =>
6581 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6584 -- The first three declarations were already inserted ahead of the accept
6585 -- statement by the Expand_Accept_Declarations procedure, which was called
6586 -- directly from the semantics during analysis of the accept statement,
6587 -- before analyzing its contained statements.
6589 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6590 -- from possible expansion activity (the original source of course does
6591 -- not have any declarations associated with the accept statement, since
6592 -- an accept statement has no declarative part). In particular, if the
6593 -- expander is active, the first such declaration is the declaration of
6594 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6596 -- The two blocks are merged into a single block if the inner block has
6597 -- no exception handlers, but otherwise two blocks are required, since
6598 -- exceptions might be raised in the exception handlers of the inner
6599 -- block, and Exceptional_Complete_Rendezvous must be called.
6601 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6602 Loc
: constant Source_Ptr
:= Sloc
(N
);
6603 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6604 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6605 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6606 Eent
: constant Entity_Id
:= Entity
(Ename
);
6607 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6608 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6609 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6615 -- If the accept statement is not part of a list, then its parent must
6616 -- be an accept alternative, and, as described above, we do not do any
6617 -- expansion for such accept statements at this level.
6619 if not Is_List_Member
(N
) then
6620 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6623 -- Trivial accept case (no statement sequence, or null statements).
6624 -- If the accept statement has declarations, then just insert them
6625 -- before the procedure call.
6627 elsif Trivial_Accept_OK
6628 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6630 -- Remove declarations for renamings, because the parameter block
6631 -- will not be assigned.
6638 D
:= First
(Declarations
(N
));
6639 while Present
(D
) loop
6641 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6649 if Present
(Declarations
(N
)) then
6650 Insert_Actions
(N
, Declarations
(N
));
6654 Make_Procedure_Call_Statement
(Loc
,
6655 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Trivial
), Loc
),
6656 Parameter_Associations
=> New_List
(
6657 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6661 -- Ada 2022 (AI12-0279)
6663 if Has_Yield_Aspect
(Eent
)
6664 and then RTE_Available
(RE_Yield
)
6666 Insert_Action_After
(N
,
6667 Make_Procedure_Call_Statement
(Loc
,
6668 New_Occurrence_Of
(RTE
(RE_Yield
), Loc
)));
6671 -- Discard Entry_Address that was created for it, so it will not be
6672 -- emitted if this accept statement is in the statement part of a
6673 -- delay alternative.
6675 if Present
(Stats
) then
6676 Remove_Last_Elmt
(Acstack
);
6679 -- Case of statement sequence present
6682 -- Construct the block, using the declarations from the accept
6683 -- statement if any to initialize the declarations of the block.
6685 Blkent
:= Make_Temporary
(Loc
, 'A');
6686 Mutate_Ekind
(Blkent
, E_Block
);
6687 Set_Etype
(Blkent
, Standard_Void_Type
);
6688 Set_Scope
(Blkent
, Current_Scope
);
6691 Make_Block_Statement
(Loc
,
6692 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
6693 Declarations
=> Declarations
(N
),
6694 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6696 -- Reset the Scope of local entities associated with the accept
6697 -- statement (that currently reference the entry scope) to the
6698 -- block scope, to avoid having references to the locals treated
6699 -- as up-level references.
6701 Reset_Scopes_To
(Block
, Blkent
);
6703 -- For the analysis of the generated declarations, the parent node
6704 -- must be properly set.
6706 Set_Parent
(Block
, Parent
(N
));
6707 Set_Parent
(Blkent
, Block
);
6709 -- Prepend call to Accept_Call to main statement sequence If the
6710 -- accept has exception handlers, the statement sequence is wrapped
6711 -- in a block. Insert call and renaming declarations in the
6712 -- declarations of the block, so they are elaborated before the
6716 Make_Procedure_Call_Statement
(Loc
,
6717 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Call
), Loc
),
6718 Parameter_Associations
=> New_List
(
6719 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6720 New_Occurrence_Of
(Ann
, Loc
)));
6722 if Parent
(Stats
) = N
then
6723 Prepend
(Call
, Statements
(Stats
));
6725 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6730 Push_Scope
(Blkent
);
6738 D
:= First
(Declarations
(N
));
6739 while Present
(D
) loop
6742 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6744 -- The renaming declarations for the formals were created
6745 -- during analysis of the accept statement, and attached to
6746 -- the list of declarations. Place them now in the context
6747 -- of the accept block or subprogram.
6750 Typ
:= Entity
(Subtype_Mark
(D
));
6751 Insert_After
(Call
, D
);
6754 -- If the formal is class_wide, it does not have an actual
6755 -- subtype. The analysis of the renaming declaration creates
6756 -- one, but we need to retain the class-wide nature of the
6759 if Is_Class_Wide_Type
(Typ
) then
6760 Set_Etype
(Defining_Identifier
(D
), Typ
);
6771 -- Replace the accept statement by the new block
6776 -- Last step is to unstack the Accept_Address value
6778 Remove_Last_Elmt
(Acstack
);
6780 end Expand_N_Accept_Statement
;
6782 ----------------------------------
6783 -- Expand_N_Asynchronous_Select --
6784 ----------------------------------
6786 -- This procedure assumes that the trigger statement is an entry call or
6787 -- a dispatching procedure call. A delay alternative should already have
6788 -- been expanded into an entry call to the appropriate delay object Wait
6791 -- If the trigger is a task entry call, the select is implemented with
6792 -- a Task_Entry_Call:
6797 -- P : parms := (parm, parm, parm);
6799 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6801 -- procedure _clean is
6804 -- Cancel_Task_Entry_Call (C);
6811 -- (<acceptor-task>, -- Acceptor
6812 -- <entry-index>, -- E
6813 -- P'Address, -- Uninterpreted_Data
6814 -- Asynchronous_Call, -- Mode
6815 -- B); -- Rendezvous_Successful
6822 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6825 -- when Abort_Signal => Abort_Undefer;
6832 -- <triggered-statements>
6836 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6837 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6841 -- P : parms := (parm, parm, parm);
6843 -- Call_Simple (acceptor-task, entry-index, P'Address);
6849 -- so the task at hand is to convert the latter expansion into the former
6851 -- If the trigger is a protected entry call, the select is implemented
6852 -- with Protected_Entry_Call:
6855 -- P : E1_Params := (param, param, param);
6856 -- Bnn : Communications_Block;
6861 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6863 -- procedure _clean is
6866 -- if Enqueued (Bnn) then
6867 -- Cancel_Protected_Entry_Call (Bnn);
6874 -- Protected_Entry_Call
6875 -- (po._object'Access, -- Object
6876 -- <entry index>, -- E
6877 -- P'Address, -- Uninterpreted_Data
6878 -- Asynchronous_Call, -- Mode
6881 -- if Enqueued (Bnn) then
6885 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6888 -- when Abort_Signal => Abort_Undefer;
6891 -- if not Cancelled (Bnn) then
6892 -- <triggered-statements>
6896 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6900 -- P : E1_Params := (param, param, param);
6901 -- Bnn : Communications_Block;
6904 -- Protected_Entry_Call
6905 -- (po._object'Access, -- Object
6906 -- <entry index>, -- E
6907 -- P'Address, -- Uninterpreted_Data
6908 -- Simple_Call, -- Mode
6915 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6919 -- B : Boolean := False;
6920 -- Bnn : Communication_Block;
6921 -- C : Ada.Tags.Prim_Op_Kind;
6922 -- D : System.Storage_Elements.Dummy_Communication_Block;
6923 -- K : Ada.Tags.Tagged_Kind :=
6924 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6925 -- P : Parameters := (Param1 .. ParamN);
6930 -- if K = Ada.Tags.TK_Limited_Tagged
6931 -- or else K = Ada.Tags.TK_Tagged
6933 -- <dispatching-call>;
6934 -- <triggering-statements>;
6938 -- Ada.Tags.Get_Offset_Index
6939 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6941 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6943 -- if C = POK_Protected_Entry then
6945 -- procedure _clean is
6947 -- if Enqueued (Bnn) then
6948 -- Cancel_Protected_Entry_Call (Bnn);
6954 -- _Disp_Asynchronous_Select
6955 -- (<object>, S, P'Address, D, B);
6956 -- Bnn := Communication_Block (D);
6958 -- Param1 := P.Param1;
6960 -- ParamN := P.ParamN;
6962 -- if Enqueued (Bnn) then
6963 -- <abortable-statements>
6966 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6969 -- when Abort_Signal => Abort_Undefer;
6972 -- if not Cancelled (Bnn) then
6973 -- <triggering-statements>
6976 -- elsif C = POK_Task_Entry then
6978 -- procedure _clean is
6980 -- Cancel_Task_Entry_Call (U);
6986 -- _Disp_Asynchronous_Select
6987 -- (<object>, S, P'Address, D, B);
6988 -- Bnn := Communication_Bloc (D);
6990 -- Param1 := P.Param1;
6992 -- ParamN := P.ParamN;
6997 -- <abortable-statements>
6999 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7002 -- when Abort_Signal => Abort_Undefer;
7006 -- <triggering-statements>
7011 -- <dispatching-call>;
7012 -- <triggering-statements>
7017 -- The job is to convert this to the asynchronous form
7019 -- If the trigger is a delay statement, it will have been expanded into
7020 -- a call to one of the GNARL delay procedures. This routine will convert
7021 -- this into a protected entry call on a delay object and then continue
7022 -- processing as for a protected entry call trigger. This requires
7023 -- declaring a Delay_Block object and adding a pointer to this object to
7024 -- the parameter list of the delay procedure to form the parameter list of
7025 -- the entry call. This object is used by the runtime to queue the delay
7028 -- For a description of the use of P and the assignments after the call,
7029 -- see Expand_N_Entry_Call_Statement.
7031 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
7032 Loc
: constant Source_Ptr
:= Sloc
(N
);
7033 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
7034 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
7036 Abort_Block_Ent
: Entity_Id
;
7037 Abortable_Block
: Node_Id
;
7040 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7041 Blk_Typ
: Entity_Id
;
7043 Call_Ent
: Entity_Id
;
7044 Cancel_Param
: Entity_Id
;
7045 Cleanup_Block
: Node_Id
;
7046 Cleanup_Block_Ent
: Entity_Id
;
7047 Cleanup_Stmts
: List_Id
;
7048 Conc_Typ_Stmts
: List_Id
;
7050 Dblock_Ent
: Entity_Id
;
7055 Enqueue_Call
: Node_Id
;
7059 Lim_Typ_Stmts
: List_Id
;
7065 ProtE_Stmts
: List_Id
;
7066 ProtP_Stmts
: List_Id
;
7069 TaskE_Stmts
: List_Id
;
7072 B
: Entity_Id
; -- Call status flag
7073 Bnn
: Entity_Id
; -- Communication block
7074 C
: Entity_Id
; -- Call kind
7075 K
: Entity_Id
; -- Tagged kind
7076 P
: Entity_Id
; -- Parameter block
7077 S
: Entity_Id
; -- Primitive operation slot
7078 T
: Entity_Id
; -- Additional status flag
7080 procedure Rewrite_Abortable_Part
;
7081 -- If the trigger is a dispatching call, the expansion inserts multiple
7082 -- copies of the abortable part. This is both inefficient, and may lead
7083 -- to duplicate definitions that the back-end will reject, when the
7084 -- abortable part includes loops. This procedure rewrites the abortable
7085 -- part into a call to a generated procedure.
7087 ----------------------------
7088 -- Rewrite_Abortable_Part --
7089 ----------------------------
7091 procedure Rewrite_Abortable_Part
is
7092 Proc
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7097 Make_Subprogram_Body
(Loc
,
7099 Make_Procedure_Specification
(Loc
, Defining_Unit_Name
=> Proc
),
7100 Declarations
=> New_List
,
7101 Handled_Statement_Sequence
=>
7102 Make_Handled_Sequence_Of_Statements
(Loc
, Astats
));
7103 Insert_Before
(N
, Decl
);
7106 -- Rewrite abortable part into a call to this procedure
7110 Make_Procedure_Call_Statement
(Loc
,
7111 Name
=> New_Occurrence_Of
(Proc
, Loc
)));
7112 end Rewrite_Abortable_Part
;
7114 -- Start of processing for Expand_N_Asynchronous_Select
7117 -- Asynchronous select is not supported on restricted runtimes. Don't
7120 if Restricted_Profile
then
7124 Process_Statements_For_Controlled_Objects
(Trig
);
7125 Process_Statements_For_Controlled_Objects
(Abrt
);
7127 Ecall
:= Triggering_Statement
(Trig
);
7129 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
7131 -- Retrieve Astats and Tstats now because the finalization machinery may
7132 -- wrap them in blocks.
7134 Astats
:= Statements
(Abrt
);
7135 Tstats
:= Statements
(Trig
);
7137 -- The arguments in the call may require dynamic allocation, and the
7138 -- call statement may have been transformed into a block. The block
7139 -- may contain additional declarations for internal entities, and the
7140 -- original call is found by sequential search.
7142 if Nkind
(Ecall
) = N_Block_Statement
then
7143 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
7144 while Nkind
(Ecall
) not in
7145 N_Procedure_Call_Statement | N_Entry_Call_Statement
7151 -- This is either a dispatching call or a delay statement used as a
7152 -- trigger which was expanded into a procedure call.
7154 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
7155 if Ada_Version
>= Ada_2005
7157 (No
(Original_Node
(Ecall
))
7158 or else Nkind
(Original_Node
(Ecall
)) not in N_Delay_Statement
)
7160 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
7162 Rewrite_Abortable_Part
;
7166 -- Call status flag processing, generate:
7167 -- B : Boolean := False;
7169 B
:= Build_B
(Loc
, Decls
);
7171 -- Communication block processing, generate:
7172 -- Bnn : Communication_Block;
7174 Bnn
:= Make_Temporary
(Loc
, 'B');
7176 Make_Object_Declaration
(Loc
,
7177 Defining_Identifier
=> Bnn
,
7178 Object_Definition
=>
7179 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
7181 -- Call kind processing, generate:
7182 -- C : Ada.Tags.Prim_Op_Kind;
7184 C
:= Build_C
(Loc
, Decls
);
7186 -- Tagged kind processing, generate:
7187 -- K : Ada.Tags.Tagged_Kind :=
7188 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7190 -- Dummy communication block, generate:
7191 -- D : Dummy_Communication_Block;
7194 Make_Object_Declaration
(Loc
,
7195 Defining_Identifier
=>
7196 Make_Defining_Identifier
(Loc
, Name_uD
),
7197 Object_Definition
=>
7199 (RTE
(RE_Dummy_Communication_Block
), Loc
)));
7201 K
:= Build_K
(Loc
, Decls
, Obj
);
7203 -- Parameter block processing
7205 Blk_Typ
:= Build_Parameter_Block
7206 (Loc
, Actuals
, Formals
, Decls
);
7207 P
:= Parameter_Block_Pack
7208 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7210 -- Dispatch table slot processing, generate:
7213 S
:= Build_S
(Loc
, Decls
);
7215 -- Additional status flag processing, generate:
7218 T
:= Make_Temporary
(Loc
, 'T');
7220 Make_Object_Declaration
(Loc
,
7221 Defining_Identifier
=> T
,
7222 Object_Definition
=>
7223 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7225 ------------------------------
7226 -- Protected entry handling --
7227 ------------------------------
7230 -- Param1 := P.Param1;
7232 -- ParamN := P.ParamN;
7234 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7237 -- Bnn := Communication_Block (D);
7239 Prepend_To
(Cleanup_Stmts
,
7240 Make_Assignment_Statement
(Loc
,
7241 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
7243 Unchecked_Convert_To
7244 (RTE
(RE_Communication_Block
),
7245 Make_Identifier
(Loc
, Name_uD
))));
7248 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7250 Prepend_To
(Cleanup_Stmts
,
7251 Make_Procedure_Call_Statement
(Loc
,
7255 (Etype
(Etype
(Obj
)), Name_uDisp_Asynchronous_Select
),
7257 Parameter_Associations
=>
7259 New_Copy_Tree
(Obj
), -- <object>
7260 New_Occurrence_Of
(S
, Loc
), -- S
7261 Make_Attribute_Reference
(Loc
, -- P'Address
7262 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7263 Attribute_Name
=> Name_Address
),
7264 Make_Identifier
(Loc
, Name_uD
), -- D
7265 New_Occurrence_Of
(B
, Loc
)))); -- B
7268 -- if Enqueued (Bnn) then
7269 -- <abortable-statements>
7272 Append_To
(Cleanup_Stmts
,
7273 Make_Implicit_If_Statement
(N
,
7275 Make_Function_Call
(Loc
,
7277 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7278 Parameter_Associations
=>
7279 New_List
(New_Occurrence_Of
(Bnn
, Loc
))),
7282 New_Copy_List_Tree
(Astats
)));
7284 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7285 -- will then generate a _clean for the communication block Bnn.
7289 -- procedure _clean is
7291 -- if Enqueued (Bnn) then
7292 -- Cancel_Protected_Entry_Call (Bnn);
7301 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7303 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
7305 -- Wrap the cleanup block in an exception handling block
7311 -- when Abort_Signal => Abort_Undefer;
7314 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7317 Make_Implicit_Label_Declaration
(Loc
,
7318 Defining_Identifier
=> Abort_Block_Ent
),
7321 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7324 -- if not Cancelled (Bnn) then
7325 -- <triggering-statements>
7328 Append_To
(ProtE_Stmts
,
7329 Make_Implicit_If_Statement
(N
,
7333 Make_Function_Call
(Loc
,
7335 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7336 Parameter_Associations
=>
7337 New_List
(New_Occurrence_Of
(Bnn
, Loc
)))),
7340 New_Copy_List_Tree
(Tstats
)));
7342 -------------------------
7343 -- Task entry handling --
7344 -------------------------
7347 -- Param1 := P.Param1;
7349 -- ParamN := P.ParamN;
7351 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7354 -- Bnn := Communication_Block (D);
7356 Append_To
(TaskE_Stmts
,
7357 Make_Assignment_Statement
(Loc
,
7359 New_Occurrence_Of
(Bnn
, Loc
),
7361 Unchecked_Convert_To
7362 (RTE
(RE_Communication_Block
),
7363 Make_Identifier
(Loc
, Name_uD
))));
7366 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7368 Prepend_To
(TaskE_Stmts
,
7369 Make_Procedure_Call_Statement
(Loc
,
7372 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7373 Name_uDisp_Asynchronous_Select
),
7376 Parameter_Associations
=> New_List
(
7377 New_Copy_Tree
(Obj
), -- <object>
7378 New_Occurrence_Of
(S
, Loc
), -- S
7379 Make_Attribute_Reference
(Loc
, -- P'Address
7380 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7381 Attribute_Name
=> Name_Address
),
7382 Make_Identifier
(Loc
, Name_uD
), -- D
7383 New_Occurrence_Of
(B
, Loc
)))); -- B
7388 Prepend_To
(TaskE_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7392 -- <abortable-statements>
7394 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
7397 (Cleanup_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7399 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7400 -- will generate a _clean for the additional status flag.
7404 -- procedure _clean is
7406 -- Cancel_Task_Entry_Call (U);
7414 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7416 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
7418 -- Wrap the cleanup block in an exception handling block
7424 -- when Abort_Signal => Abort_Undefer;
7427 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7429 Append_To
(TaskE_Stmts
,
7430 Make_Implicit_Label_Declaration
(Loc
,
7431 Defining_Identifier
=> Abort_Block_Ent
));
7433 Append_To
(TaskE_Stmts
,
7435 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7439 -- <triggering-statements>
7442 Append_To
(TaskE_Stmts
,
7443 Make_Implicit_If_Statement
(N
,
7445 Make_Op_Not
(Loc
, Right_Opnd
=> New_Occurrence_Of
(T
, Loc
)),
7448 New_Copy_List_Tree
(Tstats
)));
7450 ----------------------------------
7451 -- Protected procedure handling --
7452 ----------------------------------
7455 -- <dispatching-call>;
7456 -- <triggering-statements>
7458 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7459 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7462 -- S := Ada.Tags.Get_Offset_Index
7463 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7466 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7469 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7471 Append_To
(Conc_Typ_Stmts
,
7472 Make_Procedure_Call_Statement
(Loc
,
7475 (Find_Prim_Op
(Etype
(Etype
(Obj
)),
7476 Name_uDisp_Get_Prim_Op_Kind
),
7478 Parameter_Associations
=>
7480 New_Copy_Tree
(Obj
),
7481 New_Occurrence_Of
(S
, Loc
),
7482 New_Occurrence_Of
(C
, Loc
))));
7485 -- if C = POK_Procedure_Entry then
7487 -- elsif C = POK_Task_Entry then
7493 Append_To
(Conc_Typ_Stmts
,
7494 Make_Implicit_If_Statement
(N
,
7498 New_Occurrence_Of
(C
, Loc
),
7500 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7507 Make_Elsif_Part
(Loc
,
7511 New_Occurrence_Of
(C
, Loc
),
7513 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
)),
7522 -- <dispatching-call>;
7523 -- <triggering-statements>
7525 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7526 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7529 -- if K = Ada.Tags.TK_Limited_Tagged
7530 -- or else K = Ada.Tags.TK_Tagged
7538 Make_Implicit_If_Statement
(N
,
7539 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
7540 Then_Statements
=> Lim_Typ_Stmts
,
7541 Else_Statements
=> Conc_Typ_Stmts
));
7544 Make_Block_Statement
(Loc
,
7547 Handled_Statement_Sequence
=>
7548 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7553 -- Delay triggering statement processing
7556 -- Add a Delay_Block object to the parameter list of the delay
7557 -- procedure to form the parameter list of the Wait entry call.
7559 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7561 Pdef
:= Entity
(Name
(Ecall
));
7563 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7565 New_Occurrence_Of
(RTE
(RE_Enqueue_Duration
), Loc
);
7567 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7569 New_Occurrence_Of
(RTE
(RE_Enqueue_Calendar
), Loc
);
7571 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7572 Enqueue_Call
:= New_Occurrence_Of
(RTE
(RE_Enqueue_RT
), Loc
);
7575 Append_To
(Parameter_Associations
(Ecall
),
7576 Make_Attribute_Reference
(Loc
,
7577 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7578 Attribute_Name
=> Name_Unchecked_Access
));
7580 -- Create the inner block to protect the abortable part
7582 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7584 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7587 Make_Block_Statement
(Loc
,
7588 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7589 Handled_Statement_Sequence
=>
7590 Make_Handled_Sequence_Of_Statements
(Loc
,
7591 Statements
=> Astats
),
7592 Has_Created_Identifier
=> True,
7593 Is_Asynchronous_Call_Block
=> True);
7595 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7598 Make_Implicit_If_Statement
(N
,
7600 Make_Function_Call
(Loc
,
7601 Name
=> Enqueue_Call
,
7602 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7604 New_List
(Make_Block_Statement
(Loc
,
7605 Handled_Statement_Sequence
=>
7606 Make_Handled_Sequence_Of_Statements
(Loc
,
7607 Statements
=> New_List
(
7608 Make_Implicit_Label_Declaration
(Loc
,
7609 Defining_Identifier
=> Blk_Ent
,
7610 Label_Construct
=> Abortable_Block
),
7612 Exception_Handlers
=> Hdle
)))));
7614 Stmts
:= New_List
(Ecall
);
7616 -- Construct statement sequence for new block
7619 Make_Implicit_If_Statement
(N
,
7621 Make_Function_Call
(Loc
,
7622 Name
=> New_Occurrence_Of
(
7623 RTE
(RE_Timed_Out
), Loc
),
7624 Parameter_Associations
=> New_List
(
7625 Make_Attribute_Reference
(Loc
,
7626 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7627 Attribute_Name
=> Name_Unchecked_Access
))),
7628 Then_Statements
=> Tstats
));
7630 -- The result is the new block
7632 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7635 Make_Block_Statement
(Loc
,
7636 Declarations
=> New_List
(
7637 Make_Object_Declaration
(Loc
,
7638 Defining_Identifier
=> Dblock_Ent
,
7639 Aliased_Present
=> True,
7640 Object_Definition
=>
7641 New_Occurrence_Of
(RTE
(RE_Delay_Block
), Loc
))),
7643 Handled_Statement_Sequence
=>
7644 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7654 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7655 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7657 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7658 Decls
:= Declarations
(Ecall
);
7660 if Is_Protected_Type
(Etype
(Concval
)) then
7662 -- Get the declarations of the block expanded from the entry call
7664 Decl
:= First
(Decls
);
7665 while Present
(Decl
)
7666 and then (Nkind
(Decl
) /= N_Object_Declaration
7667 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7668 RE_Communication_Block
))
7673 pragma Assert
(Present
(Decl
));
7674 Cancel_Param
:= Defining_Identifier
(Decl
);
7676 -- Change the mode of the Protected_Entry_Call call
7678 -- Protected_Entry_Call (
7679 -- Object => po._object'Access,
7680 -- E => <entry index>;
7681 -- Uninterpreted_Data => P'Address;
7682 -- Mode => Asynchronous_Call;
7685 -- Skip assignments to temporaries created for in-out parameters
7687 -- This makes unwarranted assumptions about the shape of the expanded
7688 -- tree for the call, and should be cleaned up ???
7690 Stmt
:= First
(Stmts
);
7691 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7697 Param
:= First
(Parameter_Associations
(Call
));
7698 while Present
(Param
)
7699 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7704 pragma Assert
(Present
(Param
));
7705 Rewrite
(Param
, New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7708 -- Append an if statement to execute the abortable part
7711 -- if Enqueued (Bnn) then
7714 Make_Implicit_If_Statement
(N
,
7716 Make_Function_Call
(Loc
,
7717 Name
=> New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7718 Parameter_Associations
=> New_List
(
7719 New_Occurrence_Of
(Cancel_Param
, Loc
))),
7720 Then_Statements
=> Astats
));
7723 Make_Block_Statement
(Loc
,
7724 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7725 Handled_Statement_Sequence
=>
7726 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7727 Has_Created_Identifier
=> True,
7728 Is_Asynchronous_Call_Block
=> True);
7731 Make_Block_Statement
(Loc
,
7732 Handled_Statement_Sequence
=>
7733 Make_Handled_Sequence_Of_Statements
(Loc
,
7734 Statements
=> New_List
(
7735 Make_Implicit_Label_Declaration
(Loc
,
7736 Defining_Identifier
=> Blk_Ent
,
7737 Label_Construct
=> Abortable_Block
),
7742 Exception_Handlers
=> New_List
(
7743 Make_Implicit_Exception_Handler
(Loc
,
7745 -- when Abort_Signal =>
7748 Exception_Choices
=>
7749 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
7750 Statements
=> New_List
(Make_Null_Statement
(Loc
)))))),
7752 -- if not Cancelled (Bnn) then
7753 -- triggered statements
7756 Make_Implicit_If_Statement
(N
,
7757 Condition
=> Make_Op_Not
(Loc
,
7759 Make_Function_Call
(Loc
,
7760 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7761 Parameter_Associations
=> New_List
(
7762 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7763 Then_Statements
=> Tstats
));
7765 -- Asynchronous task entry call
7772 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7774 -- Insert declaration of B in declarations of existing block
7777 Make_Object_Declaration
(Loc
,
7778 Defining_Identifier
=> B
,
7779 Object_Definition
=>
7780 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7782 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7784 -- Insert the declaration of C in the declarations of the existing
7785 -- block. The variable is initialized to something (True or False,
7786 -- does not matter) to prevent CodePeer from complaining about a
7787 -- possible read of an uninitialized variable.
7790 Make_Object_Declaration
(Loc
,
7791 Defining_Identifier
=> Cancel_Param
,
7792 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7793 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
7794 Has_Init_Expression
=> True));
7796 -- Remove and save the call to Call_Simple
7798 Stmt
:= First
(Stmts
);
7800 -- Skip assignments to temporaries created for in-out parameters.
7801 -- This makes unwarranted assumptions about the shape of the expanded
7802 -- tree for the call, and should be cleaned up ???
7804 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7810 -- Create the inner block to protect the abortable part
7812 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7814 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7817 Make_Block_Statement
(Loc
,
7818 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7819 Handled_Statement_Sequence
=>
7820 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7821 Has_Created_Identifier
=> True,
7822 Is_Asynchronous_Call_Block
=> True);
7825 Make_Block_Statement
(Loc
,
7826 Handled_Statement_Sequence
=>
7827 Make_Handled_Sequence_Of_Statements
(Loc
,
7828 Statements
=> New_List
(
7829 Make_Implicit_Label_Declaration
(Loc
,
7830 Defining_Identifier
=> Blk_Ent
,
7831 Label_Construct
=> Abortable_Block
),
7833 Exception_Handlers
=> Hdle
)));
7835 -- Create new call statement
7837 Params
:= Parameter_Associations
(Call
);
7840 New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7841 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
7844 Make_Procedure_Call_Statement
(Loc
,
7845 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
7846 Parameter_Associations
=> Params
));
7848 -- Construct statement sequence for new block
7851 Make_Implicit_If_Statement
(N
,
7853 Make_Op_Not
(Loc
, New_Occurrence_Of
(Cancel_Param
, Loc
)),
7854 Then_Statements
=> Tstats
));
7856 -- Protected the call against abort
7858 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7861 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7863 -- The result is the new block
7866 Make_Block_Statement
(Loc
,
7867 Declarations
=> Decls
,
7868 Handled_Statement_Sequence
=>
7869 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7872 end Expand_N_Asynchronous_Select
;
7874 -------------------------------------
7875 -- Expand_N_Conditional_Entry_Call --
7876 -------------------------------------
7878 -- The conditional task entry call is converted to a call to
7883 -- P : parms := (parm, parm, parm);
7887 -- (<acceptor-task>, -- Acceptor
7888 -- <entry-index>, -- E
7889 -- P'Address, -- Uninterpreted_Data
7890 -- Conditional_Call, -- Mode
7891 -- B); -- Rendezvous_Successful
7896 -- normal-statements
7902 -- For a description of the use of P and the assignments after the call,
7903 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7904 -- conditional entry call has already been expanded (by the Expand_N_Entry
7905 -- _Call_Statement procedure) as follows:
7908 -- P : parms := (parm, parm, parm);
7910 -- ... info for in-out parameters
7911 -- Call_Simple (acceptor-task, entry-index, P'Address);
7917 -- so the task at hand is to convert the latter expansion into the former
7919 -- The conditional protected entry call is converted to a call to
7920 -- Protected_Entry_Call:
7923 -- P : parms := (parm, parm, parm);
7924 -- Bnn : Communications_Block;
7927 -- Protected_Entry_Call
7928 -- (po._object'Access, -- Object
7929 -- <entry index>, -- E
7930 -- P'Address, -- Uninterpreted_Data
7931 -- Conditional_Call, -- Mode
7936 -- if Cancelled (Bnn) then
7939 -- normal-statements
7943 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7947 -- B : Boolean := False;
7948 -- C : Ada.Tags.Prim_Op_Kind;
7949 -- K : Ada.Tags.Tagged_Kind :=
7950 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7951 -- P : Parameters := (Param1 .. ParamN);
7955 -- if K = Ada.Tags.TK_Limited_Tagged
7956 -- or else K = Ada.Tags.TK_Tagged
7958 -- <dispatching-call>;
7959 -- <triggering-statements>
7963 -- Ada.Tags.Get_Offset_Index
7964 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7966 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7968 -- if C = POK_Protected_Entry
7969 -- or else C = POK_Task_Entry
7971 -- Param1 := P.Param1;
7973 -- ParamN := P.ParamN;
7977 -- if C = POK_Procedure
7978 -- or else C = POK_Protected_Procedure
7979 -- or else C = POK_Task_Procedure
7981 -- <dispatching-call>;
7984 -- <triggering-statements>
7986 -- <else-statements>
7991 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
7992 Loc
: constant Source_Ptr
:= Sloc
(N
);
7993 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
7994 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
7997 Blk_Typ
: Entity_Id
;
7999 Call_Ent
: Entity_Id
;
8000 Conc_Typ_Stmts
: List_Id
;
8004 Lim_Typ_Stmts
: List_Id
;
8011 Transient_Blk
: Node_Id
;
8014 B
: Entity_Id
; -- Call status flag
8015 C
: Entity_Id
; -- Call kind
8016 K
: Entity_Id
; -- Tagged kind
8017 P
: Entity_Id
; -- Parameter block
8018 S
: Entity_Id
; -- Primitive operation slot
8021 Process_Statements_For_Controlled_Objects
(N
);
8023 if Ada_Version
>= Ada_2005
8024 and then Nkind
(Blk
) = N_Procedure_Call_Statement
8026 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
8031 -- Call status flag processing, generate:
8032 -- B : Boolean := False;
8034 B
:= Build_B
(Loc
, Decls
);
8036 -- Call kind processing, generate:
8037 -- C : Ada.Tags.Prim_Op_Kind;
8039 C
:= Build_C
(Loc
, Decls
);
8041 -- Tagged kind processing, generate:
8042 -- K : Ada.Tags.Tagged_Kind :=
8043 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8045 K
:= Build_K
(Loc
, Decls
, Obj
);
8047 -- Parameter block processing
8049 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
8050 P
:= Parameter_Block_Pack
8051 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
8053 -- Dispatch table slot processing, generate:
8056 S
:= Build_S
(Loc
, Decls
);
8059 -- S := Ada.Tags.Get_Offset_Index
8060 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
8063 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
8066 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8068 Append_To
(Conc_Typ_Stmts
,
8069 Make_Procedure_Call_Statement
(Loc
,
8072 Find_Prim_Op
(Etype
(Etype
(Obj
)),
8073 Name_uDisp_Conditional_Select
),
8075 Parameter_Associations
=>
8077 New_Copy_Tree
(Obj
), -- <object>
8078 New_Occurrence_Of
(S
, Loc
), -- S
8079 Make_Attribute_Reference
(Loc
, -- P'Address
8080 Prefix
=> New_Occurrence_Of
(P
, Loc
),
8081 Attribute_Name
=> Name_Address
),
8082 New_Occurrence_Of
(C
, Loc
), -- C
8083 New_Occurrence_Of
(B
, Loc
)))); -- B
8086 -- if C = POK_Protected_Entry
8087 -- or else C = POK_Task_Entry
8089 -- Param1 := P.Param1;
8091 -- ParamN := P.ParamN;
8094 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
8096 -- Generate the if statement only when the packed parameters need
8097 -- explicit assignments to their corresponding actuals.
8099 if Present
(Unpack
) then
8100 Append_To
(Conc_Typ_Stmts
,
8101 Make_Implicit_If_Statement
(N
,
8107 New_Occurrence_Of
(C
, Loc
),
8109 New_Occurrence_Of
(RTE
(
8110 RE_POK_Protected_Entry
), Loc
)),
8115 New_Occurrence_Of
(C
, Loc
),
8117 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
8119 Then_Statements
=> Unpack
));
8124 -- if C = POK_Procedure
8125 -- or else C = POK_Protected_Procedure
8126 -- or else C = POK_Task_Procedure
8128 -- <dispatching-call>
8130 -- <normal-statements>
8132 -- <else-statements>
8135 N_Stats
:= New_Copy_Separate_List
(Statements
(Alt
));
8137 Prepend_To
(N_Stats
,
8138 Make_Implicit_If_Statement
(N
,
8144 New_Occurrence_Of
(C
, Loc
),
8146 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
8153 New_Occurrence_Of
(C
, Loc
),
8155 New_Occurrence_Of
(RTE
(
8156 RE_POK_Protected_Procedure
), Loc
)),
8161 New_Occurrence_Of
(C
, Loc
),
8163 New_Occurrence_Of
(RTE
(
8164 RE_POK_Task_Procedure
), Loc
)))),
8169 Append_To
(Conc_Typ_Stmts
,
8170 Make_Implicit_If_Statement
(N
,
8171 Condition
=> New_Occurrence_Of
(B
, Loc
),
8172 Then_Statements
=> N_Stats
,
8173 Else_Statements
=> Else_Statements
(N
)));
8176 -- <dispatching-call>;
8177 -- <triggering-statements>
8179 Lim_Typ_Stmts
:= New_Copy_Separate_List
(Statements
(Alt
));
8180 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
8183 -- if K = Ada.Tags.TK_Limited_Tagged
8184 -- or else K = Ada.Tags.TK_Tagged
8192 Make_Implicit_If_Statement
(N
,
8193 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
8194 Then_Statements
=> Lim_Typ_Stmts
,
8195 Else_Statements
=> Conc_Typ_Stmts
));
8198 Make_Block_Statement
(Loc
,
8201 Handled_Statement_Sequence
=>
8202 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8204 -- As described above, the entry alternative is transformed into a
8205 -- block that contains the gnulli call, and possibly assignment
8206 -- statements for in-out parameters. The gnulli call may itself be
8207 -- rewritten into a transient block if some unconstrained parameters
8208 -- require it. We need to retrieve the call to complete its parameter
8213 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
8215 if Present
(Transient_Blk
)
8216 and then Nkind
(Transient_Blk
) = N_Block_Statement
8218 Blk
:= Transient_Blk
;
8221 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
8222 Stmt
:= First
(Stmts
);
8223 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
8228 Params
:= Parameter_Associations
(Call
);
8230 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
8232 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8234 Param
:= First
(Params
);
8235 while Present
(Param
)
8236 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
8241 pragma Assert
(Present
(Param
));
8243 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8247 -- Find the Communication_Block parameter for the call to the
8248 -- Cancelled function.
8250 Decl
:= First
(Declarations
(Blk
));
8251 while Present
(Decl
)
8252 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
8253 RE_Communication_Block
)
8258 -- Add an if statement to execute the else part if the call
8259 -- does not succeed (as indicated by the Cancelled predicate).
8262 Make_Implicit_If_Statement
(N
,
8263 Condition
=> Make_Function_Call
(Loc
,
8264 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
8265 Parameter_Associations
=> New_List
(
8266 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))),
8267 Then_Statements
=> Else_Statements
(N
),
8268 Else_Statements
=> Statements
(Alt
)));
8271 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8273 -- Insert declaration of B in declarations of existing block
8275 if No
(Declarations
(Blk
)) then
8276 Set_Declarations
(Blk
, New_List
);
8279 Prepend_To
(Declarations
(Blk
),
8280 Make_Object_Declaration
(Loc
,
8281 Defining_Identifier
=> B
,
8282 Object_Definition
=>
8283 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8285 -- Create new call statement
8288 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8289 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
8292 Make_Procedure_Call_Statement
(Loc
,
8293 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
8294 Parameter_Associations
=> Params
));
8296 -- Construct statement sequence for new block
8299 Make_Implicit_If_Statement
(N
,
8300 Condition
=> New_Occurrence_Of
(B
, Loc
),
8301 Then_Statements
=> Statements
(Alt
),
8302 Else_Statements
=> Else_Statements
(N
)));
8305 -- The result is the new block
8308 Make_Block_Statement
(Loc
,
8309 Declarations
=> Declarations
(Blk
),
8310 Handled_Statement_Sequence
=>
8311 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8316 Reset_Scopes_To
(N
, Entity
(Identifier
(N
)));
8317 end Expand_N_Conditional_Entry_Call
;
8319 ---------------------------------------
8320 -- Expand_N_Delay_Relative_Statement --
8321 ---------------------------------------
8323 -- Delay statement is implemented as a procedure call to Delay_For
8324 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8325 -- simple delays imposed by the use of Protected Objects.
8327 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
8328 Loc
: constant Source_Ptr
:= Sloc
(N
);
8332 -- Try to use Ada.Calendar.Delays.Delay_For if available.
8334 if RTE_Available
(RO_CA_Delay_For
) then
8335 Proc
:= RTE
(RO_CA_Delay_For
);
8337 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error
8338 -- message if not available. This is the implementation used on
8339 -- restricted platforms when Ada.Calendar is not available.
8342 Proc
:= RTE
(RO_RD_Delay_For
);
8346 Make_Procedure_Call_Statement
(Loc
,
8347 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8348 Parameter_Associations
=> New_List
(Expression
(N
))));
8350 end Expand_N_Delay_Relative_Statement
;
8352 ------------------------------------
8353 -- Expand_N_Delay_Until_Statement --
8354 ------------------------------------
8356 -- Delay Until statement is implemented as a procedure call to
8357 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8359 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
8360 Loc
: constant Source_Ptr
:= Sloc
(N
);
8364 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
8365 Typ
:= RTE
(RO_CA_Delay_Until
);
8367 Typ
:= RTE
(RO_RT_Delay_Until
);
8371 Make_Procedure_Call_Statement
(Loc
,
8372 Name
=> New_Occurrence_Of
(Typ
, Loc
),
8373 Parameter_Associations
=> New_List
(Expression
(N
))));
8376 end Expand_N_Delay_Until_Statement
;
8378 -------------------------
8379 -- Expand_N_Entry_Body --
8380 -------------------------
8382 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
8384 -- Associate discriminals with the next protected operation body to be
8387 if Present
(Next_Protected_Operation
(N
)) then
8388 Set_Discriminals
(Parent
(Current_Scope
));
8390 end Expand_N_Entry_Body
;
8392 -----------------------------------
8393 -- Expand_N_Entry_Call_Statement --
8394 -----------------------------------
8396 -- An entry call is expanded into GNARLI calls to implement a simple entry
8397 -- call (see Build_Simple_Entry_Call).
8399 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
8405 if No_Run_Time_Mode
then
8406 Error_Msg_CRT
("entry call", N
);
8410 -- If this entry call is part of an asynchronous select, don't expand it
8411 -- here; it will be expanded with the select statement. Don't expand
8412 -- timed entry calls either, as they are translated into asynchronous
8415 -- ??? This whole approach is questionable; it may be better to go back
8416 -- to allowing the expansion to take place and then attempting to fix it
8417 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8418 -- whether the expanded call is on a task or protected entry.
8420 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
8421 or else N
/= Triggering_Statement
(Parent
(N
)))
8422 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8423 or else N
/= Entry_Call_Statement
(Parent
(N
))
8424 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8426 Extract_Entry
(N
, Concval
, Ename
, Index
);
8427 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8429 end Expand_N_Entry_Call_Statement
;
8431 --------------------------------
8432 -- Expand_N_Entry_Declaration --
8433 --------------------------------
8435 -- If there are parameters, then first, each of the formals is marked by
8436 -- setting Is_Entry_Formal. Next a record type is built which is used to
8437 -- hold the parameter values. The name of this record type is entryP where
8438 -- entry is the name of the entry, with an additional corresponding access
8439 -- type called entryPA. The record type has matching components for each
8440 -- formal (the component names are the same as the formal names). For
8441 -- elementary types, the component type matches the formal type. For
8442 -- composite types, an access type is declared (with the name formalA)
8443 -- which designates the formal type, and the type of the component is this
8444 -- access type. Finally the Entry_Component of each formal is set to
8445 -- reference the corresponding record component.
8447 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8448 Loc
: constant Source_Ptr
:= Sloc
(N
);
8449 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8450 Components
: List_Id
;
8453 Last_Decl
: Node_Id
;
8454 Component
: Entity_Id
;
8457 Rec_Ent
: Entity_Id
;
8458 Acc_Ent
: Entity_Id
;
8461 Formal
:= First_Formal
(Entry_Ent
);
8464 -- Most processing is done only if parameters are present
8466 if Present
(Formal
) then
8467 Components
:= New_List
;
8469 -- Loop through formals
8471 while Present
(Formal
) loop
8472 Set_Is_Entry_Formal
(Formal
);
8474 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8475 Set_Entry_Component
(Formal
, Component
);
8476 Set_Entry_Formal
(Component
, Formal
);
8477 Ftype
:= Etype
(Formal
);
8479 -- Declare new access type and then append
8481 Ctype
:= Make_Temporary
(Loc
, 'A');
8482 Set_Is_Param_Block_Component_Type
(Ctype
);
8485 Make_Full_Type_Declaration
(Loc
,
8486 Defining_Identifier
=> Ctype
,
8488 Make_Access_To_Object_Definition
(Loc
,
8489 All_Present
=> True,
8490 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8491 Subtype_Indication
=> New_Occurrence_Of
(Ftype
, Loc
)));
8493 Insert_After
(Last_Decl
, Decl
);
8496 Append_To
(Components
,
8497 Make_Component_Declaration
(Loc
,
8498 Defining_Identifier
=> Component
,
8499 Component_Definition
=>
8500 Make_Component_Definition
(Loc
,
8501 Aliased_Present
=> False,
8502 Subtype_Indication
=> New_Occurrence_Of
(Ctype
, Loc
))));
8504 Next_Formal_With_Extras
(Formal
);
8507 -- Create the Entry_Parameter_Record declaration
8509 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8512 Make_Full_Type_Declaration
(Loc
,
8513 Defining_Identifier
=> Rec_Ent
,
8515 Make_Record_Definition
(Loc
,
8517 Make_Component_List
(Loc
,
8518 Component_Items
=> Components
)));
8520 Insert_After
(Last_Decl
, Decl
);
8523 -- Construct and link in the corresponding access type
8525 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8527 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8530 Make_Full_Type_Declaration
(Loc
,
8531 Defining_Identifier
=> Acc_Ent
,
8533 Make_Access_To_Object_Definition
(Loc
,
8534 All_Present
=> True,
8535 Subtype_Indication
=> New_Occurrence_Of
(Rec_Ent
, Loc
)));
8537 Insert_After
(Last_Decl
, Decl
);
8539 end Expand_N_Entry_Declaration
;
8541 -----------------------------
8542 -- Expand_N_Protected_Body --
8543 -----------------------------
8545 -- Protected bodies are expanded to the completion of the subprograms
8546 -- created for the corresponding protected type. These are a protected and
8547 -- unprotected version of each protected subprogram in the object, a
8548 -- function to calculate each entry barrier, and a procedure to execute the
8549 -- sequence of statements of each protected entry body. For example, for
8550 -- protected type ptype:
8553 -- (O : System.Address;
8554 -- E : Protected_Entry_Index)
8557 -- <discriminant renamings>
8558 -- <private object renamings>
8560 -- return <barrier expression>;
8563 -- procedure pprocN (_object : in out poV;...) is
8564 -- <discriminant renamings>
8565 -- <private object renamings>
8567 -- <sequence of statements>
8570 -- procedure pprocP (_object : in out poV;...) is
8571 -- procedure _clean is
8574 -- ptypeS (_object, Pn);
8575 -- Unlock (_object._object'Access);
8576 -- Abort_Undefer.all;
8581 -- Lock (_object._object'Access);
8582 -- pprocN (_object;...);
8587 -- function pfuncN (_object : poV;...) return Return_Type is
8588 -- <discriminant renamings>
8589 -- <private object renamings>
8591 -- <sequence of statements>
8594 -- function pfuncP (_object : poV) return Return_Type is
8595 -- procedure _clean is
8597 -- Unlock (_object._object'Access);
8598 -- Abort_Undefer.all;
8603 -- Lock (_object._object'Access);
8604 -- return pfuncN (_object);
8611 -- (O : System.Address;
8612 -- P : System.Address;
8613 -- E : Protected_Entry_Index)
8615 -- <discriminant renamings>
8616 -- <private object renamings>
8617 -- type poVP is access poV;
8618 -- _Object : ptVP := ptVP!(O);
8622 -- <statement sequence>
8623 -- Complete_Entry_Body (_Object._Object);
8625 -- when all others =>
8626 -- Exceptional_Complete_Entry_Body (
8627 -- _Object._Object, Get_GNAT_Exception);
8631 -- The type poV is the record created for the protected type to hold
8632 -- the state of the protected object.
8634 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8635 Loc
: constant Source_Ptr
:= Sloc
(N
);
8636 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8638 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8639 -- This flag indicates whether the lock free implementation is active
8641 Current_Node
: Node_Id
;
8642 Disp_Op_Body
: Node_Id
;
8643 New_Op_Body
: Node_Id
;
8648 function Build_Dispatching_Subprogram_Body
8651 Prot_Bod
: Node_Id
) return Node_Id
;
8652 -- Build a dispatching version of the protected subprogram body. The
8653 -- newly generated subprogram contains a call to the original protected
8654 -- body. The following code is generated:
8656 -- function <protected-function-name> (Param1 .. ParamN) return
8659 -- return <protected-function-name>P (Param1 .. ParamN);
8660 -- end <protected-function-name>;
8664 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8666 -- <protected-procedure-name>P (Param1 .. ParamN);
8667 -- end <protected-procedure-name>
8669 ---------------------------------------
8670 -- Build_Dispatching_Subprogram_Body --
8671 ---------------------------------------
8673 function Build_Dispatching_Subprogram_Body
8676 Prot_Bod
: Node_Id
) return Node_Id
8678 Loc
: constant Source_Ptr
:= Sloc
(N
);
8685 -- Generate a specification without a letter suffix in order to
8686 -- override an interface function or procedure.
8688 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8690 -- The formal parameters become the actuals of the protected function
8691 -- or procedure call.
8693 Actuals
:= New_List
;
8694 Formal
:= First
(Parameter_Specifications
(Spec
));
8695 while Present
(Formal
) loop
8697 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8701 if Nkind
(Spec
) = N_Procedure_Specification
then
8704 Make_Procedure_Call_Statement
(Loc
,
8706 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8707 Parameter_Associations
=> Actuals
));
8710 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8714 Make_Simple_Return_Statement
(Loc
,
8716 Make_Function_Call
(Loc
,
8718 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8719 Parameter_Associations
=> Actuals
)));
8723 Make_Subprogram_Body
(Loc
,
8724 Declarations
=> Empty_List
,
8725 Specification
=> Spec
,
8726 Handled_Statement_Sequence
=>
8727 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8728 end Build_Dispatching_Subprogram_Body
;
8730 -- Start of processing for Expand_N_Protected_Body
8733 if No_Run_Time_Mode
then
8734 Error_Msg_CRT
("protected body", N
);
8738 -- This is the proper body corresponding to a stub. The declarations
8739 -- must be inserted at the point of the stub, which in turn is in the
8740 -- declarative part of the parent unit.
8742 if Nkind
(Parent
(N
)) = N_Subunit
then
8743 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8748 Op_Body
:= First
(Declarations
(N
));
8750 -- The protected body is replaced with the bodies of its protected
8751 -- operations, and the declarations for internal objects that may
8752 -- have been created for entry family bounds.
8754 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8757 while Present
(Op_Body
) loop
8758 case Nkind
(Op_Body
) is
8759 when N_Subprogram_Declaration
=>
8762 when N_Subprogram_Body
=>
8764 -- Do not create bodies for eliminated operations
8766 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8767 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8769 if Lock_Free_Active
then
8771 Build_Lock_Free_Unprotected_Subprogram_Body
8775 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8778 Insert_After
(Current_Node
, New_Op_Body
);
8779 Current_Node
:= New_Op_Body
;
8780 Analyze
(New_Op_Body
);
8782 -- When the original protected body has nested subprograms,
8783 -- the new body also has them, so set the flag accordingly
8784 -- and reset the scopes of the top-level nested subprograms
8785 -- and other declaration entities so that they now refer to
8786 -- the new body's entity. (It would preferable to do this
8787 -- within Build_Protected_Sub_Specification, which is called
8788 -- from Build_Unprotected_Subprogram_Body, but the needed
8789 -- subprogram entity isn't available via Corresponding_Spec
8790 -- until after the above Analyze call.)
8792 if Has_Nested_Subprogram
(Corresponding_Spec
(Op_Body
)) then
8793 Set_Has_Nested_Subprogram
8794 (Corresponding_Spec
(New_Op_Body
));
8797 (New_Op_Body
, Corresponding_Spec
(New_Op_Body
));
8800 -- Build the corresponding protected operation. This is
8801 -- needed only if this is a public or private operation of
8804 -- Why do we need to test for Corresponding_Spec being
8805 -- present here when it's assumed to be set further above
8806 -- in the Is_Eliminated test???
8808 if Present
(Corresponding_Spec
(Op_Body
)) then
8810 Unit_Declaration_Node
(Corresponding_Spec
(Op_Body
));
8812 if Nkind
(Parent
(Op_Decl
)) = N_Protected_Definition
then
8813 if Lock_Free_Active
then
8815 Build_Lock_Free_Protected_Subprogram_Body
8816 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8819 Build_Protected_Subprogram_Body
(
8820 Op_Body
, Pid
, Specification
(New_Op_Body
));
8823 Insert_After
(Current_Node
, New_Op_Body
);
8824 Analyze
(New_Op_Body
);
8825 Current_Node
:= New_Op_Body
;
8827 -- Generate an overriding primitive operation body for
8828 -- this subprogram if the protected type implements
8831 if Ada_Version
>= Ada_2005
8832 and then Present
(Interfaces
(
8833 Corresponding_Record_Type
(Pid
)))
8836 Build_Dispatching_Subprogram_Body
(
8837 Op_Body
, Pid
, New_Op_Body
);
8839 Insert_After
(Current_Node
, Disp_Op_Body
);
8840 Analyze
(Disp_Op_Body
);
8842 Current_Node
:= Disp_Op_Body
;
8848 when N_Entry_Body
=>
8849 Op_Id
:= Defining_Identifier
(Op_Body
);
8850 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8852 Insert_After
(Current_Node
, New_Op_Body
);
8853 Current_Node
:= New_Op_Body
;
8854 Analyze
(New_Op_Body
);
8856 when N_Implicit_Label_Declaration
=>
8862 New_Op_Body
:= New_Copy
(Op_Body
);
8863 Insert_After
(Current_Node
, New_Op_Body
);
8864 Current_Node
:= New_Op_Body
;
8866 when N_Freeze_Entity
=>
8867 New_Op_Body
:= New_Copy
(Op_Body
);
8869 if Present
(Entity
(Op_Body
))
8870 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8872 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8875 Insert_After
(Current_Node
, New_Op_Body
);
8876 Current_Node
:= New_Op_Body
;
8877 Analyze
(New_Op_Body
);
8880 New_Op_Body
:= New_Copy
(Op_Body
);
8881 Insert_After
(Current_Node
, New_Op_Body
);
8882 Current_Node
:= New_Op_Body
;
8883 Analyze
(New_Op_Body
);
8885 when N_Object_Declaration
=>
8886 pragma Assert
(not Comes_From_Source
(Op_Body
));
8887 New_Op_Body
:= New_Copy
(Op_Body
);
8888 Insert_After
(Current_Node
, New_Op_Body
);
8889 Current_Node
:= New_Op_Body
;
8890 Analyze
(New_Op_Body
);
8893 raise Program_Error
;
8899 -- Finally, create the body of the function that maps an entry index
8900 -- into the corresponding body index, except when there is no entry, or
8901 -- in a Ravenscar-like profile.
8903 if Corresponding_Runtime_Package
(Pid
) =
8904 System_Tasking_Protected_Objects_Entries
8906 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8907 Insert_After
(Current_Node
, New_Op_Body
);
8908 Current_Node
:= New_Op_Body
;
8909 Analyze
(New_Op_Body
);
8912 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8913 -- protected body. At this point all wrapper specs have been created,
8914 -- frozen and included in the dispatch table for the protected type.
8916 if Ada_Version
>= Ada_2005
then
8917 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8919 end Expand_N_Protected_Body
;
8921 -----------------------------------------
8922 -- Expand_N_Protected_Type_Declaration --
8923 -----------------------------------------
8925 -- First we create a corresponding record type declaration used to
8926 -- represent values of this protected type.
8927 -- The general form of this type declaration is
8929 -- type poV (discriminants) is record
8930 -- _Object : aliased <kind>Protection
8931 -- [(<entry count> [, <handler count>])];
8932 -- [entry_family : array (bounds) of Void;]
8933 -- <private data fields>
8936 -- The discriminants are present only if the corresponding protected type
8937 -- has discriminants, and they exactly mirror the protected type
8938 -- discriminants. The private data fields similarly mirror the private
8939 -- declarations of the protected type.
8941 -- The Object field is always present. It contains RTS specific data used
8942 -- to control the protected object. It is declared as Aliased so that it
8943 -- can be passed as a pointer to the RTS. This allows the protected record
8944 -- to be referenced within RTS data structures. An appropriate Protection
8945 -- type and discriminant are generated.
8947 -- The Service field is present for protected objects with entries. It
8948 -- contains sufficient information to allow the entry service procedure for
8949 -- this object to be called when the object is not known till runtime.
8951 -- One entry_family component is present for each entry family in the
8952 -- task definition (see Expand_N_Task_Type_Declaration).
8954 -- When a protected object is declared, an instance of the protected type
8955 -- value record is created. The elaboration of this declaration creates the
8956 -- correct bounds for the entry families, and also evaluates the priority
8957 -- expression if needed. The initialization routine for the protected type
8958 -- itself then calls Initialize_Protection with appropriate parameters to
8959 -- initialize the value of the Task_Id field. Install_Handlers may be also
8960 -- called if a pragma Attach_Handler applies.
8962 -- Note: this record is passed to the subprograms created by the expansion
8963 -- of protected subprograms and entries. It is an in parameter to protected
8964 -- functions and an in out parameter to procedures and entry bodies. The
8965 -- Entity_Id for this created record type is placed in the
8966 -- Corresponding_Record_Type field of the associated protected type entity.
8968 -- Next we create a procedure specifications for protected subprograms and
8969 -- entry bodies. For each protected subprograms two subprograms are
8970 -- created, an unprotected and a protected version. The unprotected version
8971 -- is called from within other operations of the same protected object.
8973 -- We also build the call to register the procedure if a pragma
8974 -- Interrupt_Handler applies.
8976 -- A single subprogram is created to service all entry bodies; it has an
8977 -- additional boolean out parameter indicating that the previous entry call
8978 -- made by the current task was serviced immediately, i.e. not by proxy.
8979 -- The O parameter contains a pointer to a record object of the type
8980 -- described above. An untyped interface is used here to allow this
8981 -- procedure to be called in places where the type of the object to be
8982 -- serviced is not known. This must be done, for example, when a call that
8983 -- may have been requeued is cancelled; the corresponding object must be
8984 -- serviced, but which object that is not known till runtime.
8987 -- (O : System.Address; P : out Boolean);
8988 -- procedure pprocN (_object : in out poV);
8989 -- procedure pproc (_object : in out poV);
8990 -- function pfuncN (_object : poV);
8991 -- function pfunc (_object : poV);
8994 -- Note that this must come after the record type declaration, since
8995 -- the specs refer to this type.
8997 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
8998 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
8999 Loc
: constant Source_Ptr
:= Sloc
(N
);
9000 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
9002 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
9003 -- This flag indicates whether the lock free implementation is active
9005 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
9006 -- This contains two lists; one for visible and one for private decls
9008 Current_Node
: Node_Id
:= N
;
9010 Entries_Aggr
: Node_Id
;
9014 procedure Check_Inlining
(Subp
: Entity_Id
);
9015 -- If the original operation has a pragma Inline, propagate the flag
9016 -- to the internal body, for possible inlining later on. The source
9017 -- operation is invisible to the back-end and is never actually called.
9019 procedure Expand_Entry_Declaration
(Decl
: Node_Id
);
9020 -- Create the entry barrier and the procedure body for entry declaration
9021 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
9023 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
9024 -- When compiling under the Ravenscar profile, private components must
9025 -- have a static size, or else a protected object will require heap
9026 -- allocation, violating the corresponding restriction. It is preferable
9027 -- to make this check here, because it provides a better error message
9028 -- than the back-end, which refers to the object as a whole.
9030 procedure Register_Handler
;
9031 -- For a protected operation that is an interrupt handler, add the
9032 -- freeze action that will register it as such.
9034 procedure Replace_Access_Definition
(Comp
: Node_Id
);
9035 -- If a private component of the type is an access to itself, this
9036 -- is not a reference to the current instance, but an access type out
9037 -- of which one might construct a list. If such a component exists, we
9038 -- create an incomplete type for the equivalent record type, and
9039 -- a named access type for it, that replaces the access definition
9040 -- of the original component. This is similar to what is done for
9041 -- records in Check_Anonymous_Access_Components, but simpler, because
9042 -- the corresponding record type has no previous declaration.
9043 -- This needs to be done only once, even if there are several such
9044 -- access components. The following entity stores the constructed
9047 Acc_T
: Entity_Id
:= Empty
;
9049 --------------------
9050 -- Check_Inlining --
9051 --------------------
9053 procedure Check_Inlining
(Subp
: Entity_Id
) is
9055 if Is_Inlined
(Subp
) then
9056 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
9057 Set_Is_Inlined
(Subp
, False);
9060 if Has_Pragma_No_Inline
(Subp
) then
9061 Set_Has_Pragma_No_Inline
(Protected_Body_Subprogram
(Subp
));
9065 ---------------------------
9066 -- Static_Component_Size --
9067 ---------------------------
9069 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
9070 Typ
: constant Entity_Id
:= Etype
(Comp
);
9074 if Is_Scalar_Type
(Typ
) then
9077 elsif Is_Array_Type
(Typ
) then
9078 return Compile_Time_Known_Bounds
(Typ
);
9080 elsif Is_Record_Type
(Typ
) then
9081 C
:= First_Component
(Typ
);
9082 while Present
(C
) loop
9083 if not Static_Component_Size
(C
) then
9092 -- Any other type will be checked by the back-end
9097 end Static_Component_Size
;
9099 ------------------------------
9100 -- Expand_Entry_Declaration --
9101 ------------------------------
9103 procedure Expand_Entry_Declaration
(Decl
: Node_Id
) is
9104 Ent_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
9110 E_Count
:= E_Count
+ 1;
9112 -- Create the protected body subprogram
9115 Make_Defining_Identifier
(Loc
,
9116 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'E'));
9117 Set_Protected_Body_Subprogram
(Ent_Id
, Bod_Id
);
9120 Make_Subprogram_Declaration
(Loc
,
9122 Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Ent_Id
));
9124 Insert_After
(Current_Node
, Subp
);
9125 Current_Node
:= Subp
;
9129 -- Build a wrapper procedure to handle contract cases, preconditions,
9130 -- and postconditions.
9132 Build_Contract_Wrapper
(Ent_Id
, N
);
9134 -- Create the barrier function
9137 Make_Defining_Identifier
(Loc
,
9138 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'B'));
9139 Set_Barrier_Function
(Ent_Id
, Bar_Id
);
9142 Make_Subprogram_Declaration
(Loc
,
9144 Build_Barrier_Function_Specification
(Loc
, Bar_Id
));
9145 Set_Is_Entry_Barrier_Function
(Subp
);
9147 Insert_After
(Current_Node
, Subp
);
9148 Current_Node
:= Subp
;
9152 Set_Protected_Body_Subprogram
(Bar_Id
, Bar_Id
);
9153 Set_Scope
(Bar_Id
, Scope
(Ent_Id
));
9155 -- Collect pointers to the protected subprogram and the barrier
9156 -- of the current entry, for insertion into Entry_Bodies_Array.
9158 Append_To
(Expressions
(Entries_Aggr
),
9159 Make_Aggregate
(Loc
,
9160 Expressions
=> New_List
(
9161 Make_Attribute_Reference
(Loc
,
9162 Prefix
=> New_Occurrence_Of
(Bar_Id
, Loc
),
9163 Attribute_Name
=> Name_Unrestricted_Access
),
9164 Make_Attribute_Reference
(Loc
,
9165 Prefix
=> New_Occurrence_Of
(Bod_Id
, Loc
),
9166 Attribute_Name
=> Name_Unrestricted_Access
))));
9167 end Expand_Entry_Declaration
;
9169 ----------------------
9170 -- Register_Handler --
9171 ----------------------
9173 procedure Register_Handler
is
9175 -- All semantic checks already done in Sem_Prag
9177 Prot_Proc
: constant Entity_Id
:=
9178 Defining_Unit_Name
(Specification
(Current_Node
));
9180 Proc_Address
: constant Node_Id
:=
9181 Make_Attribute_Reference
(Loc
,
9183 New_Occurrence_Of
(Prot_Proc
, Loc
),
9184 Attribute_Name
=> Name_Address
);
9186 RTS_Call
: constant Entity_Id
:=
9187 Make_Procedure_Call_Statement
(Loc
,
9190 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
9191 Parameter_Associations
=> New_List
(Proc_Address
));
9193 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
9194 end Register_Handler
;
9196 -------------------------------
9197 -- Replace_Access_Definition --
9198 -------------------------------
9200 procedure Replace_Access_Definition
(Comp
: Node_Id
) is
9201 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
9209 Inc_T
:= Make_Defining_Identifier
(Loc
, Chars
(Rec_Id
));
9210 Inc_D
:= Make_Incomplete_Type_Declaration
(Loc
, Inc_T
);
9211 Acc_T
:= Make_Temporary
(Loc
, 'S');
9213 Make_Access_To_Object_Definition
(Loc
,
9214 Subtype_Indication
=> New_Occurrence_Of
(Inc_T
, Loc
));
9216 Make_Full_Type_Declaration
(Loc
,
9217 Defining_Identifier
=> Acc_T
,
9218 Type_Definition
=> Acc_Def
);
9220 Insert_Before
(Rec_Decl
, Inc_D
);
9223 Insert_Before
(Rec_Decl
, Acc_D
);
9227 Set_Access_Definition
(Comp
, Empty
);
9228 Set_Subtype_Indication
(Comp
, New_Occurrence_Of
(Acc_T
, Loc
));
9229 end Replace_Access_Definition
;
9234 Body_Id
: Entity_Id
;
9240 Object_Comp
: Node_Id
;
9244 -- Start of processing for Expand_N_Protected_Type_Declaration
9247 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
9250 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
9251 Rec_Id
:= Defining_Identifier
(Rec_Decl
);
9254 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
9256 Qualify_Entity_Names
(N
);
9258 -- If the type has discriminants, their occurrences in the declaration
9259 -- have been replaced by the corresponding discriminals. For components
9260 -- that are constrained by discriminants, their homologues in the
9261 -- corresponding record type must refer to the discriminants of that
9262 -- record, so we must apply a new renaming to subtypes_indications:
9264 -- protected discriminant => discriminal => record discriminant
9266 -- This replacement is not applied to default expressions, for which
9267 -- the discriminal is correct.
9269 if Has_Discriminants
(Prot_Typ
) then
9275 Disc
:= First_Discriminant
(Prot_Typ
);
9276 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
9277 while Present
(Disc
) loop
9278 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
9279 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
9280 Next_Discriminant
(Disc
);
9286 -- Fill in the component declarations
9288 -- Add components for entry families. For each entry family, create an
9289 -- anonymous type declaration with the same size, and analyze the type.
9291 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
9293 pragma Assert
(Present
(Pdef
));
9295 Insert_After
(Current_Node
, Rec_Decl
);
9296 Current_Node
:= Rec_Decl
;
9298 -- Add private field components
9300 if Present
(Private_Declarations
(Pdef
)) then
9301 Priv
:= First
(Private_Declarations
(Pdef
));
9302 while Present
(Priv
) loop
9303 if Nkind
(Priv
) = N_Component_Declaration
then
9304 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
9306 -- When compiling for a restricted profile, the private
9307 -- components must have a static size. If not, this is an
9308 -- error for a single protected declaration, and rates a
9309 -- warning on a protected type declaration.
9311 if not Comes_From_Source
(Prot_Typ
) then
9313 -- It's ok to be checking this restriction at expansion
9314 -- time, because this is only for the restricted profile,
9315 -- which is not subject to strict RM conformance, so it
9316 -- is OK to miss this check in -gnatc mode.
9318 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
9320 (No_Implicit_Protected_Object_Allocations
, Priv
);
9322 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
9323 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9325 -- Any object of the type will be non-static
9327 Error_Msg_N
("component has non-static size??", Priv
);
9329 ("\creation of protected object of type& will "
9330 & "violate restriction "
9331 & "No_Implicit_Heap_Allocations??", Priv
, Prot_Typ
);
9333 -- Object will be non-static if discriminants are
9336 ("creation of protected object of type& with "
9337 & "non-static discriminants will violate "
9338 & "restriction No_Implicit_Heap_Allocations??",
9342 -- Likewise for No_Implicit_Protected_Object_Allocations
9344 elsif Restriction_Active
9345 (No_Implicit_Protected_Object_Allocations
)
9347 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9349 -- Any object of the type will be non-static
9351 Error_Msg_N
("component has non-static size??", Priv
);
9353 ("\creation of protected object of type& will "
9354 & "violate restriction "
9355 & "No_Implicit_Protected_Object_Allocations??",
9358 -- Object will be non-static if discriminants are
9361 ("creation of protected object of type& with "
9362 & "non-static discriminants will violate "
9364 & "No_Implicit_Protected_Object_Allocations??",
9370 -- The component definition consists of a subtype indication,
9371 -- or (in Ada 2005) an access definition. Make a copy of the
9372 -- proper definition.
9375 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
9376 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
9377 Nent
: constant Entity_Id
:=
9378 Make_Defining_Identifier
(Sloc
(Oent
),
9379 Chars
=> Chars
(Oent
));
9383 if Present
(Subtype_Indication
(Old_Comp
)) then
9385 Make_Component_Definition
(Sloc
(Oent
),
9386 Aliased_Present
=> False,
9387 Subtype_Indication
=>
9389 (Subtype_Indication
(Old_Comp
), Discr_Map
));
9392 Make_Component_Definition
(Sloc
(Oent
),
9393 Aliased_Present
=> False,
9394 Access_Definition
=>
9396 (Access_Definition
(Old_Comp
), Discr_Map
));
9398 -- A self-reference in the private part becomes a
9399 -- self-reference to the corresponding record.
9401 if Entity
(Subtype_Mark
(Access_Definition
(New_Comp
)))
9404 Replace_Access_Definition
(New_Comp
);
9409 Make_Component_Declaration
(Loc
,
9410 Defining_Identifier
=> Nent
,
9411 Component_Definition
=> New_Comp
,
9412 Expression
=> Expression
(Priv
));
9414 Set_Has_Per_Object_Constraint
(Nent
,
9415 Has_Per_Object_Constraint
(Oent
));
9417 Append_To
(Cdecls
, New_Priv
);
9420 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
9422 -- Make the unprotected version of the subprogram available
9423 -- for expansion of intra object calls. There is need for
9424 -- a protected version only if the subprogram is an interrupt
9425 -- handler, otherwise this operation can only be called from
9429 Make_Subprogram_Declaration
(Loc
,
9431 Build_Protected_Sub_Specification
9432 (Priv
, Prot_Typ
, Unprotected_Mode
));
9434 Insert_After
(Current_Node
, Sub
);
9437 Set_Protected_Body_Subprogram
9438 (Defining_Unit_Name
(Specification
(Priv
)),
9439 Defining_Unit_Name
(Specification
(Sub
)));
9440 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
9441 Current_Node
:= Sub
;
9444 Make_Subprogram_Declaration
(Loc
,
9446 Build_Protected_Sub_Specification
9447 (Priv
, Prot_Typ
, Protected_Mode
));
9449 Insert_After
(Current_Node
, Sub
);
9451 Current_Node
:= Sub
;
9453 if Is_Interrupt_Handler
9454 (Defining_Unit_Name
(Specification
(Priv
)))
9456 if not Restricted_Profile
then
9466 -- Except for the lock-free implementation, append the _Object field
9467 -- with the right type to the component list. We need to compute the
9468 -- number of entries, and in some cases the number of Attach_Handler
9471 if not Lock_Free_Active
then
9473 Entry_Count_Expr
: constant Node_Id
:=
9474 Build_Entry_Count_Expression
9475 (Prot_Typ
, Cdecls
, Loc
);
9476 Num_Attach_Handler
: Nat
:= 0;
9477 Protection_Subtype
: Node_Id
;
9481 if Has_Attach_Handler
(Prot_Typ
) then
9482 Ritem
:= First_Rep_Item
(Prot_Typ
);
9483 while Present
(Ritem
) loop
9484 if Nkind
(Ritem
) = N_Pragma
9485 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
9487 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
9490 Next_Rep_Item
(Ritem
);
9494 -- Determine the proper protection type. There are two special
9495 -- cases: 1) when the protected type has dynamic interrupt
9496 -- handlers, and 2) when it has static handlers and we use a
9497 -- restricted profile.
9499 if Has_Attach_Handler
(Prot_Typ
)
9500 and then not Restricted_Profile
9502 Protection_Subtype
:=
9503 Make_Subtype_Indication
(Loc
,
9506 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
9508 Make_Index_Or_Discriminant_Constraint
(Loc
,
9509 Constraints
=> New_List
(
9511 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
9513 elsif Has_Interrupt_Handler
(Prot_Typ
)
9514 and then not Restriction_Active
(No_Dynamic_Attachment
)
9516 Protection_Subtype
:=
9517 Make_Subtype_Indication
(Loc
,
9520 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
9522 Make_Index_Or_Discriminant_Constraint
(Loc
,
9523 Constraints
=> New_List
(Entry_Count_Expr
)));
9526 case Corresponding_Runtime_Package
(Prot_Typ
) is
9527 when System_Tasking_Protected_Objects_Entries
=>
9528 Protection_Subtype
:=
9529 Make_Subtype_Indication
(Loc
,
9532 (RTE
(RE_Protection_Entries
), Loc
),
9534 Make_Index_Or_Discriminant_Constraint
(Loc
,
9535 Constraints
=> New_List
(Entry_Count_Expr
)));
9537 when System_Tasking_Protected_Objects_Single_Entry
=>
9538 Protection_Subtype
:=
9539 New_Occurrence_Of
(RTE
(RE_Protection_Entry
), Loc
);
9541 when System_Tasking_Protected_Objects
=>
9542 Protection_Subtype
:=
9543 New_Occurrence_Of
(RTE
(RE_Protection
), Loc
);
9546 raise Program_Error
;
9551 Make_Component_Declaration
(Loc
,
9552 Defining_Identifier
=>
9553 Make_Defining_Identifier
(Loc
, Name_uObject
),
9554 Component_Definition
=>
9555 Make_Component_Definition
(Loc
,
9556 Aliased_Present
=> True,
9557 Subtype_Indication
=> Protection_Subtype
));
9560 -- Put the _Object component after the private component so that it
9561 -- be finalized early as required by 9.4 (20)
9563 Append_To
(Cdecls
, Object_Comp
);
9566 -- Analyze the record declaration immediately after construction,
9567 -- because the initialization procedure is needed for single object
9568 -- declarations before the next entity is analyzed (the freeze call
9569 -- that generates this initialization procedure is found below).
9571 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
9573 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9574 -- the corresponding record is frozen. If any wrappers are generated,
9575 -- Current_Node is updated accordingly.
9577 if Ada_Version
>= Ada_2005
then
9578 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
9581 -- Collect pointers to entry bodies and their barriers, to be placed
9582 -- in the Entry_Bodies_Array for the type. For each entry/family we
9583 -- add an expression to the aggregate which is the initial value of
9584 -- this array. The array is declared after all protected subprograms.
9586 if Has_Entries
(Prot_Typ
) then
9587 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
9589 Entries_Aggr
:= Empty
;
9592 -- Build two new procedure specifications for each protected subprogram;
9593 -- one to call from outside the object and one to call from inside.
9594 -- Build a barrier function and an entry body action procedure
9595 -- specification for each protected entry. Initialize the entry body
9596 -- array. If subprogram is flagged as eliminated, do not generate any
9597 -- internal operations.
9600 Comp
:= First
(Visible_Declarations
(Pdef
));
9601 while Present
(Comp
) loop
9602 if Nkind
(Comp
) = N_Subprogram_Declaration
then
9604 Make_Subprogram_Declaration
(Loc
,
9606 Build_Protected_Sub_Specification
9607 (Comp
, Prot_Typ
, Unprotected_Mode
));
9609 Insert_After
(Current_Node
, Sub
);
9612 Set_Protected_Body_Subprogram
9613 (Defining_Unit_Name
(Specification
(Comp
)),
9614 Defining_Unit_Name
(Specification
(Sub
)));
9615 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
9617 -- Make the protected version of the subprogram available for
9618 -- expansion of external calls.
9620 Current_Node
:= Sub
;
9623 Make_Subprogram_Declaration
(Loc
,
9625 Build_Protected_Sub_Specification
9626 (Comp
, Prot_Typ
, Protected_Mode
));
9628 Insert_After
(Current_Node
, Sub
);
9631 Current_Node
:= Sub
;
9633 -- Generate an overriding primitive operation specification for
9634 -- this subprogram if the protected type implements an interface
9635 -- and Build_Wrapper_Spec did not generate its wrapper.
9637 if Ada_Version
>= Ada_2005
9639 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9642 Found
: Boolean := False;
9643 Prim_Elmt
: Elmt_Id
;
9649 (Primitive_Operations
9650 (Corresponding_Record_Type
(Prot_Typ
)));
9652 while Present
(Prim_Elmt
) loop
9653 Prim_Op
:= Node
(Prim_Elmt
);
9655 if Is_Primitive_Wrapper
(Prim_Op
)
9656 and then Wrapped_Entity
(Prim_Op
) =
9657 Defining_Entity
(Specification
(Comp
))
9663 Next_Elmt
(Prim_Elmt
);
9668 Make_Subprogram_Declaration
(Loc
,
9670 Build_Protected_Sub_Specification
9671 (Comp
, Prot_Typ
, Dispatching_Mode
));
9673 Insert_After
(Current_Node
, Sub
);
9676 Current_Node
:= Sub
;
9681 -- If a pragma Interrupt_Handler applies, build and add a call to
9682 -- Register_Interrupt_Handler to the freezing actions of the
9683 -- protected version (Current_Node) of the subprogram:
9685 -- system.interrupts.register_interrupt_handler
9686 -- (prot_procP'address);
9688 if not Restricted_Profile
9689 and then Is_Interrupt_Handler
9690 (Defining_Unit_Name
(Specification
(Comp
)))
9695 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9696 Expand_Entry_Declaration
(Comp
);
9702 -- If there are some private entry declarations, expand it as if they
9703 -- were visible entries.
9705 if Present
(Private_Declarations
(Pdef
)) then
9706 Comp
:= First
(Private_Declarations
(Pdef
));
9707 while Present
(Comp
) loop
9708 if Nkind
(Comp
) = N_Entry_Declaration
then
9709 Expand_Entry_Declaration
(Comp
);
9716 -- Create the declaration of an array object which contains the values
9717 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9718 -- type. This object is later passed to the appropriate protected object
9719 -- initialization routine.
9721 if Has_Entries
(Prot_Typ
)
9722 and then Corresponding_Runtime_Package
(Prot_Typ
) =
9723 System_Tasking_Protected_Objects_Entries
9730 Maxes_Id
: Entity_Id
;
9731 Need_Array
: Boolean := False;
9734 -- First check if there is any Max_Queue_Length pragma
9736 Item
:= First_Entity
(Prot_Typ
);
9737 while Present
(Item
) loop
9738 if Is_Entry
(Item
) and then Has_Max_Queue_Length
(Item
) then
9746 -- Gather the Max_Queue_Length values of all entries in a list. A
9747 -- value of zero indicates that the entry has no limitation on its
9752 Item
:= First_Entity
(Prot_Typ
);
9754 while Present
(Item
) loop
9755 if Is_Entry
(Item
) then
9758 Make_Integer_Literal
9759 (Loc
, Get_Max_Queue_Length
(Item
)));
9765 -- Create the declaration of the array object. Generate:
9767 -- Maxes_Id : aliased constant
9768 -- Protected_Entry_Queue_Max_Array
9769 -- (1 .. Count) := (..., ...);
9772 Make_Defining_Identifier
(Loc
,
9773 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'B'));
9776 Make_Object_Declaration
(Loc
,
9777 Defining_Identifier
=> Maxes_Id
,
9778 Aliased_Present
=> True,
9779 Constant_Present
=> True,
9780 Object_Definition
=>
9781 Make_Subtype_Indication
(Loc
,
9784 (RTE
(RE_Protected_Entry_Queue_Max_Array
), Loc
),
9786 Make_Index_Or_Discriminant_Constraint
(Loc
,
9787 Constraints
=> New_List
(
9789 Make_Integer_Literal
(Loc
, 1),
9790 Make_Integer_Literal
(Loc
, Count
))))),
9791 Expression
=> Make_Aggregate
(Loc
, Maxes
));
9793 -- A pointer to this array will be placed in the corresponding
9794 -- record by its initialization procedure so this needs to be
9797 Insert_After
(Current_Node
, Max_Vals
);
9798 Current_Node
:= Max_Vals
;
9801 Set_Entry_Max_Queue_Lengths_Array
(Prot_Typ
, Maxes_Id
);
9806 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9807 -- all protected subprograms have been collected.
9809 if Has_Entries
(Prot_Typ
) then
9811 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9812 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9814 case Corresponding_Runtime_Package
(Prot_Typ
) is
9815 when System_Tasking_Protected_Objects_Entries
=>
9816 Expr
:= Entries_Aggr
;
9818 Make_Subtype_Indication
(Loc
,
9821 (RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9823 Make_Index_Or_Discriminant_Constraint
(Loc
,
9824 Constraints
=> New_List
(
9826 Make_Integer_Literal
(Loc
, 1),
9827 Make_Integer_Literal
(Loc
, E_Count
)))));
9829 when System_Tasking_Protected_Objects_Single_Entry
=>
9830 Expr
:= Remove_Head
(Expressions
(Entries_Aggr
));
9831 Obj_Def
:= New_Occurrence_Of
(RTE
(RE_Entry_Body
), Loc
);
9834 raise Program_Error
;
9838 Make_Object_Declaration
(Loc
,
9839 Defining_Identifier
=> Body_Id
,
9840 Aliased_Present
=> True,
9841 Constant_Present
=> True,
9842 Object_Definition
=> Obj_Def
,
9843 Expression
=> Expr
);
9845 -- A pointer to this array will be placed in the corresponding record
9846 -- by its initialization procedure so this needs to be analyzed here.
9848 Insert_After
(Current_Node
, Body_Arr
);
9849 Current_Node
:= Body_Arr
;
9852 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9854 -- Finally, build the function that maps an entry index into the
9855 -- corresponding body. A pointer to this function is placed in each
9856 -- object of the type. Except for a ravenscar-like profile (no abort,
9857 -- no entry queue, 1 entry)
9859 if Corresponding_Runtime_Package
(Prot_Typ
) =
9860 System_Tasking_Protected_Objects_Entries
9863 Make_Subprogram_Declaration
(Loc
,
9864 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9866 Insert_After
(Current_Node
, Sub
);
9870 end Expand_N_Protected_Type_Declaration
;
9872 --------------------------------
9873 -- Expand_N_Requeue_Statement --
9874 --------------------------------
9876 -- A nondispatching requeue statement is expanded into one of four GNARLI
9877 -- operations, depending on the source and destination (task or protected
9878 -- object). A dispatching requeue statement is expanded into a call to the
9879 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9880 -- jump around the remainder of processing for the original entry and, if
9881 -- the destination is (different) protected object, to attempt to service
9882 -- it. The following illustrates the various cases:
9885 -- (O : System.Address;
9886 -- P : System.Address;
9887 -- E : Protected_Entry_Index)
9889 -- <discriminant renamings>
9890 -- <private object renamings>
9891 -- type poVP is access poV;
9892 -- _object : ptVP := ptVP!(O);
9896 -- <start of statement sequence for entry>
9898 -- -- Requeue from one protected entry body to another protected
9901 -- Requeue_Protected_Entry (
9902 -- _object._object'Access,
9903 -- new._object'Access,
9908 -- <some more of the statement sequence for entry>
9910 -- -- Requeue from an entry body to a task entry
9912 -- Requeue_Protected_To_Task_Entry (
9918 -- <rest of statement sequence for entry>
9919 -- Complete_Entry_Body (_object._object);
9922 -- when all others =>
9923 -- Exceptional_Complete_Entry_Body (
9924 -- _object._object, Get_GNAT_Exception);
9928 -- Requeue of a task entry call to a task entry
9930 -- Accept_Call (E, Ann);
9931 -- <start of statement sequence for accept statement>
9932 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9934 -- <rest of statement sequence for accept statement>
9936 -- Complete_Rendezvous;
9939 -- when all others =>
9940 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9942 -- Requeue of a task entry call to a protected entry
9944 -- Accept_Call (E, Ann);
9945 -- <start of statement sequence for accept statement>
9946 -- Requeue_Task_To_Protected_Entry (
9947 -- new._object'Access,
9952 -- <rest of statement sequence for accept statement>
9954 -- Complete_Rendezvous;
9957 -- when all others =>
9958 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9960 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9961 -- marked by pragma Implemented (XXX, By_Entry).
9963 -- The requeue is inside a protected entry:
9966 -- (O : System.Address;
9967 -- P : System.Address;
9968 -- E : Protected_Entry_Index)
9970 -- <discriminant renamings>
9971 -- <private object renamings>
9972 -- type poVP is access poV;
9973 -- _object : ptVP := ptVP!(O);
9977 -- <start of statement sequence for entry>
9980 -- (<interface class-wide object>,
9983 -- Ada.Tags.Get_Offset_Index
9985 -- <interface dispatch table index of target entry>),
9989 -- <rest of statement sequence for entry>
9990 -- Complete_Entry_Body (_object._object);
9993 -- when all others =>
9994 -- Exceptional_Complete_Entry_Body (
9995 -- _object._object, Get_GNAT_Exception);
9999 -- The requeue is inside a task entry:
10001 -- Accept_Call (E, Ann);
10002 -- <start of statement sequence for accept statement>
10004 -- (<interface class-wide object>,
10007 -- Ada.Tags.Get_Offset_Index
10009 -- <interface dispatch table index of target entrt>),
10011 -- newS (new, Pnn);
10013 -- <rest of statement sequence for accept statement>
10015 -- Complete_Rendezvous;
10018 -- when all others =>
10019 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
10021 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
10022 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
10023 -- statement is replaced by a dispatching call with actual parameters taken
10024 -- from the inner-most accept statement or entry body.
10026 -- Target.Primitive (Param1, ..., ParamN);
10028 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
10029 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
10033 -- S : constant Offset_Index :=
10034 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
10035 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
10038 -- if C = POK_Protected_Entry
10039 -- or else C = POK_Task_Entry
10041 -- <statements for dispatching requeue>
10043 -- elsif C = POK_Protected_Procedure then
10044 -- <dispatching call equivalent>
10047 -- raise Program_Error;
10051 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
10052 Loc
: constant Source_Ptr
:= Sloc
(N
);
10053 Conc_Typ
: Entity_Id
;
10056 Enc_Subp
: Entity_Id
;
10058 Old_Typ
: Entity_Id
;
10060 function Build_Dispatching_Call_Equivalent
return Node_Id
;
10061 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10062 -- the form Concval.Ename. It is statically known that Ename is allowed
10063 -- to be implemented by a protected procedure. Create a dispatching call
10064 -- equivalent of Concval.Ename taking the actual parameters from the
10065 -- inner-most accept statement or entry body.
10067 function Build_Dispatching_Requeue
return Node_Id
;
10068 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10069 -- the form Concval.Ename. It is statically known that Ename is allowed
10070 -- to be implemented by a protected or a task entry. Create a call to
10071 -- primitive _Disp_Requeue which handles the low-level actions.
10073 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
10074 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10075 -- the form Concval.Ename. Ename is either marked by pragma Implemented
10076 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
10077 -- determines at runtime whether Ename denotes an entry or a procedure
10078 -- and perform the appropriate kind of dispatching select.
10080 function Build_Normal_Requeue
return Node_Id
;
10081 -- N denotes a nondispatching requeue statement to either a task or a
10082 -- protected entry. Build the appropriate runtime call to perform the
10085 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
10086 -- For a protected entry, create a return statement to skip the rest of
10087 -- the entry body. Otherwise, create a goto statement to skip the rest
10088 -- of a task accept statement. The lookup for the enclosing entry body
10089 -- or accept statement starts from Search.
10091 ---------------------------------------
10092 -- Build_Dispatching_Call_Equivalent --
10093 ---------------------------------------
10095 function Build_Dispatching_Call_Equivalent
return Node_Id
is
10096 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10097 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10104 -- Climb the parent chain looking for the inner-most entry body or
10105 -- accept statement.
10108 while Present
(Acc_Ent
)
10109 and then Nkind
(Acc_Ent
) not in N_Accept_Statement | N_Entry_Body
10111 Acc_Ent
:= Parent
(Acc_Ent
);
10114 -- A requeue statement should be housed inside an entry body or an
10115 -- accept statement at some level. If this is not the case, then the
10116 -- tree is malformed.
10118 pragma Assert
(Present
(Acc_Ent
));
10120 -- Recover the list of formal parameters
10122 if Nkind
(Acc_Ent
) = N_Entry_Body
then
10123 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
10126 Formals
:= Parameter_Specifications
(Acc_Ent
);
10128 -- Create the actual parameters for the dispatching call. These are
10129 -- simply copies of the entry body or accept statement formals in the
10130 -- same order as they appear.
10132 Actuals
:= No_List
;
10134 if Present
(Formals
) then
10135 Actuals
:= New_List
;
10136 Formal
:= First
(Formals
);
10137 while Present
(Formal
) loop
10138 Append_To
(Actuals
,
10139 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
10145 -- Obj.Call_Ent (Actuals);
10148 Make_Procedure_Call_Statement
(Loc
,
10150 Make_Selected_Component
(Loc
,
10151 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
10152 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
10154 Parameter_Associations
=> Actuals
);
10155 end Build_Dispatching_Call_Equivalent
;
10157 -------------------------------
10158 -- Build_Dispatching_Requeue --
10159 -------------------------------
10161 function Build_Dispatching_Requeue
return Node_Id
is
10162 Params
: constant List_Id
:= New_List
;
10165 -- Process the "with abort" parameter
10167 Prepend_To
(Params
,
10168 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10170 -- Process the entry wrapper's position in the primary dispatch
10171 -- table parameter. Generate:
10173 -- Ada.Tags.Get_Entry_Index
10174 -- (T => To_Tag_Ptr (Obj'Address).all,
10176 -- Ada.Tags.Get_Offset_Index
10177 -- (Ada.Tags.Tag (Concval),
10178 -- <interface dispatch table position of Ename>));
10180 -- Note that Obj'Address is recursively expanded into a call to
10181 -- Base_Address (Obj).
10183 if Tagged_Type_Expansion
then
10184 Prepend_To
(Params
,
10185 Make_Function_Call
(Loc
,
10186 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10187 Parameter_Associations
=> New_List
(
10189 Make_Explicit_Dereference
(Loc
,
10190 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
10191 Make_Attribute_Reference
(Loc
,
10192 Prefix
=> New_Copy_Tree
(Concval
),
10193 Attribute_Name
=> Name_Address
))),
10195 Make_Function_Call
(Loc
,
10196 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10197 Parameter_Associations
=> New_List
(
10198 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
10199 Make_Integer_Literal
(Loc
,
10200 DT_Position
(Entity
(Ename
))))))));
10205 Prepend_To
(Params
,
10206 Make_Function_Call
(Loc
,
10207 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10208 Parameter_Associations
=> New_List
(
10210 Make_Attribute_Reference
(Loc
,
10212 Attribute_Name
=> Name_Tag
),
10214 Make_Function_Call
(Loc
,
10215 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10217 Parameter_Associations
=> New_List
(
10221 Make_Attribute_Reference
(Loc
,
10223 Attribute_Name
=> Name_Tag
),
10227 Make_Attribute_Reference
(Loc
,
10228 Prefix
=> New_Occurrence_Of
(Etype
(Concval
), Loc
),
10229 Attribute_Name
=> Name_Tag
),
10233 Make_Integer_Literal
(Loc
,
10234 DT_Position
(Entity
(Ename
))))))));
10237 -- Specific actuals for protected to XXX requeue
10239 if Is_Protected_Type
(Old_Typ
) then
10240 Prepend_To
(Params
,
10241 Make_Attribute_Reference
(Loc
, -- _object'Address
10243 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10244 Attribute_Name
=> Name_Address
));
10246 Prepend_To
(Params
, -- True
10247 New_Occurrence_Of
(Standard_True
, Loc
));
10249 -- Specific actuals for task to XXX requeue
10252 pragma Assert
(Is_Task_Type
(Old_Typ
));
10254 Prepend_To
(Params
, -- null
10255 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
10257 Prepend_To
(Params
, -- False
10258 New_Occurrence_Of
(Standard_False
, Loc
));
10261 -- Add the object parameter
10263 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
10266 -- _Disp_Requeue (<Params>);
10268 -- Find entity for Disp_Requeue operation, which belongs to
10269 -- the type and may not be directly visible.
10273 Op
: Entity_Id
:= Empty
;
10276 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
10277 while Present
(Elmt
) loop
10279 exit when Chars
(Op
) = Name_uDisp_Requeue
;
10283 pragma Assert
(Present
(Op
));
10286 Make_Procedure_Call_Statement
(Loc
,
10287 Name
=> New_Occurrence_Of
(Op
, Loc
),
10288 Parameter_Associations
=> Params
);
10290 end Build_Dispatching_Requeue
;
10292 --------------------------------------
10293 -- Build_Dispatching_Requeue_To_Any --
10294 --------------------------------------
10296 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
10297 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10298 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10299 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
10309 -- Dispatch table slot processing, generate:
10312 S
:= Build_S
(Loc
, Decls
);
10314 -- Call kind processing, generate:
10315 -- C : Ada.Tags.Prim_Op_Kind;
10317 C
:= Build_C
(Loc
, Decls
);
10320 -- S := Ada.Tags.Get_Offset_Index
10321 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10323 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10326 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10329 Make_Procedure_Call_Statement
(Loc
,
10331 New_Occurrence_Of
(
10332 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10333 Name_uDisp_Get_Prim_Op_Kind
),
10335 Parameter_Associations
=> New_List
(
10336 New_Copy_Tree
(Obj
),
10337 New_Occurrence_Of
(S
, Loc
),
10338 New_Occurrence_Of
(C
, Loc
))));
10342 -- if C = POK_Protected_Entry
10343 -- or else C = POK_Task_Entry
10346 Make_Implicit_If_Statement
(N
,
10352 New_Occurrence_Of
(C
, Loc
),
10354 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
10359 New_Occurrence_Of
(C
, Loc
),
10361 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
10363 -- Dispatching requeue equivalent
10365 Then_Statements
=> New_List
(
10366 Build_Dispatching_Requeue
,
10369 -- elsif C = POK_Protected_Procedure then
10371 Elsif_Parts
=> New_List
(
10372 Make_Elsif_Part
(Loc
,
10376 New_Occurrence_Of
(C
, Loc
),
10378 New_Occurrence_Of
(
10379 RTE
(RE_POK_Protected_Procedure
), Loc
)),
10381 -- Dispatching call equivalent
10383 Then_Statements
=> New_List
(
10384 Build_Dispatching_Call_Equivalent
))),
10387 -- raise Program_Error;
10390 Else_Statements
=> New_List
(
10391 Make_Raise_Program_Error
(Loc
,
10392 Reason
=> PE_Explicit_Raise
))));
10394 -- Wrap everything into a block
10397 Make_Block_Statement
(Loc
,
10398 Declarations
=> Decls
,
10399 Handled_Statement_Sequence
=>
10400 Make_Handled_Sequence_Of_Statements
(Loc
,
10401 Statements
=> Stmts
));
10402 end Build_Dispatching_Requeue_To_Any
;
10404 --------------------------
10405 -- Build_Normal_Requeue --
10406 --------------------------
10408 function Build_Normal_Requeue
return Node_Id
is
10409 Params
: constant List_Id
:= New_List
;
10414 -- Process the "with abort" parameter
10416 Prepend_To
(Params
,
10417 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10419 -- Add the index expression to the parameters. It is common among all
10422 Prepend_To
(Params
,
10423 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
10425 if Is_Protected_Type
(Old_Typ
) then
10427 Self_Param
: Node_Id
;
10431 Make_Attribute_Reference
(Loc
,
10433 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10435 Name_Unchecked_Access
);
10437 -- Protected to protected requeue
10439 if Is_Protected_Type
(Conc_Typ
) then
10441 New_Occurrence_Of
(
10442 RTE
(RE_Requeue_Protected_Entry
), Loc
);
10445 Make_Attribute_Reference
(Loc
,
10447 Concurrent_Ref
(Concval
),
10449 Name_Unchecked_Access
);
10451 -- Protected to task requeue
10453 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10455 New_Occurrence_Of
(
10456 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
10458 Param
:= Concurrent_Ref
(Concval
);
10461 Prepend_To
(Params
, Param
);
10462 Prepend_To
(Params
, Self_Param
);
10465 else pragma Assert
(Is_Task_Type
(Old_Typ
));
10467 -- Task to protected requeue
10469 if Is_Protected_Type
(Conc_Typ
) then
10471 New_Occurrence_Of
(
10472 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
10475 Make_Attribute_Reference
(Loc
,
10477 Concurrent_Ref
(Concval
),
10479 Name_Unchecked_Access
);
10481 -- Task to task requeue
10483 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10485 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
);
10487 Param
:= Concurrent_Ref
(Concval
);
10490 Prepend_To
(Params
, Param
);
10494 Make_Procedure_Call_Statement
(Loc
,
10496 Parameter_Associations
=> Params
);
10497 end Build_Normal_Requeue
;
10499 --------------------------
10500 -- Build_Skip_Statement --
10501 --------------------------
10503 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
10504 Skip_Stmt
: Node_Id
;
10507 -- Build a return statement to skip the rest of the entire body
10509 if Is_Protected_Type
(Old_Typ
) then
10510 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
10512 -- If the requeue is within a task, find the end label of the
10513 -- enclosing accept statement and create a goto statement to it.
10521 -- Climb the parent chain looking for the enclosing accept
10524 Acc
:= Parent
(Search
);
10525 while Present
(Acc
)
10526 and then Nkind
(Acc
) /= N_Accept_Statement
10528 Acc
:= Parent
(Acc
);
10531 -- The last statement is the second label used for completing
10532 -- the rendezvous the usual way. The label we are looking for
10533 -- is right before it.
10536 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
10538 pragma Assert
(Nkind
(Label
) = N_Label
);
10540 -- Generate a goto statement to skip the rest of the accept
10543 Make_Goto_Statement
(Loc
,
10545 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
10549 Set_Analyzed
(Skip_Stmt
);
10552 end Build_Skip_Statement
;
10554 -- Start of processing for Expand_N_Requeue_Statement
10557 -- Extract the components of the entry call
10559 Extract_Entry
(N
, Concval
, Ename
, Index
);
10560 Conc_Typ
:= Etype
(Concval
);
10562 -- Examine the scope stack in order to find nearest enclosing concurrent
10563 -- type. This will constitute our invocation source.
10565 Old_Typ
:= Current_Scope
;
10566 while Present
(Old_Typ
)
10567 and then not Is_Concurrent_Type
(Old_Typ
)
10569 Old_Typ
:= Scope
(Old_Typ
);
10572 -- Obtain the innermost enclosing callable construct for use in
10573 -- generating a dynamic accessibility check.
10575 Enc_Subp
:= Current_Scope
;
10577 if Ekind
(Enc_Subp
) not in Entry_Kind | Subprogram_Kind
then
10578 Enc_Subp
:= Enclosing_Subprogram
(Enc_Subp
);
10581 -- Generate a dynamic accessibility check on the target object
10583 Insert_Before_And_Analyze
(N
,
10584 Make_Raise_Program_Error
(Loc
,
10587 Left_Opnd
=> Accessibility_Level
(Name
(N
), Dynamic_Level
),
10588 Right_Opnd
=> Make_Integer_Literal
(Loc
,
10589 Scope_Depth
(Enc_Subp
))),
10590 Reason
=> PE_Accessibility_Check_Failed
));
10592 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10593 -- Concval.Ename where the type of Concval is class-wide concurrent
10596 if Ada_Version
>= Ada_2012
10597 and then Present
(Concval
)
10598 and then Is_Class_Wide_Type
(Conc_Typ
)
10599 and then Is_Concurrent_Interface
(Conc_Typ
)
10602 Has_Impl
: Boolean := False;
10603 Impl_Kind
: Name_Id
:= No_Name
;
10606 -- Check whether the Ename is flagged by pragma Implemented
10608 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
10610 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
10613 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10614 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10616 if Has_Impl
and then Impl_Kind
= Name_By_Entry
then
10617 Rewrite
(N
, Build_Dispatching_Requeue
);
10619 Insert_After
(N
, Build_Skip_Statement
(N
));
10621 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10622 -- a protected procedure. In this case the requeue is transformed
10623 -- into a dispatching call.
10626 and then Impl_Kind
= Name_By_Protected_Procedure
10628 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
10631 -- The procedure_or_entry_NAME's implementation kind is either
10632 -- By_Any, Optional, or pragma Implemented was not applied at all.
10633 -- In this case a runtime test determines whether Ename denotes an
10634 -- entry or a protected procedure and performs the appropriate
10638 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
10643 -- Processing for regular (nondispatching) requeues
10646 Rewrite
(N
, Build_Normal_Requeue
);
10648 Insert_After
(N
, Build_Skip_Statement
(N
));
10650 end Expand_N_Requeue_Statement
;
10652 -------------------------------
10653 -- Expand_N_Selective_Accept --
10654 -------------------------------
10656 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10657 Loc
: constant Source_Ptr
:= Sloc
(N
);
10658 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10660 -- Note: in the below declarations a lot of new lists are allocated
10661 -- unconditionally which may well not end up being used. That's not
10662 -- a good idea since it wastes space gratuitously ???
10664 Accept_Case
: List_Id
;
10665 Accept_List
: constant List_Id
:= New_List
;
10668 Alt_List
: constant List_Id
:= New_List
;
10669 Alt_Stats
: List_Id
;
10670 Ann
: Entity_Id
:= Empty
;
10672 Check_Guard
: Boolean := True;
10674 Decls
: constant List_Id
:= New_List
;
10675 Stats
: constant List_Id
:= New_List
;
10676 Body_List
: constant List_Id
:= New_List
;
10677 Trailing_List
: constant List_Id
:= New_List
;
10680 Else_Present
: Boolean := False;
10681 Terminate_Alt
: Node_Id
:= Empty
;
10682 Select_Mode
: Node_Id
;
10684 Delay_Case
: List_Id
;
10685 Delay_Count
: Integer := 0;
10686 Delay_Val
: Entity_Id
;
10687 Delay_Index
: Entity_Id
;
10688 Delay_Min
: Entity_Id
;
10689 Delay_Num
: Pos
:= 1;
10690 Delay_Alt_List
: List_Id
:= New_List
;
10691 Delay_List
: constant List_Id
:= New_List
;
10695 First_Delay
: Boolean := True;
10696 Guard_Open
: Entity_Id
;
10702 Num_Accept
: Nat
:= 0;
10704 Time_Type
: Entity_Id
:= Empty
;
10705 Select_Call
: Node_Id
;
10707 Qnam
: constant Entity_Id
:=
10708 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10710 Xnam
: constant Entity_Id
:=
10711 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10713 -----------------------
10714 -- Local subprograms --
10715 -----------------------
10717 function Accept_Or_Raise
return List_Id
;
10718 -- For the rare case where delay alternatives all have guards, and
10719 -- all of them are closed, it is still possible that there were open
10720 -- accept alternatives with no callers. We must reexamine the
10721 -- Accept_List, and execute a selective wait with no else if some
10722 -- accept is open. If none, we raise program_error.
10724 procedure Add_Accept
(Alt
: Node_Id
);
10725 -- Process a single accept statement in a select alternative. Build
10726 -- procedure for body of accept, and add entry to dispatch table with
10727 -- expression for guard, in preparation for call to run time select.
10729 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10730 -- Manufacture a label using Num as a serial number and declare it.
10731 -- The declaration is appended to Decls. The label marks the trailing
10732 -- statements of an accept or delay alternative.
10734 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10735 -- Build call to Selective_Wait runtime routine
10737 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10738 -- Add code to compare value of delay with previous values, and
10739 -- generate case entry for trailing statements.
10741 procedure Process_Accept_Alternative
10745 -- Add code to call corresponding procedure, and branch to
10746 -- trailing statements, if any.
10748 ---------------------
10749 -- Accept_Or_Raise --
10750 ---------------------
10752 function Accept_Or_Raise
return List_Id
is
10755 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10758 -- We generate the following:
10760 -- for J in q'range loop
10761 -- if q(J).S /=null_task_entry then
10762 -- selective_wait (simple_mode,...);
10768 -- if no rendez_vous then
10769 -- raise program_error;
10772 -- Note that the code needs to know that the selector name
10773 -- in an Accept_Alternative is named S.
10775 Cond
:= Make_Op_Ne
(Loc
,
10777 Make_Selected_Component
(Loc
,
10779 Make_Indexed_Component
(Loc
,
10780 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10781 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))),
10782 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10784 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Loc
));
10786 Stats
:= New_List
(
10787 Make_Implicit_Loop_Statement
(N
,
10788 Iteration_Scheme
=>
10789 Make_Iteration_Scheme
(Loc
,
10790 Loop_Parameter_Specification
=>
10791 Make_Loop_Parameter_Specification
(Loc
,
10792 Defining_Identifier
=> J
,
10793 Discrete_Subtype_Definition
=>
10794 Make_Attribute_Reference
(Loc
,
10795 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10796 Attribute_Name
=> Name_Range
,
10797 Expressions
=> New_List
(
10798 Make_Integer_Literal
(Loc
, 1))))),
10800 Statements
=> New_List
(
10801 Make_Implicit_If_Statement
(N
,
10803 Then_Statements
=> New_List
(
10805 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)),
10806 Make_Exit_Statement
(Loc
))))));
10809 Make_Raise_Program_Error
(Loc
,
10810 Condition
=> Make_Op_Eq
(Loc
,
10811 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
10813 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
10814 Reason
=> PE_All_Guards_Closed
));
10817 end Accept_Or_Raise
;
10823 procedure Add_Accept
(Alt
: Node_Id
) is
10824 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10825 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10826 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10827 Eent
: constant Entity_Id
:= Entity
(Ename
);
10828 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10832 Null_Body
: Node_Id
;
10833 PB_Ent
: Entity_Id
;
10834 Proc_Body
: Node_Id
;
10836 -- Start of processing for Add_Accept
10840 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10843 if Present
(Condition
(Alt
)) then
10845 Make_If_Expression
(Eloc
, New_List
(
10847 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10848 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10850 Expr
:= Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
));
10853 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10854 Null_Body
:= New_Occurrence_Of
(Standard_False
, Eloc
);
10856 -- Always add call to Abort_Undefer when generating code, since
10857 -- this is what the runtime expects (abort deferred in
10858 -- Selective_Wait). In CodePeer mode this only confuses the
10859 -- analysis with unknown calls, so don't do it.
10861 if not CodePeer_Mode
then
10862 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10864 (First
(Statements
(Handled_Statement_Sequence
10865 (Accept_Statement
(Alt
)))),
10871 Make_Defining_Identifier
(Eloc
,
10872 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10874 -- Link the acceptor to the original receiving entry
10876 Mutate_Ekind
(PB_Ent
, E_Procedure
);
10877 Set_Receiving_Entry
(PB_Ent
, Eent
);
10879 if Comes_From_Source
(Alt
) then
10880 Set_Debug_Info_Needed
(PB_Ent
);
10884 Make_Subprogram_Body
(Eloc
,
10886 Make_Procedure_Specification
(Eloc
,
10887 Defining_Unit_Name
=> PB_Ent
),
10888 Declarations
=> Declarations
(Acc_Stm
),
10889 Handled_Statement_Sequence
=>
10890 Build_Accept_Body
(Accept_Statement
(Alt
)));
10892 Reset_Scopes_To
(Proc_Body
, PB_Ent
);
10894 -- During the analysis of the body of the accept statement, any
10895 -- zero cost exception handler records were collected in the
10896 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10897 -- This is where we move them to where they belong, namely the
10898 -- newly created procedure.
10900 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10901 Append
(Proc_Body
, Body_List
);
10904 Null_Body
:= New_Occurrence_Of
(Standard_True
, Eloc
);
10906 -- if accept statement has declarations, insert above, given that
10907 -- we are not creating a body for the accept.
10909 if Present
(Declarations
(Acc_Stm
)) then
10910 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10914 Append_To
(Accept_List
,
10915 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10917 Num_Accept
:= Num_Accept
+ 1;
10920 ----------------------------
10921 -- Make_And_Declare_Label --
10922 ----------------------------
10924 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10928 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10930 Make_Label
(Loc
, Lab_Id
);
10933 Make_Implicit_Label_Declaration
(Loc
,
10934 Defining_Identifier
=>
10935 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10936 Label_Construct
=> Lab
));
10939 end Make_And_Declare_Label
;
10941 ----------------------
10942 -- Make_Select_Call --
10943 ----------------------
10945 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10946 Params
: constant List_Id
:= New_List
;
10950 Make_Attribute_Reference
(Loc
,
10951 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10952 Attribute_Name
=> Name_Unchecked_Access
));
10953 Append_To
(Params
, Select_Mode
);
10954 Append_To
(Params
, New_Occurrence_Of
(Ann
, Loc
));
10955 Append_To
(Params
, New_Occurrence_Of
(Xnam
, Loc
));
10958 Make_Procedure_Call_Statement
(Loc
,
10959 Name
=> New_Occurrence_Of
(RTE
(RE_Selective_Wait
), Loc
),
10960 Parameter_Associations
=> Params
);
10961 end Make_Select_Call
;
10963 --------------------------------
10964 -- Process_Accept_Alternative --
10965 --------------------------------
10967 procedure Process_Accept_Alternative
10972 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10973 Alt_Stats
: List_Id
;
10976 Adjust_Condition
(Condition
(Alt
));
10978 -- Accept with body
10980 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10983 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10986 (Defining_Unit_Name
(Specification
(Proc
)),
10989 -- Accept with no body (followed by trailing statements)
10993 Entry_Id
: constant Entity_Id
:=
10994 Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)));
10996 -- Ada 2022 (AI12-0279)
10998 if Has_Yield_Aspect
(Entry_Id
)
10999 and then RTE_Available
(RE_Yield
)
11003 Make_Procedure_Call_Statement
(Sloc
(Proc
),
11004 New_Occurrence_Of
(RTE
(RE_Yield
), Sloc
(Proc
))));
11006 Alt_Stats
:= Empty_List
;
11011 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
11013 -- After the call, if any, branch to trailing statements, if any.
11014 -- We create a label for each, as well as the corresponding label
11017 if not Is_Empty_List
(Statements
(Alt
)) then
11018 Lab
:= Make_And_Declare_Label
(Index
);
11019 Append
(Lab
, Trailing_List
);
11020 Append_List
(Statements
(Alt
), Trailing_List
);
11021 Append_To
(Trailing_List
,
11022 Make_Goto_Statement
(Loc
,
11023 Name
=> New_Copy
(Identifier
(End_Lab
))));
11029 Append_To
(Alt_Stats
,
11030 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
11032 Append_To
(Alt_List
,
11033 Make_Case_Statement_Alternative
(Loc
,
11034 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
11035 Statements
=> Alt_Stats
));
11036 end Process_Accept_Alternative
;
11038 -------------------------------
11039 -- Process_Delay_Alternative --
11040 -------------------------------
11042 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
11043 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
11045 Delay_Alt
: List_Id
;
11048 -- Deal with C/Fortran boolean as delay condition
11050 Adjust_Condition
(Condition
(Alt
));
11052 -- Determine the smallest specified delay
11054 -- for each delay alternative generate:
11056 -- if guard-expression then
11057 -- Delay_Val := delay-expression;
11058 -- Guard_Open := True;
11059 -- if Delay_Val < Delay_Min then
11060 -- Delay_Min := Delay_Val;
11061 -- Delay_Index := Index;
11065 -- The enclosing if-statement is omitted if there is no guard
11067 if Delay_Count
= 1 or else First_Delay
then
11068 First_Delay
:= False;
11070 Delay_Alt
:= New_List
(
11071 Make_Assignment_Statement
(Loc
,
11072 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
11073 Expression
=> Expression
(Delay_Statement
(Alt
))));
11075 if Delay_Count
> 1 then
11076 Append_To
(Delay_Alt
,
11077 Make_Assignment_Statement
(Loc
,
11078 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11079 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
11083 Delay_Alt
:= New_List
(
11084 Make_Assignment_Statement
(Loc
,
11085 Name
=> New_Occurrence_Of
(Delay_Val
, Loc
),
11086 Expression
=> Expression
(Delay_Statement
(Alt
))));
11088 if Time_Type
= Standard_Duration
then
11091 Left_Opnd
=> New_Occurrence_Of
(Delay_Val
, Loc
),
11092 Right_Opnd
=> New_Occurrence_Of
(Delay_Min
, Loc
));
11095 -- The scope of the time type must define a comparison
11096 -- operator. The scope itself may not be visible, so we
11097 -- construct a node with entity information to insure that
11098 -- semantic analysis can find the proper operator.
11101 Make_Function_Call
(Loc
,
11102 Name
=> Make_Selected_Component
(Loc
,
11104 New_Occurrence_Of
(Scope
(Time_Type
), Loc
),
11106 Make_Operator_Symbol
(Loc
,
11107 Chars
=> Name_Op_Lt
,
11108 Strval
=> No_String
)),
11109 Parameter_Associations
=>
11111 New_Occurrence_Of
(Delay_Val
, Loc
),
11112 New_Occurrence_Of
(Delay_Min
, Loc
)));
11114 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
11117 Append_To
(Delay_Alt
,
11118 Make_Implicit_If_Statement
(N
,
11120 Then_Statements
=> New_List
(
11121 Make_Assignment_Statement
(Loc
,
11122 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
11123 Expression
=> New_Occurrence_Of
(Delay_Val
, Loc
)),
11125 Make_Assignment_Statement
(Loc
,
11126 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11127 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
11130 if Check_Guard
then
11131 Append_To
(Delay_Alt
,
11132 Make_Assignment_Statement
(Loc
,
11133 Name
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11134 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11137 if Present
(Condition
(Alt
)) then
11138 Delay_Alt
:= New_List
(
11139 Make_Implicit_If_Statement
(N
,
11140 Condition
=> Condition
(Alt
),
11141 Then_Statements
=> Delay_Alt
));
11144 Append_List
(Delay_Alt
, Delay_List
);
11146 Ensure_Statement_Present
(Dloc
, Alt
);
11148 -- If the delay alternative has a statement part, add choice to the
11149 -- case statements for delays.
11151 if not Is_Empty_List
(Statements
(Alt
)) then
11153 if Delay_Count
= 1 then
11154 Append_List
(Statements
(Alt
), Delay_Alt_List
);
11157 Append_To
(Delay_Alt_List
,
11158 Make_Case_Statement_Alternative
(Loc
,
11159 Discrete_Choices
=> New_List
(
11160 Make_Integer_Literal
(Loc
, Index
)),
11161 Statements
=> Statements
(Alt
)));
11164 elsif Delay_Count
= 1 then
11166 -- If the single delay has no trailing statements, add a branch
11167 -- to the exit label to the selective wait.
11169 Delay_Alt_List
:= New_List
(
11170 Make_Goto_Statement
(Loc
,
11171 Name
=> New_Copy
(Identifier
(End_Lab
))));
11174 end Process_Delay_Alternative
;
11176 -- Start of processing for Expand_N_Selective_Accept
11179 Process_Statements_For_Controlled_Objects
(N
);
11181 -- First insert some declarations before the select. The first is:
11185 -- This variable holds the parameters passed to the accept body. This
11186 -- declaration has already been inserted by the time we get here by
11187 -- a call to Expand_Accept_Declarations made from the semantics when
11188 -- processing the first accept statement contained in the select. We
11189 -- can find this entity as Accept_Address (E), where E is any of the
11190 -- entries references by contained accept statements.
11192 -- The first step is to scan the list of Selective_Accept_Statements
11193 -- to find this entity, and also count the number of accepts, and
11194 -- determine if terminated, delay or else is present:
11198 Alt
:= First
(Alts
);
11199 while Present
(Alt
) loop
11200 Process_Statements_For_Controlled_Objects
(Alt
);
11202 if Nkind
(Alt
) = N_Accept_Alternative
then
11205 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11206 Delay_Count
:= Delay_Count
+ 1;
11208 -- If the delays are relative delays, the delay expressions have
11209 -- type Standard_Duration. Otherwise they must have some time type
11210 -- recognized by GNAT.
11212 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
11213 Time_Type
:= Standard_Duration
;
11215 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
11217 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
11218 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
11222 -- Move this check to sem???
11224 "& is not a time type (RM 9.6(6))",
11225 Expression
(Delay_Statement
(Alt
)), Time_Type
);
11226 Time_Type
:= Standard_Duration
;
11227 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
11231 if No
(Condition
(Alt
)) then
11233 -- This guard will always be open
11235 Check_Guard
:= False;
11238 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
11239 Adjust_Condition
(Condition
(Alt
));
11240 Terminate_Alt
:= Alt
;
11243 Num_Alts
:= Num_Alts
+ 1;
11247 Else_Present
:= Present
(Else_Statements
(N
));
11249 -- At the same time (see procedure Add_Accept) we build the accept list:
11251 -- Qnn : Accept_List (1 .. num-select) := (
11252 -- (null-body, entry-index),
11253 -- (null-body, entry-index),
11255 -- (null_body, entry-index));
11257 -- In the above declaration, null-body is True if the corresponding
11258 -- accept has no body, and false otherwise. The entry is either the
11259 -- entry index expression if there is no guard, or if a guard is
11260 -- present, then an if expression of the form:
11262 -- (if guard then entry-index else Null_Task_Entry)
11264 -- If a guard is statically known to be false, the entry can simply
11265 -- be omitted from the accept list.
11268 Make_Object_Declaration
(Loc
,
11269 Defining_Identifier
=> Qnam
,
11270 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11271 Aliased_Present
=> True,
11273 Make_Qualified_Expression
(Loc
,
11275 New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11277 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
11279 -- Then we declare the variable that holds the index for the accept
11280 -- that will be selected for service:
11282 -- Xnn : Select_Index;
11285 Make_Object_Declaration
(Loc
,
11286 Defining_Identifier
=> Xnam
,
11287 Object_Definition
=>
11288 New_Occurrence_Of
(RTE
(RE_Select_Index
), Loc
),
11290 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)));
11292 -- After this follow procedure declarations for each accept body
11294 -- procedure Pnn is
11299 -- where the ... are statements from the corresponding procedure body.
11300 -- No parameters are involved, since the parameters are passed via Ann
11301 -- and the parameter references have already been expanded to be direct
11302 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11303 -- any embedded tasking statements (which would normally be illegal in
11304 -- procedures), have been converted to calls to the tasking runtime so
11305 -- there is no problem in putting them into procedures.
11307 -- The original accept statement has been expanded into a block in
11308 -- the same fashion as for simple accepts (see Build_Accept_Body).
11310 -- Note: we don't really need to build these procedures for the case
11311 -- where no delay statement is present, but it is just as easy to
11312 -- build them unconditionally, and not significantly inefficient,
11313 -- since if they are short they will be inlined anyway.
11315 -- The procedure declarations have been assembled in Body_List
11317 -- If delays are present, we must compute the required delay.
11318 -- We first generate the declarations:
11320 -- Delay_Index : Boolean := 0;
11321 -- Delay_Min : Some_Time_Type.Time;
11322 -- Delay_Val : Some_Time_Type.Time;
11324 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11325 -- active delay that is actually chosen as the basis for the possible
11326 -- delay if an immediate rendez-vous is not possible.
11328 -- In the most common case there is a single delay statement, and this
11329 -- is handled specially.
11331 if Delay_Count
> 0 then
11333 -- Generate the required declarations
11336 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
11338 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
11340 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
11342 pragma Assert
(Present
(Time_Type
));
11345 Make_Object_Declaration
(Loc
,
11346 Defining_Identifier
=> Delay_Val
,
11347 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
)));
11350 Make_Object_Declaration
(Loc
,
11351 Defining_Identifier
=> Delay_Index
,
11352 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11353 Expression
=> Make_Integer_Literal
(Loc
, 0)));
11356 Make_Object_Declaration
(Loc
,
11357 Defining_Identifier
=> Delay_Min
,
11358 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
),
11360 Unchecked_Convert_To
(Time_Type
,
11361 Make_Attribute_Reference
(Loc
,
11363 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
11364 Attribute_Name
=> Name_Last
))));
11366 -- Create Duration and Delay_Mode objects used for passing a delay
11369 D
:= Make_Temporary
(Loc
, 'D');
11370 M
:= Make_Temporary
(Loc
, 'M');
11376 -- Note that these values are defined in s-osprim.ads and must
11377 -- be kept in sync:
11379 -- Relative : constant := 0;
11380 -- Absolute_Calendar : constant := 1;
11381 -- Absolute_RT : constant := 2;
11383 if Time_Type
= Standard_Duration
then
11384 Discr
:= Make_Integer_Literal
(Loc
, 0);
11386 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11387 Discr
:= Make_Integer_Literal
(Loc
, 1);
11391 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11392 Discr
:= Make_Integer_Literal
(Loc
, 2);
11396 Make_Object_Declaration
(Loc
,
11397 Defining_Identifier
=> D
,
11398 Object_Definition
=>
11399 New_Occurrence_Of
(Standard_Duration
, Loc
)));
11402 Make_Object_Declaration
(Loc
,
11403 Defining_Identifier
=> M
,
11404 Object_Definition
=>
11405 New_Occurrence_Of
(Standard_Integer
, Loc
),
11406 Expression
=> Discr
));
11409 if Check_Guard
then
11411 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
11414 Make_Object_Declaration
(Loc
,
11415 Defining_Identifier
=> Guard_Open
,
11416 Object_Definition
=>
11417 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11419 New_Occurrence_Of
(Standard_False
, Loc
)));
11422 -- Delay_Count is zero, don't need M and D set (suppress warning)
11429 if Present
(Terminate_Alt
) then
11431 -- If the terminate alternative guard is False, use
11432 -- Simple_Mode; otherwise use Terminate_Mode.
11434 if Present
(Condition
(Terminate_Alt
)) then
11435 Select_Mode
:= Make_If_Expression
(Loc
,
11436 New_List
(Condition
(Terminate_Alt
),
11437 New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
),
11438 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)));
11440 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
);
11443 elsif Else_Present
or Delay_Count
> 0 then
11444 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Else_Mode
), Loc
);
11447 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
);
11450 Select_Call
:= Make_Select_Call
(Select_Mode
);
11451 Append
(Select_Call
, Stats
);
11453 -- Now generate code to act on the result. There is an entry
11454 -- in this case for each accept statement with a non-null body,
11455 -- followed by a branch to the statements that follow the Accept.
11456 -- In the absence of delay alternatives, we generate:
11459 -- when No_Rendezvous => -- omitted if simple mode
11474 -- Lab0: Else_Statements;
11477 -- Lab1: Trailing_Statements1;
11480 -- Lab2: Trailing_Statements2;
11485 -- Generate label for common exit
11487 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
11489 -- First entry is the default case, when no rendezvous is possible
11491 Choices
:= New_List
(New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
));
11493 if Else_Present
then
11495 -- If no rendezvous is possible, the else part is executed
11497 Lab
:= Make_And_Declare_Label
(0);
11498 Alt_Stats
:= New_List
(
11499 Make_Goto_Statement
(Loc
,
11500 Name
=> New_Copy
(Identifier
(Lab
))));
11502 Append
(Lab
, Trailing_List
);
11503 Append_List
(Else_Statements
(N
), Trailing_List
);
11504 Append_To
(Trailing_List
,
11505 Make_Goto_Statement
(Loc
,
11506 Name
=> New_Copy
(Identifier
(End_Lab
))));
11508 Alt_Stats
:= New_List
(
11509 Make_Goto_Statement
(Loc
,
11510 Name
=> New_Copy
(Identifier
(End_Lab
))));
11513 Append_To
(Alt_List
,
11514 Make_Case_Statement_Alternative
(Loc
,
11515 Discrete_Choices
=> Choices
,
11516 Statements
=> Alt_Stats
));
11518 -- We make use of the fact that Accept_Index is an integer type, and
11519 -- generate successive literals for entries for each accept. Only those
11520 -- for which there is a body or trailing statements get a case entry.
11522 Alt
:= First
(Select_Alternatives
(N
));
11523 Proc
:= First
(Body_List
);
11524 while Present
(Alt
) loop
11526 if Nkind
(Alt
) = N_Accept_Alternative
then
11527 Process_Accept_Alternative
(Alt
, Index
, Proc
);
11528 Index
:= Index
+ 1;
11531 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
11536 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11537 Process_Delay_Alternative
(Alt
, Delay_Num
);
11538 Delay_Num
:= Delay_Num
+ 1;
11544 -- An others choice is always added to the main case, as well
11545 -- as the delay case (to satisfy the compiler).
11547 Append_To
(Alt_List
,
11548 Make_Case_Statement_Alternative
(Loc
,
11549 Discrete_Choices
=>
11550 New_List
(Make_Others_Choice
(Loc
)),
11552 New_List
(Make_Goto_Statement
(Loc
,
11553 Name
=> New_Copy
(Identifier
(End_Lab
))))));
11555 Accept_Case
:= New_List
(
11556 Make_Case_Statement
(Loc
,
11557 Expression
=> New_Occurrence_Of
(Xnam
, Loc
),
11558 Alternatives
=> Alt_List
));
11560 Append_List
(Trailing_List
, Accept_Case
);
11561 Append_List
(Body_List
, Decls
);
11563 -- Construct case statement for trailing statements of delay
11564 -- alternatives, if there are several of them.
11566 if Delay_Count
> 1 then
11567 Append_To
(Delay_Alt_List
,
11568 Make_Case_Statement_Alternative
(Loc
,
11569 Discrete_Choices
=>
11570 New_List
(Make_Others_Choice
(Loc
)),
11572 New_List
(Make_Null_Statement
(Loc
))));
11574 Delay_Case
:= New_List
(
11575 Make_Case_Statement
(Loc
,
11576 Expression
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11577 Alternatives
=> Delay_Alt_List
));
11579 Delay_Case
:= Delay_Alt_List
;
11582 -- If there are no delay alternatives, we append the case statement
11583 -- to the statement list.
11585 if Delay_Count
= 0 then
11586 Append_List
(Accept_Case
, Stats
);
11588 -- Delay alternatives present
11591 -- If delay alternatives are present we generate:
11593 -- find minimum delay.
11594 -- DX := minimum delay;
11595 -- M := <delay mode>;
11596 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11599 -- if X = No_Rendezvous then
11600 -- case statement for delay statements.
11602 -- case statement for accept alternatives.
11613 -- The type of the delay expression is known to be legal
11615 if Time_Type
= Standard_Duration
then
11616 Conv
:= New_Occurrence_Of
(Delay_Min
, Loc
);
11618 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11619 Conv
:= Make_Function_Call
(Loc
,
11620 New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
11621 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11625 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11627 Conv
:= Make_Function_Call
(Loc
,
11628 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
11629 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11632 Stmt
:= Make_Assignment_Statement
(Loc
,
11633 Name
=> New_Occurrence_Of
(D
, Loc
),
11634 Expression
=> Conv
);
11636 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11638 Parms
:= Parameter_Associations
(Select_Call
);
11640 Parm
:= First
(Parms
);
11641 while Present
(Parm
) and then Parm
/= Select_Mode
loop
11645 pragma Assert
(Present
(Parm
));
11646 Rewrite
(Parm
, New_Occurrence_Of
(RTE
(RE_Delay_Mode
), Loc
));
11649 -- Prepare two new parameters of Duration and Delay_Mode type
11650 -- which represent the value and the mode of the minimum delay.
11653 Insert_After
(Parm
, New_Occurrence_Of
(M
, Loc
));
11654 Insert_After
(Parm
, New_Occurrence_Of
(D
, Loc
));
11656 -- Create a call to RTS
11658 Rewrite
(Select_Call
,
11659 Make_Procedure_Call_Statement
(Loc
,
11660 Name
=> New_Occurrence_Of
(RTE
(RE_Timed_Selective_Wait
), Loc
),
11661 Parameter_Associations
=> Parms
));
11663 -- This new call should follow the calculation of the minimum
11666 Insert_List_Before
(Select_Call
, Delay_List
);
11668 if Check_Guard
then
11670 Make_Implicit_If_Statement
(N
,
11671 Condition
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11672 Then_Statements
=> New_List
(
11673 New_Copy_Tree
(Stmt
),
11674 New_Copy_Tree
(Select_Call
)),
11675 Else_Statements
=> Accept_Or_Raise
);
11676 Rewrite
(Select_Call
, Stmt
);
11678 Insert_Before
(Select_Call
, Stmt
);
11682 Make_Implicit_If_Statement
(N
,
11683 Condition
=> Make_Op_Eq
(Loc
,
11684 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
11686 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
11688 Then_Statements
=> Delay_Case
,
11689 Else_Statements
=> Accept_Case
);
11691 Append
(Cases
, Stats
);
11695 Append
(End_Lab
, Stats
);
11697 -- Replace accept statement with appropriate block
11700 Make_Block_Statement
(Loc
,
11701 Declarations
=> Decls
,
11702 Handled_Statement_Sequence
=>
11703 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11706 -- Note: have to worry more about abort deferral in above code ???
11708 -- Final step is to unstack the Accept_Address entries for all accept
11709 -- statements appearing in accept alternatives in the select statement
11711 Alt
:= First
(Alts
);
11712 while Present
(Alt
) loop
11713 if Nkind
(Alt
) = N_Accept_Alternative
then
11714 Remove_Last_Elmt
(Accept_Address
11715 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11720 end Expand_N_Selective_Accept
;
11722 -------------------------------------------
11723 -- Expand_N_Single_Protected_Declaration --
11724 -------------------------------------------
11726 -- A single protected declaration should never be present after semantic
11727 -- analysis because it is transformed into a protected type declaration
11728 -- and an accompanying anonymous object. This routine ensures that the
11729 -- transformation takes place.
11731 procedure Expand_N_Single_Protected_Declaration
(N
: Node_Id
) is
11733 raise Program_Error
;
11734 end Expand_N_Single_Protected_Declaration
;
11736 --------------------------------------
11737 -- Expand_N_Single_Task_Declaration --
11738 --------------------------------------
11740 -- A single task declaration should never be present after semantic
11741 -- analysis because it is transformed into a task type declaration and
11742 -- an accompanying anonymous object. This routine ensures that the
11743 -- transformation takes place.
11745 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11747 raise Program_Error
;
11748 end Expand_N_Single_Task_Declaration
;
11750 ------------------------
11751 -- Expand_N_Task_Body --
11752 ------------------------
11754 -- Given a task body
11756 -- task body tname is
11762 -- This expansion routine converts it into a procedure and sets the
11763 -- elaboration flag for the procedure to true, to represent the fact
11764 -- that the task body is now elaborated:
11766 -- procedure tnameB (_Task : access tnameV) is
11767 -- discriminal : dtype renames _Task.discriminant;
11769 -- procedure _clean is
11771 -- Abort_Defer.all;
11773 -- Abort_Undefer.all;
11778 -- Abort_Undefer.all;
11780 -- System.Task_Stages.Complete_Activation;
11788 -- In addition, if the task body is an activator, then a call to activate
11789 -- tasks is added at the start of the statements, before the call to
11790 -- Complete_Activation, and if in addition the task is a master then it
11791 -- must be established as a master. These calls are inserted and analyzed
11792 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11795 -- There is one discriminal declaration line generated for each
11796 -- discriminant that is present to provide an easy reference point for
11797 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11799 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11800 -- task body procedures have a profile (Arg : System.Address). That is
11801 -- needed because GNARLI has to use the same access-to-subprogram type
11802 -- for all task types. We depend here on knowing that in GNAT, passing
11803 -- an address argument by value is identical to passing a record value
11804 -- by access (in either case a single pointer is passed), so even though
11805 -- this procedure has the wrong profile. In fact it's all OK, since the
11806 -- callings sequence is identical.
11808 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11809 Loc
: constant Source_Ptr
:= Sloc
(N
);
11810 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11814 Insert_Nod
: Node_Id
;
11815 -- Used to determine the proper location of wrapper body insertions
11818 -- if no task body procedure, means we had an error in configurable
11819 -- run-time mode, and there is no point in proceeding further.
11821 if No
(Task_Body_Procedure
(Ttyp
)) then
11825 -- Add renaming declarations for discriminals and a declaration for the
11826 -- entry family index (if applicable).
11828 Install_Private_Data_Declarations
11829 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11831 -- Add a call to Abort_Undefer at the very beginning of the task
11832 -- body since this body is called with abort still deferred.
11834 if Abort_Allowed
then
11835 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11837 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11841 -- The statement part has already been protected with an at_end and
11842 -- cleanup actions. The call to Complete_Activation must be placed
11843 -- at the head of the sequence of statements of that block. The
11844 -- declarations have been merged in this sequence of statements but
11845 -- the first real statement is accessible from the First_Real_Statement
11846 -- field (which was set for exactly this purpose).
11848 if Restricted_Profile
then
11849 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11851 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11855 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11859 Make_Subprogram_Body
(Loc
,
11860 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11861 Declarations
=> Declarations
(N
),
11862 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11863 Set_Is_Task_Body_Procedure
(New_N
);
11865 -- If the task contains generic instantiations, cleanup actions are
11866 -- delayed until after instantiation. Transfer the activation chain to
11867 -- the subprogram, to insure that the activation call is properly
11868 -- generated. It the task body contains inner tasks, indicate that the
11869 -- subprogram is a task master.
11871 if Delay_Cleanups
(Ttyp
) then
11872 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11873 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11876 Rewrite
(N
, New_N
);
11879 -- Set elaboration flag immediately after task body. If the body is a
11880 -- subunit, the flag is set in the declarative part containing the stub.
11882 if Nkind
(Parent
(N
)) /= N_Subunit
then
11884 Make_Assignment_Statement
(Loc
,
11886 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11887 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11890 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11891 -- the task body. At this point all wrapper specs have been created,
11892 -- frozen and included in the dispatch table for the task type.
11894 if Ada_Version
>= Ada_2005
then
11895 if Nkind
(Parent
(N
)) = N_Subunit
then
11896 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11901 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11903 end Expand_N_Task_Body
;
11905 ------------------------------------
11906 -- Expand_N_Task_Type_Declaration --
11907 ------------------------------------
11909 -- We have several things to do. First we must create a Boolean flag used
11910 -- to mark if the body is elaborated yet. This variable gets set to True
11911 -- when the body of the task is elaborated (we can't rely on the normal
11912 -- ABE mechanism for the task body, since we need to pass an access to
11913 -- this elaboration boolean to the runtime routines).
11915 -- taskE : aliased Boolean := False;
11917 -- Next a variable is declared to hold the task stack size (either the
11918 -- default : Unspecified_Size, or a value that is set by a pragma
11919 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11920 -- the variable is initialized with this value:
11922 -- taskZ : Size_Type := Unspecified_Size;
11924 -- taskZ : Size_Type := Size_Type (size_expression);
11926 -- Note: No variable is needed to hold the task relative deadline since
11927 -- its value would never be static because the parameter is of a private
11928 -- type (Ada.Real_Time.Time_Span).
11930 -- Next we create a corresponding record type declaration used to represent
11931 -- values of this task. The general form of this type declaration is
11933 -- type taskV (discriminants) is record
11934 -- _Task_Id : Task_Id;
11935 -- entry_family : array (bounds) of Void;
11936 -- _Priority : Integer := priority_expression;
11937 -- _Size : Size_Type := size_expression;
11938 -- _Secondary_Stack_Size : Size_Type := size_expression;
11939 -- _Task_Info : Task_Info_Type := task_info_expression;
11940 -- _CPU : Integer := cpu_range_expression;
11941 -- _Relative_Deadline : Time_Span := time_span_expression;
11942 -- _Domain : Dispatching_Domain := dd_expression;
11945 -- The discriminants are present only if the corresponding task type has
11946 -- discriminants, and they exactly mirror the task type discriminants.
11948 -- The Id field is always present. It contains the Task_Id value, as set by
11949 -- the call to Create_Task. Note that although the task is limited, the
11950 -- task value record type is not limited, so there is no problem in passing
11951 -- this field as an out parameter to Create_Task.
11953 -- One entry_family component is present for each entry family in the task
11954 -- definition. The bounds correspond to the bounds of the entry family
11955 -- (which may depend on discriminants). The element type is void, since we
11956 -- only need the bounds information for determining the entry index. Note
11957 -- that the use of an anonymous array would normally be illegal in this
11958 -- context, but this is a parser check, and the semantics is quite prepared
11959 -- to handle such a case.
11961 -- The _Size field is present only if a Storage_Size pragma appears in the
11962 -- task definition. The expression captures the argument that was present
11963 -- in the pragma, and is used to override the task stack size otherwise
11964 -- associated with the task type.
11966 -- The _Secondary_Stack_Size field is present only the task entity has a
11967 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11968 -- when the record init proc is built, to capture the expression of the
11969 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11970 -- be filled here since aspect evaluations are delayed till the freeze
11973 -- The _Priority field is present only if the task entity has a Priority or
11974 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11975 -- definition clause). It will be filled at the freeze point, when the
11976 -- record init proc is built, to capture the expression of the rep item
11977 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11978 -- here since aspect evaluations are delayed till the freeze point.
11980 -- The _Task_Info field is present only if a Task_Info pragma appears in
11981 -- the task definition. The expression captures the argument that was
11982 -- present in the pragma, and is used to provide the Task_Image parameter
11983 -- to the call to Create_Task.
11985 -- The _CPU field is present only if the task entity has a CPU rep item
11986 -- (pragma, aspect specification or attribute definition clause). It will
11987 -- be filled at the freeze point, when the record init proc is built, to
11988 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11989 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11990 -- are delayed till the freeze point.
11992 -- The _Relative_Deadline field is present only if a Relative_Deadline
11993 -- pragma appears in the task definition. The expression captures the
11994 -- argument that was present in the pragma, and is used to provide the
11995 -- Relative_Deadline parameter to the call to Create_Task.
11997 -- The _Domain field is present only if the task entity has a
11998 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11999 -- definition clause). It will be filled at the freeze point, when the
12000 -- record init proc is built, to capture the expression of the rep item
12001 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
12002 -- here since aspect evaluations are delayed till the freeze point.
12004 -- When a task is declared, an instance of the task value record is
12005 -- created. The elaboration of this declaration creates the correct bounds
12006 -- for the entry families, and also evaluates the size, priority, and
12007 -- task_Info expressions if needed. The initialization routine for the task
12008 -- type itself then calls Create_Task with appropriate parameters to
12009 -- initialize the value of the Task_Id field.
12011 -- Note: the address of this record is passed as the "Discriminants"
12012 -- parameter for Create_Task. Since Create_Task merely passes this onto the
12013 -- body procedure, it does not matter that it does not quite match the
12014 -- GNARLI model of what is being passed (the record contains more than just
12015 -- the discriminants, but the discriminants can be found from the record
12018 -- The Entity_Id for this created record type is placed in the
12019 -- Corresponding_Record_Type field of the associated task type entity.
12021 -- Next we create a procedure specification for the task body procedure:
12023 -- procedure taskB (_Task : access taskV);
12025 -- Note that this must come after the record type declaration, since
12026 -- the spec refers to this type. It turns out that the initialization
12027 -- procedure for the value type references the task body spec, but that's
12028 -- fine, since it won't be generated till the freeze point for the type,
12029 -- which is certainly after the task body spec declaration.
12031 -- Finally, we set the task index value field of the entry attribute in
12032 -- the case of a simple entry.
12034 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
12035 Loc
: constant Source_Ptr
:= Sloc
(N
);
12036 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
12037 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
12038 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
12039 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
12041 Body_Decl
: Node_Id
;
12043 Decl_Stack
: Node_Id
;
12045 Elab_Decl
: Node_Id
;
12046 Ent_Stack
: Entity_Id
;
12047 Proc_Spec
: Node_Id
;
12048 Rec_Decl
: Node_Id
;
12049 Rec_Ent
: Entity_Id
;
12050 Size_Decl
: Entity_Id
;
12051 Task_Size
: Node_Id
;
12053 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
12054 -- Searches the task definition T for the first occurrence of the pragma
12055 -- Relative Deadline. The caller has ensured that the pragma is present
12056 -- in the task definition. Note that this routine cannot be implemented
12057 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
12058 -- not chained because their expansion into a procedure call statement
12059 -- would cause a break in the chain.
12061 ----------------------------------
12062 -- Get_Relative_Deadline_Pragma --
12063 ----------------------------------
12065 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
12069 N
:= First
(Visible_Declarations
(T
));
12070 while Present
(N
) loop
12071 if Nkind
(N
) = N_Pragma
12072 and then Pragma_Name
(N
) = Name_Relative_Deadline
12080 N
:= First
(Private_Declarations
(T
));
12081 while Present
(N
) loop
12082 if Nkind
(N
) = N_Pragma
12083 and then Pragma_Name
(N
) = Name_Relative_Deadline
12091 raise Program_Error
;
12092 end Get_Relative_Deadline_Pragma
;
12094 -- Start of processing for Expand_N_Task_Type_Declaration
12097 -- If already expanded, nothing to do
12099 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
12103 -- Here we will do the expansion
12105 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
12107 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
12108 Cdecls
:= Component_Items
(Component_List
12109 (Type_Definition
(Rec_Decl
)));
12111 Qualify_Entity_Names
(N
);
12113 -- First create the elaboration variable
12116 Make_Object_Declaration
(Loc
,
12117 Defining_Identifier
=>
12118 Make_Defining_Identifier
(Sloc
(Tasktyp
),
12119 Chars
=> New_External_Name
(Tasknm
, 'E')),
12120 Aliased_Present
=> True,
12121 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
12122 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
12124 Insert_After
(N
, Elab_Decl
);
12126 -- Next create the declaration of the size variable (tasknmZ)
12128 Set_Storage_Size_Variable
(Tasktyp
,
12129 Make_Defining_Identifier
(Sloc
(Tasktyp
),
12130 Chars
=> New_External_Name
(Tasknm
, 'Z')));
12132 if Present
(Taskdef
)
12133 and then Has_Storage_Size_Pragma
(Taskdef
)
12135 Is_OK_Static_Expression
12137 (First
(Pragma_Argument_Associations
12138 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
12141 Make_Object_Declaration
(Loc
,
12142 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
12143 Object_Definition
=>
12144 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12146 Convert_To
(RTE
(RE_Size_Type
),
12148 (Expression
(First
(Pragma_Argument_Associations
12150 (TaskId
, Name_Storage_Size
)))))));
12154 Make_Object_Declaration
(Loc
,
12155 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
12156 Object_Definition
=>
12157 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
12159 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
12162 Insert_After
(Elab_Decl
, Size_Decl
);
12164 -- Next build the rest of the corresponding record declaration. This is
12165 -- done last, since the corresponding record initialization procedure
12166 -- will reference the previously created entities.
12168 -- Fill in the component declarations -- first the _Task_Id field
12171 Make_Component_Declaration
(Loc
,
12172 Defining_Identifier
=>
12173 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
12174 Component_Definition
=>
12175 Make_Component_Definition
(Loc
,
12176 Aliased_Present
=> False,
12177 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RO_ST_Task_Id
),
12180 -- Declare static ATCB (that is, created by the expander) if we are
12181 -- using the Restricted run time.
12183 if Restricted_Profile
then
12185 Make_Component_Declaration
(Loc
,
12186 Defining_Identifier
=>
12187 Make_Defining_Identifier
(Loc
, Name_uATCB
),
12189 Component_Definition
=>
12190 Make_Component_Definition
(Loc
,
12191 Aliased_Present
=> True,
12192 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12194 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
12197 Make_Index_Or_Discriminant_Constraint
(Loc
,
12199 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
12203 -- Declare static stack (that is, created by the expander) if we are
12204 -- using the Restricted run time on a bare board configuration.
12206 if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
12208 -- First we need to extract the appropriate stack size
12210 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
12212 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12214 Expr_N
: constant Node_Id
:=
12215 Expression
(First
(
12216 Pragma_Argument_Associations
(
12217 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
12218 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
12219 P
: constant Node_Id
:= Parent
(Expr_N
);
12222 -- The stack is defined inside the corresponding record.
12223 -- Therefore if the size of the stack is set by means of
12224 -- a discriminant, we must reference the discriminant of the
12225 -- corresponding record type.
12227 if Nkind
(Expr_N
) in N_Has_Entity
12228 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
12232 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
12234 Set_Parent
(Task_Size
, P
);
12235 Set_Etype
(Task_Size
, Etyp
);
12236 Set_Analyzed
(Task_Size
);
12239 Task_Size
:= New_Copy_Tree
(Expr_N
);
12245 New_Occurrence_Of
(RTE
(RE_Default_Stack_Size
), Loc
);
12248 Decl_Stack
:= Make_Component_Declaration
(Loc
,
12249 Defining_Identifier
=> Ent_Stack
,
12251 Component_Definition
=>
12252 Make_Component_Definition
(Loc
,
12253 Aliased_Present
=> True,
12254 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12256 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
12259 Make_Index_Or_Discriminant_Constraint
(Loc
,
12260 Constraints
=> New_List
(Make_Range
(Loc
,
12261 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
12262 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
12265 Append_To
(Cdecls
, Decl_Stack
);
12267 -- The appropriate alignment for the stack is ensured by the run-time
12268 -- code in charge of task creation.
12272 -- Declare a static secondary stack if the conditions for a statically
12273 -- generated stack are met.
12275 if Create_Secondary_Stack_For_Task
(TaskId
) then
12277 Size_Expr
: constant Node_Id
:=
12278 Expression
(First
(
12279 Pragma_Argument_Associations
(
12280 Get_Rep_Pragma
(TaskId
,
12281 Name_Secondary_Stack_Size
))));
12283 Stack_Size
: Node_Id
;
12286 -- The secondary stack is defined inside the corresponding
12287 -- record. Therefore if the size of the stack is set by means
12288 -- of a discriminant, we must reference the discriminant of the
12289 -- corresponding record type.
12291 if Nkind
(Size_Expr
) in N_Has_Entity
12292 and then Present
(Discriminal_Link
(Entity
(Size_Expr
)))
12296 (CR_Discriminant
(Discriminal_Link
(Entity
(Size_Expr
))),
12298 Set_Parent
(Stack_Size
, Parent
(Size_Expr
));
12299 Set_Etype
(Stack_Size
, Etype
(Size_Expr
));
12300 Set_Analyzed
(Stack_Size
);
12303 Stack_Size
:= New_Copy_Tree
(Size_Expr
);
12306 -- Create the secondary stack for the task
12309 Make_Component_Declaration
(Loc
,
12310 Defining_Identifier
=>
12311 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack
),
12312 Component_Definition
=>
12313 Make_Component_Definition
(Loc
,
12314 Aliased_Present
=> True,
12315 Subtype_Indication
=>
12316 Make_Subtype_Indication
(Loc
,
12318 New_Occurrence_Of
(RTE
(RE_SS_Stack
), Loc
),
12320 Make_Index_Or_Discriminant_Constraint
(Loc
,
12321 Constraints
=> New_List
(
12322 Convert_To
(RTE
(RE_Size_Type
),
12325 Append_To
(Cdecls
, Decl_SS
);
12329 -- Add components for entry families
12331 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
12333 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12334 -- item is present.
12336 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
12338 Make_Component_Declaration
(Loc
,
12339 Defining_Identifier
=>
12340 Make_Defining_Identifier
(Loc
, Name_uPriority
),
12341 Component_Definition
=>
12342 Make_Component_Definition
(Loc
,
12343 Aliased_Present
=> False,
12344 Subtype_Indication
=>
12345 New_Occurrence_Of
(Standard_Integer
, Loc
))));
12348 -- Add the _Size component if a Storage_Size pragma is present
12350 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12352 Make_Component_Declaration
(Loc
,
12353 Defining_Identifier
=>
12354 Make_Defining_Identifier
(Loc
, Name_uSize
),
12356 Component_Definition
=>
12357 Make_Component_Definition
(Loc
,
12358 Aliased_Present
=> False,
12359 Subtype_Indication
=>
12360 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
)),
12363 Convert_To
(RTE
(RE_Size_Type
),
12365 Expression
(First
(
12366 Pragma_Argument_Associations
(
12367 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
12370 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
12371 -- pragma is present.
12374 (TaskId
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
12377 Make_Component_Declaration
(Loc
,
12378 Defining_Identifier
=>
12379 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack_Size
),
12381 Component_Definition
=>
12382 Make_Component_Definition
(Loc
,
12383 Aliased_Present
=> False,
12384 Subtype_Indication
=>
12385 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
))));
12388 -- Add the _Task_Info component if a Task_Info pragma is present
12390 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
12392 Make_Component_Declaration
(Loc
,
12393 Defining_Identifier
=>
12394 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
12396 Component_Definition
=>
12397 Make_Component_Definition
(Loc
,
12398 Aliased_Present
=> False,
12399 Subtype_Indication
=>
12400 New_Occurrence_Of
(RTE
(RE_Task_Info_Type
), Loc
)),
12402 Expression
=> New_Copy
(
12403 Expression
(First
(
12404 Pragma_Argument_Associations
(
12406 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
12409 -- Add the _CPU component if a CPU rep item is present
12411 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
12413 Make_Component_Declaration
(Loc
,
12414 Defining_Identifier
=>
12415 Make_Defining_Identifier
(Loc
, Name_uCPU
),
12417 Component_Definition
=>
12418 Make_Component_Definition
(Loc
,
12419 Aliased_Present
=> False,
12420 Subtype_Indication
=>
12421 New_Occurrence_Of
(RTE
(RE_CPU_Range
), Loc
))));
12424 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12425 -- present. If we are using a restricted run time this component will
12426 -- not be added (deadlines are not allowed by the Ravenscar profile),
12427 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
12430 if (not Restricted_Profile
or else Task_Dispatching_Policy
= 'E')
12431 and then Present
(Taskdef
)
12432 and then Has_Relative_Deadline_Pragma
(Taskdef
)
12435 Make_Component_Declaration
(Loc
,
12436 Defining_Identifier
=>
12437 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
12439 Component_Definition
=>
12440 Make_Component_Definition
(Loc
,
12441 Aliased_Present
=> False,
12442 Subtype_Indication
=>
12443 New_Occurrence_Of
(RTE
(RE_Time_Span
), Loc
)),
12446 Convert_To
(RTE
(RE_Time_Span
),
12448 Expression
(First
(
12449 Pragma_Argument_Associations
(
12450 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
12453 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12454 -- item is present. If we are using a restricted run time this component
12455 -- will not be added (dispatching domains are not allowed by the
12456 -- Ravenscar profile).
12458 if not Restricted_Profile
12461 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
12464 Make_Component_Declaration
(Loc
,
12465 Defining_Identifier
=>
12466 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
12468 Component_Definition
=>
12469 Make_Component_Definition
(Loc
,
12470 Aliased_Present
=> False,
12471 Subtype_Indication
=>
12473 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
12476 Insert_After
(Size_Decl
, Rec_Decl
);
12478 -- Analyze the record declaration immediately after construction,
12479 -- because the initialization procedure is needed for single task
12480 -- declarations before the next entity is analyzed.
12482 Analyze
(Rec_Decl
);
12484 -- Create the declaration of the task body procedure
12486 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
12488 Make_Subprogram_Declaration
(Loc
,
12489 Specification
=> Proc_Spec
);
12490 Set_Is_Task_Body_Procedure
(Body_Decl
);
12492 Insert_After
(Rec_Decl
, Body_Decl
);
12494 -- The subprogram does not comes from source, so we have to indicate the
12495 -- need for debugging information explicitly.
12497 if Comes_From_Source
(Original_Node
(N
)) then
12498 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
12501 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12502 -- the corresponding record has been frozen.
12504 if Ada_Version
>= Ada_2005
then
12505 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
12508 -- Ada 2005 (AI-345): We must defer freezing to allow further
12509 -- declaration of primitive subprograms covering task interfaces
12511 if Ada_Version
<= Ada_95
then
12513 -- Now we can freeze the corresponding record. This needs manually
12514 -- freezing, since it is really part of the task type, and the task
12515 -- type is frozen at this stage. We of course need the initialization
12516 -- procedure for this corresponding record type and we won't get it
12517 -- in time if we don't freeze now.
12519 Insert_List_After
(Body_Decl
, List
=> Freeze_Entity
(Rec_Ent
, N
));
12522 -- Complete the expansion of access types to the current task type, if
12523 -- any were declared.
12525 Expand_Previous_Access_Type
(Tasktyp
);
12527 -- Create wrappers for entries that have contract cases, preconditions
12528 -- and postconditions.
12534 Ent
:= First_Entity
(Tasktyp
);
12535 while Present
(Ent
) loop
12536 if Ekind
(Ent
) in E_Entry | E_Entry_Family
then
12537 Build_Contract_Wrapper
(Ent
, N
);
12543 end Expand_N_Task_Type_Declaration
;
12545 -------------------------------
12546 -- Expand_N_Timed_Entry_Call --
12547 -------------------------------
12549 -- A timed entry call in normal case is not implemented using ATC mechanism
12550 -- anymore for efficiency reason.
12560 -- is expanded as follows:
12562 -- 1) When T.E is a task entry_call;
12566 -- X : Task_Entry_Index := <entry index>;
12567 -- DX : Duration := To_Duration (D);
12568 -- M : Delay_Mode := <discriminant>;
12569 -- P : parms := (parm, parm, parm);
12572 -- Timed_Protected_Entry_Call
12573 -- (<acceptor-task>, X, P'Address, DX, M, B);
12581 -- 2) When T.E is a protected entry_call;
12585 -- X : Protected_Entry_Index := <entry index>;
12586 -- DX : Duration := To_Duration (D);
12587 -- M : Delay_Mode := <discriminant>;
12588 -- P : parms := (parm, parm, parm);
12591 -- Timed_Protected_Entry_Call
12592 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12600 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12601 -- is no delay and the triggering statements are executed. We first
12602 -- determine the kind of the triggering call and then execute a
12603 -- synchronized operation or a direct call.
12606 -- B : Boolean := False;
12607 -- C : Ada.Tags.Prim_Op_Kind;
12608 -- DX : Duration := To_Duration (D)
12609 -- K : Ada.Tags.Tagged_Kind :=
12610 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12611 -- M : Integer :=...;
12612 -- P : Parameters := (Param1 .. ParamN);
12616 -- if K = Ada.Tags.TK_Limited_Tagged
12617 -- or else K = Ada.Tags.TK_Tagged
12619 -- <dispatching-call>;
12624 -- Ada.Tags.Get_Offset_Index
12625 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12627 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12629 -- if C = POK_Protected_Entry
12630 -- or else C = POK_Task_Entry
12632 -- Param1 := P.Param1;
12634 -- ParamN := P.ParamN;
12638 -- if C = POK_Procedure
12639 -- or else C = POK_Protected_Procedure
12640 -- or else C = POK_Task_Procedure
12642 -- <dispatching-call>;
12648 -- <triggering-statements>
12650 -- <timed-statements>
12654 -- The triggering statement and the sequence of timed statements have not
12655 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12656 -- global references if within an instantiation.
12658 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
12660 Blk_Typ
: Entity_Id
;
12662 Call_Ent
: Entity_Id
;
12663 Conc_Typ_Stmts
: List_Id
;
12664 Concval
: Node_Id
:= Empty
; -- init to avoid warning
12665 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
12668 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
12670 D_Type
: Entity_Id
;
12673 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
12674 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
12679 Is_Disp_Select
: Boolean;
12680 Lim_Typ_Stmts
: List_Id
;
12681 Loc
: constant Source_Ptr
:= Sloc
(D_Stat
);
12690 B
: Entity_Id
; -- Call status flag
12691 C
: Entity_Id
; -- Call kind
12692 D
: Entity_Id
; -- Delay
12693 K
: Entity_Id
; -- Tagged kind
12694 M
: Entity_Id
; -- Delay mode
12695 P
: Entity_Id
; -- Parameter block
12696 S
: Entity_Id
; -- Primitive operation slot
12698 -- Start of processing for Expand_N_Timed_Entry_Call
12701 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12702 -- was already reported on spec, so do not attempt to expand the call.
12704 if Restriction_Active
(No_Select_Statements
) then
12708 Process_Statements_For_Controlled_Objects
(E_Alt
);
12709 Process_Statements_For_Controlled_Objects
(D_Alt
);
12711 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
12713 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12714 -- may wrap them in blocks.
12716 E_Stats
:= Statements
(E_Alt
);
12717 D_Stats
:= Statements
(D_Alt
);
12719 -- The arguments in the call may require dynamic allocation, and the
12720 -- call statement may have been transformed into a block. The block
12721 -- may contain additional declarations for internal entities, and the
12722 -- original call is found by sequential search.
12724 if Nkind
(E_Call
) = N_Block_Statement
then
12725 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
12726 while Nkind
(E_Call
) not in
12727 N_Procedure_Call_Statement | N_Entry_Call_Statement
12734 Ada_Version
>= Ada_2005
12735 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
12737 if Is_Disp_Select
then
12738 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
12744 -- B : Boolean := False;
12746 B
:= Build_B
(Loc
, Decls
);
12749 -- C : Ada.Tags.Prim_Op_Kind;
12751 C
:= Build_C
(Loc
, Decls
);
12753 -- Because the analysis of all statements was disabled, manually
12754 -- analyze the delay statement.
12757 D_Stat
:= Original_Node
(D_Stat
);
12760 -- Build an entry call using Simple_Entry_Call
12762 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
12763 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
12765 Decls
:= Declarations
(E_Call
);
12766 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
12775 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12778 Make_Object_Declaration
(Loc
,
12779 Defining_Identifier
=> B
,
12780 Object_Definition
=>
12781 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
12784 -- Duration and mode processing
12786 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12788 -- Use the type of the delay expression (Calendar or Real_Time) to
12789 -- generate the appropriate conversion.
12791 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12792 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12793 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12795 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12796 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12798 Make_Function_Call
(Loc
,
12799 Name
=> New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
12800 Parameter_Associations
=>
12801 New_List
(New_Copy
(Expression
(D_Stat
))));
12803 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12804 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12806 Make_Function_Call
(Loc
,
12807 Name
=> New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
12808 Parameter_Associations
=>
12809 New_List
(New_Copy
(Expression
(D_Stat
))));
12812 D
:= Make_Temporary
(Loc
, 'D');
12818 Make_Object_Declaration
(Loc
,
12819 Defining_Identifier
=> D
,
12820 Object_Definition
=> New_Occurrence_Of
(Standard_Duration
, Loc
)));
12822 M
:= Make_Temporary
(Loc
, 'M');
12825 -- M : Integer := (0 | 1 | 2);
12828 Make_Object_Declaration
(Loc
,
12829 Defining_Identifier
=> M
,
12830 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
12831 Expression
=> D_Disc
));
12833 -- Parameter block processing
12835 -- Manually create the parameter block for dispatching calls. In the
12836 -- case of entries, the block has already been created during the call
12837 -- to Build_Simple_Entry_Call.
12839 if Is_Disp_Select
then
12841 -- Compute the delay at this stage because the evaluation of its
12842 -- expression must not occur earlier (see ACVC C97302A).
12845 Make_Assignment_Statement
(Loc
,
12846 Name
=> New_Occurrence_Of
(D
, Loc
),
12847 Expression
=> D_Conv
));
12849 -- Tagged kind processing, generate:
12850 -- K : Ada.Tags.Tagged_Kind :=
12851 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12853 K
:= Build_K
(Loc
, Decls
, Obj
);
12855 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12857 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12859 -- Dispatch table slot processing, generate:
12862 S
:= Build_S
(Loc
, Decls
);
12865 -- S := Ada.Tags.Get_Offset_Index
12866 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12869 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12872 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12874 -- where Obj is the controlling formal parameter, S is the dispatch
12875 -- table slot number of the dispatching operation, P is the wrapped
12876 -- parameter block, D is the duration, M is the duration mode, C is
12877 -- the call kind and B is the call status.
12879 Params
:= New_List
;
12881 Append_To
(Params
, New_Copy_Tree
(Obj
));
12882 Append_To
(Params
, New_Occurrence_Of
(S
, Loc
));
12884 Make_Attribute_Reference
(Loc
,
12885 Prefix
=> New_Occurrence_Of
(P
, Loc
),
12886 Attribute_Name
=> Name_Address
));
12887 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12888 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12889 Append_To
(Params
, New_Occurrence_Of
(C
, Loc
));
12890 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12892 Append_To
(Conc_Typ_Stmts
,
12893 Make_Procedure_Call_Statement
(Loc
,
12897 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12898 Parameter_Associations
=> Params
));
12901 -- if C = POK_Protected_Entry
12902 -- or else C = POK_Task_Entry
12904 -- Param1 := P.Param1;
12906 -- ParamN := P.ParamN;
12909 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12911 -- Generate the if statement only when the packed parameters need
12912 -- explicit assignments to their corresponding actuals.
12914 if Present
(Unpack
) then
12915 Append_To
(Conc_Typ_Stmts
,
12916 Make_Implicit_If_Statement
(N
,
12922 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12925 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12929 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12931 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
12933 Then_Statements
=> Unpack
));
12939 -- if C = POK_Procedure
12940 -- or else C = POK_Protected_Procedure
12941 -- or else C = POK_Task_Procedure
12943 -- <dispatching-call>
12947 N_Stats
:= New_List
(
12948 Make_Implicit_If_Statement
(N
,
12953 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12955 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
12961 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12963 New_Occurrence_Of
(RTE
(
12964 RE_POK_Protected_Procedure
), Loc
)),
12967 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12970 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12972 Then_Statements
=> New_List
(E_Call
)));
12974 Append_To
(Conc_Typ_Stmts
,
12975 Make_Implicit_If_Statement
(N
,
12976 Condition
=> New_Occurrence_Of
(B
, Loc
),
12977 Then_Statements
=> N_Stats
));
12980 -- <dispatching-call>;
12984 New_List
(New_Copy_Tree
(E_Call
),
12985 Make_Assignment_Statement
(Loc
,
12986 Name
=> New_Occurrence_Of
(B
, Loc
),
12987 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12990 -- if K = Ada.Tags.TK_Limited_Tagged
12991 -- or else K = Ada.Tags.TK_Tagged
12999 Make_Implicit_If_Statement
(N
,
13000 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
13001 Then_Statements
=> Lim_Typ_Stmts
,
13002 Else_Statements
=> Conc_Typ_Stmts
));
13007 -- <triggering-statements>
13009 -- <timed-statements>
13013 Make_Implicit_If_Statement
(N
,
13014 Condition
=> New_Occurrence_Of
(B
, Loc
),
13015 Then_Statements
=> E_Stats
,
13016 Else_Statements
=> D_Stats
));
13019 -- Simple case of a nondispatching trigger. Skip assignments to
13020 -- temporaries created for in-out parameters.
13022 -- This makes unwarranted assumptions about the shape of the expanded
13023 -- tree for the call, and should be cleaned up ???
13025 Stmt
:= First
(Stmts
);
13026 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
13030 -- Compute the delay at this stage because the evaluation of
13031 -- its expression must not occur earlier (see ACVC C97302A).
13033 Insert_Before
(Stmt
,
13034 Make_Assignment_Statement
(Loc
,
13035 Name
=> New_Occurrence_Of
(D
, Loc
),
13036 Expression
=> D_Conv
));
13039 Params
:= Parameter_Associations
(Call
);
13041 -- For a protected type, we build a Timed_Protected_Entry_Call
13043 if Is_Protected_Type
(Etype
(Concval
)) then
13045 -- Create a new call statement
13047 Param
:= First
(Params
);
13048 while Present
(Param
)
13049 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
13054 Dummy
:= Remove_Next
(Next
(Param
));
13056 -- Remove garbage is following the Cancel_Param if present
13058 Dummy
:= Next
(Param
);
13060 -- Remove the mode of the Protected_Entry_Call call, then remove
13061 -- the Communication_Block of the Protected_Entry_Call call, and
13062 -- finally add Duration and a Delay_Mode parameter
13064 pragma Assert
(Present
(Param
));
13065 Rewrite
(Param
, New_Occurrence_Of
(D
, Loc
));
13067 Rewrite
(Dummy
, New_Occurrence_Of
(M
, Loc
));
13069 -- Add a Boolean flag for successful entry call
13071 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
13073 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
13074 when System_Tasking_Protected_Objects_Entries
=>
13076 Make_Procedure_Call_Statement
(Loc
,
13079 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
13080 Parameter_Associations
=> Params
));
13083 raise Program_Error
;
13086 -- For the task case, build a Timed_Task_Entry_Call
13089 -- Create a new call statement
13091 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
13092 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
13093 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
13096 Make_Procedure_Call_Statement
(Loc
,
13098 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
13099 Parameter_Associations
=> Params
));
13103 Make_Implicit_If_Statement
(N
,
13104 Condition
=> New_Occurrence_Of
(B
, Loc
),
13105 Then_Statements
=> E_Stats
,
13106 Else_Statements
=> D_Stats
));
13110 Make_Block_Statement
(Loc
,
13111 Declarations
=> Decls
,
13112 Handled_Statement_Sequence
=>
13113 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
13117 -- Some items in Decls used to be in the N_Block in E_Call that is
13118 -- constructed in Expand_Entry_Call, and are now in the new Block
13119 -- into which N has been rewritten. Adjust their scopes to reflect that.
13121 if Nkind
(E_Call
) = N_Block_Statement
then
13122 Obj
:= First_Entity
(Entity
(Identifier
(E_Call
)));
13123 while Present
(Obj
) loop
13124 Set_Scope
(Obj
, Entity
(Identifier
(N
)));
13129 Reset_Scopes_To
(N
, Entity
(Identifier
(N
)));
13130 end Expand_N_Timed_Entry_Call
;
13132 ----------------------------------------
13133 -- Expand_Protected_Body_Declarations --
13134 ----------------------------------------
13136 procedure Expand_Protected_Body_Declarations
13138 Spec_Id
: Entity_Id
)
13141 if No_Run_Time_Mode
then
13142 Error_Msg_CRT
("protected body", N
);
13145 elsif Expander_Active
then
13147 -- Associate discriminals with the first subprogram or entry body to
13150 if Present
(First_Protected_Operation
(Declarations
(N
))) then
13151 Set_Discriminals
(Parent
(Spec_Id
));
13154 end Expand_Protected_Body_Declarations
;
13156 -------------------------
13157 -- External_Subprogram --
13158 -------------------------
13160 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
13161 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
13164 -- The internal and external subprograms follow each other on the entity
13165 -- chain. Note that previously private operations had no separate
13166 -- external subprogram. We now create one in all cases, because a
13167 -- private operation may actually appear in an external call, through
13168 -- a 'Access reference used for a callback.
13170 -- If the operation is a function that returns an anonymous access type,
13171 -- the corresponding itype appears before the operation, and must be
13174 -- This mechanism is fragile, there should be a real link between the
13175 -- two versions of the operation, but there is no place to put it ???
13177 if Is_Access_Type
(Next_Entity
(Subp
)) then
13178 return Next_Entity
(Next_Entity
(Subp
));
13180 return Next_Entity
(Subp
);
13182 end External_Subprogram
;
13184 ------------------------------
13185 -- Extract_Dispatching_Call --
13186 ------------------------------
13188 procedure Extract_Dispatching_Call
13190 Call_Ent
: out Entity_Id
;
13191 Object
: out Entity_Id
;
13192 Actuals
: out List_Id
;
13193 Formals
: out List_Id
)
13195 Call_Nam
: Node_Id
;
13198 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
13200 if Present
(Original_Node
(N
)) then
13201 Call_Nam
:= Name
(Original_Node
(N
));
13203 Call_Nam
:= Name
(N
);
13206 -- Retrieve the name of the dispatching procedure. It contains the
13207 -- dispatch table slot number.
13210 case Nkind
(Call_Nam
) is
13211 when N_Identifier
=>
13214 when N_Selected_Component
=>
13215 Call_Nam
:= Selector_Name
(Call_Nam
);
13218 raise Program_Error
;
13222 Actuals
:= Parameter_Associations
(N
);
13223 Call_Ent
:= Entity
(Call_Nam
);
13224 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
13225 Object
:= First
(Actuals
);
13227 if Present
(Original_Node
(Object
)) then
13228 Object
:= Original_Node
(Object
);
13231 -- If the type of the dispatching object is an access type then return
13232 -- an explicit dereference of a copy of the object, and note that this
13233 -- is the controlling actual of the call.
13235 if Is_Access_Type
(Etype
(Object
)) then
13237 Make_Explicit_Dereference
(Sloc
(N
), New_Copy_Tree
(Object
));
13239 Set_Is_Controlling_Actual
(Object
);
13241 end Extract_Dispatching_Call
;
13243 -------------------
13244 -- Extract_Entry --
13245 -------------------
13247 procedure Extract_Entry
13249 Concval
: out Node_Id
;
13250 Ename
: out Node_Id
;
13251 Index
: out Node_Id
)
13253 Nam
: constant Node_Id
:= Name
(N
);
13256 -- For a simple entry, the name is a selected component, with the
13257 -- prefix being the task value, and the selector being the entry.
13259 if Nkind
(Nam
) = N_Selected_Component
then
13260 Concval
:= Prefix
(Nam
);
13261 Ename
:= Selector_Name
(Nam
);
13264 -- For a member of an entry family, the name is an indexed component
13265 -- where the prefix is a selected component, whose prefix in turn is
13266 -- the task value, and whose selector is the entry family. The single
13267 -- expression in the expressions list of the indexed component is the
13268 -- subscript for the family.
13270 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
13271 Concval
:= Prefix
(Prefix
(Nam
));
13272 Ename
:= Selector_Name
(Prefix
(Nam
));
13273 Index
:= First
(Expressions
(Nam
));
13276 -- Through indirection, the type may actually be a limited view of a
13277 -- concurrent type. When compiling a call, the non-limited view of the
13278 -- type is visible.
13280 if From_Limited_With
(Etype
(Concval
)) then
13281 Set_Etype
(Concval
, Non_Limited_View
(Etype
(Concval
)));
13285 -------------------
13286 -- Family_Offset --
13287 -------------------
13289 function Family_Offset
13294 Cap
: Boolean) return Node_Id
13300 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
13301 -- If one of the bounds is a reference to a discriminant, replace with
13302 -- corresponding discriminal of type. Within the body of a task retrieve
13303 -- the renamed discriminant by simple visibility, using its generated
13304 -- name. Within a protected object, find the original discriminant and
13305 -- replace it with the discriminal of the current protected operation.
13307 ------------------------------
13308 -- Convert_Discriminant_Ref --
13309 ------------------------------
13311 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
13312 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
13317 if Is_Entity_Name
(Bound
)
13318 and then Ekind
(Entity
(Bound
)) = E_Discriminant
13320 if Is_Task_Type
(Ttyp
) and then Has_Completion
(Ttyp
) then
13321 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13322 Find_Direct_Name
(B
);
13324 elsif Is_Protected_Type
(Ttyp
) then
13325 D
:= First_Discriminant
(Ttyp
);
13326 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
13327 Next_Discriminant
(D
);
13330 B
:= New_Occurrence_Of
(Discriminal
(D
), Loc
);
13333 B
:= New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
13336 elsif Nkind
(Bound
) = N_Attribute_Reference
then
13340 B
:= New_Copy_Tree
(Bound
);
13344 Make_Attribute_Reference
(Loc
,
13345 Attribute_Name
=> Name_Pos
,
13346 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
13347 Expressions
=> New_List
(B
));
13348 end Convert_Discriminant_Ref
;
13350 -- Start of processing for Family_Offset
13353 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
13354 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
13357 if Is_Task_Type
(Ttyp
) then
13358 Ityp
:= RTE
(RE_Task_Entry_Index
);
13360 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13364 Make_Attribute_Reference
(Loc
,
13365 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13366 Attribute_Name
=> Name_Min
,
13367 Expressions
=> New_List
(
13369 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
13372 Make_Attribute_Reference
(Loc
,
13373 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13374 Attribute_Name
=> Name_Max
,
13375 Expressions
=> New_List
(
13377 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
13380 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
13387 function Family_Size
13392 Cap
: Boolean) return Node_Id
13397 if Is_Task_Type
(Ttyp
) then
13398 Ityp
:= RTE
(RE_Task_Entry_Index
);
13400 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13404 Make_Attribute_Reference
(Loc
,
13405 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13406 Attribute_Name
=> Name_Max
,
13407 Expressions
=> New_List
(
13409 Left_Opnd
=> Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
13410 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
13411 Make_Integer_Literal
(Loc
, 0)));
13414 ----------------------------
13415 -- Find_Enclosing_Context --
13416 ----------------------------
13418 procedure Find_Enclosing_Context
13420 Context
: out Node_Id
;
13421 Context_Id
: out Entity_Id
;
13422 Context_Decls
: out List_Id
)
13425 -- Traverse the parent chain looking for an enclosing body, block,
13426 -- package or return statement.
13428 Context
:= Parent
(N
);
13429 while Present
(Context
) loop
13430 if Nkind
(Context
) in N_Entry_Body
13431 | N_Extended_Return_Statement
13433 | N_Package_Declaration
13434 | N_Subprogram_Body
13439 -- Do not consider block created to protect a list of statements with
13440 -- an Abort_Defer / Abort_Undefer_Direct pair.
13442 elsif Nkind
(Context
) = N_Block_Statement
13443 and then not Is_Abort_Block
(Context
)
13448 Context
:= Parent
(Context
);
13451 pragma Assert
(Present
(Context
));
13453 -- Extract the constituents of the context
13455 if Nkind
(Context
) = N_Extended_Return_Statement
then
13456 Context_Decls
:= Return_Object_Declarations
(Context
);
13457 Context_Id
:= Return_Statement_Entity
(Context
);
13459 -- Package declarations and bodies use a common library-level activation
13460 -- chain or task master, therefore return the package declaration as the
13461 -- proper carrier for the appropriate flag.
13463 elsif Nkind
(Context
) = N_Package_Body
then
13464 Context_Decls
:= Declarations
(Context
);
13465 Context_Id
:= Corresponding_Spec
(Context
);
13466 Context
:= Parent
(Context_Id
);
13468 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
13469 Context
:= Parent
(Parent
(Context
));
13471 Context
:= Parent
(Context
);
13474 elsif Nkind
(Context
) = N_Package_Declaration
then
13475 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
13476 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13478 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13479 Context_Id
:= Defining_Identifier
(Context_Id
);
13483 if Nkind
(Context
) = N_Block_Statement
then
13484 Context_Id
:= Entity
(Identifier
(Context
));
13486 if No
(Declarations
(Context
)) then
13487 Set_Declarations
(Context
, New_List
);
13490 elsif Nkind
(Context
) = N_Entry_Body
then
13491 Context_Id
:= Defining_Identifier
(Context
);
13493 elsif Nkind
(Context
) = N_Subprogram_Body
then
13494 if Present
(Corresponding_Spec
(Context
)) then
13495 Context_Id
:= Corresponding_Spec
(Context
);
13497 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13499 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13500 Context_Id
:= Defining_Identifier
(Context_Id
);
13504 elsif Nkind
(Context
) = N_Task_Body
then
13505 Context_Id
:= Corresponding_Spec
(Context
);
13508 raise Program_Error
;
13511 Context_Decls
:= Declarations
(Context
);
13514 pragma Assert
(Present
(Context_Id
));
13515 pragma Assert
(Present
(Context_Decls
));
13516 end Find_Enclosing_Context
;
13518 -----------------------
13519 -- Find_Master_Scope --
13520 -----------------------
13522 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
13526 -- In Ada 2005, the master is the innermost enclosing scope that is not
13527 -- transient. If the enclosing block is the rewriting of a call or the
13528 -- scope is an extended return statement this is valid master. The
13529 -- master in an extended return is only used within the return, and is
13530 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13531 -- now before that overwriting occurs.
13535 if Ada_Version
>= Ada_2005
then
13536 while Is_Internal
(S
) loop
13537 if Nkind
(Parent
(S
)) = N_Block_Statement
13538 and then Has_Master_Entity
(S
)
13542 elsif Ekind
(S
) = E_Return_Statement
then
13552 end Find_Master_Scope
;
13554 -------------------------------
13555 -- First_Protected_Operation --
13556 -------------------------------
13558 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
13559 First_Op
: Node_Id
;
13562 First_Op
:= First
(D
);
13563 while Present
(First_Op
)
13564 and then Nkind
(First_Op
) not in N_Subprogram_Body | N_Entry_Body
13570 end First_Protected_Operation
;
13572 ---------------------------------------
13573 -- Install_Private_Data_Declarations --
13574 ---------------------------------------
13576 procedure Install_Private_Data_Declarations
13578 Spec_Id
: Entity_Id
;
13579 Conc_Typ
: Entity_Id
;
13580 Body_Nod
: Node_Id
;
13582 Barrier
: Boolean := False;
13583 Family
: Boolean := False)
13585 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
13588 Insert_Node
: Node_Id
:= Empty
;
13589 Obj_Ent
: Entity_Id
;
13591 procedure Add
(Decl
: Node_Id
);
13592 -- Add a single declaration after Insert_Node. If this is the first
13593 -- addition, Decl is added to the front of Decls and it becomes the
13596 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
13597 -- The bounds of an entry index may depend on discriminants, create a
13598 -- reference to the corresponding prival. Otherwise return a duplicate
13599 -- of the original bound.
13605 procedure Add
(Decl
: Node_Id
) is
13607 if No
(Insert_Node
) then
13608 Prepend_To
(Decls
, Decl
);
13610 Insert_After
(Insert_Node
, Decl
);
13613 Insert_Node
:= Decl
;
13616 -------------------
13617 -- Replace_Bound --
13618 -------------------
13620 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
13622 if Nkind
(Bound
) = N_Identifier
13623 and then Is_Discriminal
(Entity
(Bound
))
13625 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13627 return Duplicate_Subexpr
(Bound
);
13631 -- Start of processing for Install_Private_Data_Declarations
13634 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13635 -- formal parameter _O, _object or _task depending on the context.
13637 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
13639 -- Special processing of _O for barrier functions, protected entries
13646 (Ekind
(Spec_Id
) = E_Entry
13647 or else Ekind
(Spec_Id
) = E_Entry_Family
))
13650 Conc_Rec
: constant Entity_Id
:=
13651 Corresponding_Record_Type
(Conc_Typ
);
13652 Typ_Id
: constant Entity_Id
:=
13653 Make_Defining_Identifier
(Loc
,
13654 New_External_Name
(Chars
(Conc_Rec
), 'P'));
13657 -- type prot_typVP is access prot_typV;
13660 Make_Full_Type_Declaration
(Loc
,
13661 Defining_Identifier
=> Typ_Id
,
13663 Make_Access_To_Object_Definition
(Loc
,
13664 Subtype_Indication
=>
13665 New_Occurrence_Of
(Conc_Rec
, Loc
)));
13669 -- _object : prot_typVP := prot_typV (_O);
13672 Make_Object_Declaration
(Loc
,
13673 Defining_Identifier
=>
13674 Make_Defining_Identifier
(Loc
, Name_uObject
),
13675 Object_Definition
=> New_Occurrence_Of
(Typ_Id
, Loc
),
13677 Unchecked_Convert_To
(Typ_Id
,
13678 New_Occurrence_Of
(Obj_Ent
, Loc
)));
13681 -- Set the reference to the concurrent object
13683 Obj_Ent
:= Defining_Identifier
(Decl
);
13687 -- Step 2: Create the Protection object and build its declaration for
13688 -- any protected entry (family) of subprogram. Note for the lock-free
13689 -- implementation, the Protection object is not needed anymore.
13691 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
13693 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
13697 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
13699 -- Determine the proper protection type
13701 if Has_Attach_Handler
(Conc_Typ
)
13702 and then not Restricted_Profile
13704 Prot_Typ
:= RE_Static_Interrupt_Protection
;
13706 elsif Has_Interrupt_Handler
(Conc_Typ
)
13707 and then not Restriction_Active
(No_Dynamic_Attachment
)
13709 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
13712 case Corresponding_Runtime_Package
(Conc_Typ
) is
13713 when System_Tasking_Protected_Objects_Entries
=>
13714 Prot_Typ
:= RE_Protection_Entries
;
13716 when System_Tasking_Protected_Objects_Single_Entry
=>
13717 Prot_Typ
:= RE_Protection_Entry
;
13719 when System_Tasking_Protected_Objects
=>
13720 Prot_Typ
:= RE_Protection
;
13723 raise Program_Error
;
13728 -- conc_typR : protection_typ renames _object._object;
13731 Make_Object_Renaming_Declaration
(Loc
,
13732 Defining_Identifier
=> Prot_Ent
,
13734 New_Occurrence_Of
(RTE
(Prot_Typ
), Loc
),
13736 Make_Selected_Component
(Loc
,
13737 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13738 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
13743 -- Step 3: Add discriminant renamings (if any)
13745 if Has_Discriminants
(Conc_Typ
) then
13750 D
:= First_Discriminant
(Conc_Typ
);
13751 while Present
(D
) loop
13753 -- Adjust the source location
13755 Set_Sloc
(Discriminal
(D
), Loc
);
13758 -- discr_name : discr_typ renames _object.discr_name;
13760 -- discr_name : discr_typ renames _task.discr_name;
13763 Make_Object_Renaming_Declaration
(Loc
,
13764 Defining_Identifier
=> Discriminal
(D
),
13765 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
13767 Make_Selected_Component
(Loc
,
13768 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13769 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
13772 -- Set debug info needed on this renaming declaration even
13773 -- though it does not come from source, so that the debugger
13774 -- will get the right information for these generated names.
13776 Set_Debug_Info_Needed
(Discriminal
(D
));
13778 Next_Discriminant
(D
);
13783 -- Step 4: Add private component renamings (if any)
13785 if Is_Protected
then
13786 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
13788 if Present
(Private_Declarations
(Def
)) then
13791 Comp_Id
: Entity_Id
;
13792 Decl_Id
: Entity_Id
;
13796 Comp
:= First
(Private_Declarations
(Def
));
13797 while Present
(Comp
) loop
13798 if Nkind
(Comp
) = N_Component_Declaration
then
13799 Comp_Id
:= Defining_Identifier
(Comp
);
13800 Nam
:= Chars
(Comp_Id
);
13801 Decl_Id
:= Make_Defining_Identifier
(Sloc
(Comp_Id
), Nam
);
13803 -- Minimal decoration
13805 if Ekind
(Spec_Id
) = E_Function
then
13806 Mutate_Ekind
(Decl_Id
, E_Constant
);
13808 Mutate_Ekind
(Decl_Id
, E_Variable
);
13811 Set_Prival
(Comp_Id
, Decl_Id
);
13812 Set_Prival_Link
(Decl_Id
, Comp_Id
);
13813 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13814 Set_Is_Independent
(Decl_Id
, Is_Independent
(Comp_Id
));
13816 -- Copy the Comes_From_Source flag of the component, as
13817 -- the renaming may be the only entity directly seen by
13818 -- the user in the context, but do not warn for it.
13820 Set_Comes_From_Source
13821 (Decl_Id
, Comes_From_Source
(Comp_Id
));
13822 Set_Warnings_Off
(Decl_Id
);
13825 -- comp_name : comp_typ renames _object.comp_name;
13828 Make_Object_Renaming_Declaration
(Loc
,
13829 Defining_Identifier
=> Decl_Id
,
13831 New_Occurrence_Of
(Etype
(Comp_Id
), Loc
),
13833 Make_Selected_Component
(Loc
,
13834 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13835 Selector_Name
=> Make_Identifier
(Loc
, Nam
)));
13845 -- Step 5: Add the declaration of the entry index and the associated
13846 -- type for barrier functions and entry families.
13848 if (Barrier
and Family
) or else Ekind
(Spec_Id
) = E_Entry_Family
then
13850 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13851 Index
: constant Entity_Id
:=
13852 Defining_Identifier
13853 (Entry_Index_Specification
13854 (Entry_Body_Formal_Part
(Body_Nod
)));
13855 Index_Con
: constant Entity_Id
:=
13856 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13858 Index_Typ
: Entity_Id
;
13862 -- Minimal decoration
13864 Mutate_Ekind
(Index_Con
, E_Constant
);
13865 Set_Entry_Index_Constant
(Index
, Index_Con
);
13866 Set_Discriminal_Link
(Index_Con
, Index
);
13868 -- Retrieve the bounds of the entry family
13870 High
:= Type_High_Bound
(Etype
(Index
));
13871 Low
:= Type_Low_Bound
(Etype
(Index
));
13873 -- In the simple case the entry family is given by a subtype mark
13874 -- and the index constant has the same type.
13876 if Is_Entity_Name
(Original_Node
(
13877 Discrete_Subtype_Definition
(Parent
(Index
))))
13879 Index_Typ
:= Etype
(Index
);
13881 -- Otherwise a new subtype declaration is required
13884 High
:= Replace_Bound
(High
);
13885 Low
:= Replace_Bound
(Low
);
13887 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13890 -- subtype Jnn is <Etype of Index> range Low .. High;
13893 Make_Subtype_Declaration
(Loc
,
13894 Defining_Identifier
=> Index_Typ
,
13895 Subtype_Indication
=>
13896 Make_Subtype_Indication
(Loc
,
13898 New_Occurrence_Of
(Base_Type
(Etype
(Index
)), Loc
),
13900 Make_Range_Constraint
(Loc
,
13901 Range_Expression
=>
13902 Make_Range
(Loc
, Low
, High
))));
13906 Set_Etype
(Index_Con
, Index_Typ
);
13908 -- Create the object which designates the index:
13909 -- J : constant Jnn :=
13910 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13912 -- where Jnn is the subtype created above or the original type of
13913 -- the index, _E is a formal of the protected body subprogram and
13914 -- <index expr> is the index of the first family member.
13917 Make_Object_Declaration
(Loc
,
13918 Defining_Identifier
=> Index_Con
,
13919 Constant_Present
=> True,
13920 Object_Definition
=>
13921 New_Occurrence_Of
(Index_Typ
, Loc
),
13924 Make_Attribute_Reference
(Loc
,
13926 New_Occurrence_Of
(Index_Typ
, Loc
),
13927 Attribute_Name
=> Name_Val
,
13929 Expressions
=> New_List
(
13933 Make_Op_Subtract
(Loc
,
13934 Left_Opnd
=> New_Occurrence_Of
(E
, Loc
),
13936 Entry_Index_Expression
(Loc
,
13937 Defining_Identifier
(Body_Nod
),
13941 Make_Attribute_Reference
(Loc
,
13943 New_Occurrence_Of
(Index_Typ
, Loc
),
13944 Attribute_Name
=> Name_Pos
,
13945 Expressions
=> New_List
(
13946 Make_Attribute_Reference
(Loc
,
13948 New_Occurrence_Of
(Index_Typ
, Loc
),
13949 Attribute_Name
=> Name_First
)))))));
13953 end Install_Private_Data_Declarations
;
13955 ---------------------------------
13956 -- Is_Potentially_Large_Family --
13957 ---------------------------------
13959 function Is_Potentially_Large_Family
13960 (Base_Index
: Entity_Id
;
13961 Conctyp
: Entity_Id
;
13963 Hi
: Node_Id
) return Boolean
13966 return Scope
(Base_Index
) = Standard_Standard
13967 and then Base_Index
= Base_Type
(Standard_Integer
)
13968 and then Has_Defaulted_Discriminants
(Conctyp
)
13970 (Denotes_Discriminant
(Lo
, True)
13972 Denotes_Discriminant
(Hi
, True));
13973 end Is_Potentially_Large_Family
;
13975 -------------------------------------
13976 -- Is_Private_Primitive_Subprogram --
13977 -------------------------------------
13979 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13982 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13983 and then Is_Private_Primitive
(Id
);
13984 end Is_Private_Primitive_Subprogram
;
13990 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13991 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13992 Formal
: Entity_Id
;
13995 Formal
:= First_Formal
(Bod_Subp
);
13996 while Present
(Formal
) loop
13998 -- Look for formal parameter _E
14000 if Chars
(Formal
) = Name_uE
then
14004 Next_Formal
(Formal
);
14007 -- A protected body subprogram should always have the parameter in
14010 raise Program_Error
;
14013 --------------------------------
14014 -- Make_Initialize_Protection --
14015 --------------------------------
14017 function Make_Initialize_Protection
14018 (Protect_Rec
: Entity_Id
) return List_Id
14020 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
14023 Ptyp
: constant Node_Id
:=
14024 Corresponding_Concurrent_Type
(Protect_Rec
);
14026 L
: constant List_Id
:= New_List
;
14027 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
14028 Prio_Type
: Entity_Id
;
14029 Prio_Var
: Entity_Id
:= Empty
;
14030 Restricted
: constant Boolean := Restricted_Profile
;
14033 -- We may need two calls to properly initialize the object, one to
14034 -- Initialize_Protection, and possibly one to Install_Handlers if we
14035 -- have a pragma Attach_Handler.
14037 -- Get protected declaration. In the case of a task type declaration,
14038 -- this is simply the parent of the protected type entity. In the single
14039 -- protected object declaration, this parent will be the implicit type,
14040 -- and we can find the corresponding single protected object declaration
14041 -- by searching forward in the declaration list in the tree.
14043 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
14044 -- of this type should have been removed during semantic analysis.
14046 Pdec
:= Parent
(Ptyp
);
14047 while Nkind
(Pdec
) not in
14048 N_Protected_Type_Declaration | N_Single_Protected_Declaration
14053 -- Build the parameter list for the call. Note that _Init is the name
14054 -- of the formal for the object to be initialized, which is the task
14055 -- value record itself.
14059 -- For lock-free implementation, skip initializations of the Protection
14062 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14064 -- Object parameter. This is a pointer to the object of type
14065 -- Protection used by the GNARL to control the protected object.
14068 Make_Attribute_Reference
(Loc
,
14070 Make_Selected_Component
(Loc
,
14071 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14072 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
14073 Attribute_Name
=> Name_Unchecked_Access
));
14075 -- Priority parameter. Set to Unspecified_Priority unless there is a
14076 -- Priority rep item, in which case we take the value from the pragma
14077 -- or attribute definition clause, or there is an Interrupt_Priority
14078 -- rep item and no Priority rep item, and we set the ceiling to
14079 -- Interrupt_Priority'Last, an implementation-defined value, see
14082 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
14084 Prio_Clause
: constant Node_Id
:=
14086 (Ptyp
, Name_Priority
, Check_Parents
=> False);
14093 if Nkind
(Prio_Clause
) = N_Pragma
then
14096 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
14098 -- Get_Rep_Item returns either priority pragma
14100 if Pragma_Name
(Prio_Clause
) = Name_Priority
then
14101 Prio_Type
:= RTE
(RE_Any_Priority
);
14103 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
14106 -- Attribute definition clause Priority
14109 if Chars
(Prio_Clause
) = Name_Priority
then
14110 Prio_Type
:= RTE
(RE_Any_Priority
);
14112 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
14115 Prio
:= Expression
(Prio_Clause
);
14118 -- Always create a locale variable to capture the priority.
14119 -- The priority is also passed to Install_Restriced_Handlers.
14120 -- Note that it is really necessary to create this variable
14121 -- explicitly. It might be thought that removing side effects
14122 -- would the appropriate approach, but that could generate
14123 -- declarations improperly placed in the enclosing scope.
14125 Prio_Var
:= Make_Temporary
(Loc
, 'R', Prio
);
14127 Make_Object_Declaration
(Loc
,
14128 Defining_Identifier
=> Prio_Var
,
14129 Object_Definition
=> New_Occurrence_Of
(Prio_Type
, Loc
),
14130 Expression
=> Relocate_Node
(Prio
)));
14132 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14135 -- When no priority is specified but an xx_Handler pragma is, we
14136 -- default to System.Interrupts.Default_Interrupt_Priority, see
14139 elsif Has_Attach_Handler
(Ptyp
)
14140 or else Has_Interrupt_Handler
(Ptyp
)
14143 New_Occurrence_Of
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
14145 -- Normal case, no priority or xx_Handler specified, default priority
14149 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14152 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
14154 if Restricted_Profile
and Task_Dispatching_Policy
= 'E' then
14155 Deadline_Floor
: declare
14156 Item
: constant Node_Id
:=
14158 (Ptyp
, Name_Deadline_Floor
, Check_Parents
=> False);
14160 Deadline
: Node_Id
;
14163 if Present
(Item
) then
14165 -- Pragma Deadline_Floor
14167 if Nkind
(Item
) = N_Pragma
then
14170 (First
(Pragma_Argument_Associations
(Item
)));
14172 -- Attribute definition clause Deadline_Floor
14176 (Nkind
(Item
) = N_Attribute_Definition_Clause
);
14178 Deadline
:= Expression
(Item
);
14181 Append_To
(Args
, Deadline
);
14183 -- Unusual case: default deadline
14187 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14189 end Deadline_Floor
;
14192 -- Test for Compiler_Info parameter. This parameter allows entry body
14193 -- procedures and barrier functions to be called from the runtime. It
14194 -- is a pointer to the record generated by the compiler to represent
14195 -- the protected object.
14197 -- A protected type without entries that covers an interface and
14198 -- overrides the abstract routines with protected procedures is
14199 -- considered equivalent to a protected type with entries in the
14200 -- context of dispatching select statements.
14202 -- Protected types with interrupt handlers (when not using a
14203 -- restricted profile) are also considered equivalent to protected
14204 -- types with entries.
14206 -- The types which are used (Static_Interrupt_Protection and
14207 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14210 Pkg_Id
: constant RTU_Id
:= Corresponding_Runtime_Package
(Ptyp
);
14212 Called_Subp
: RE_Id
;
14216 when System_Tasking_Protected_Objects_Entries
=>
14217 Called_Subp
:= RE_Initialize_Protection_Entries
;
14219 -- Argument Compiler_Info
14222 Make_Attribute_Reference
(Loc
,
14223 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14224 Attribute_Name
=> Name_Address
));
14226 when System_Tasking_Protected_Objects_Single_Entry
=>
14227 Called_Subp
:= RE_Initialize_Protection_Entry
;
14229 -- Argument Compiler_Info
14232 Make_Attribute_Reference
(Loc
,
14233 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14234 Attribute_Name
=> Name_Address
));
14236 when System_Tasking_Protected_Objects
=>
14237 Called_Subp
:= RE_Initialize_Protection
;
14240 raise Program_Error
;
14243 -- Entry_Queue_Maxes parameter. This is an access to an array of
14244 -- naturals representing the entry queue maximums for each entry
14245 -- in the protected type. Zero represents no max. The access is
14246 -- null if there is no limit for all entries (usual case).
14249 and then Pkg_Id
= System_Tasking_Protected_Objects_Entries
14251 if Present
(Entry_Max_Queue_Lengths_Array
(Ptyp
)) then
14253 Make_Attribute_Reference
(Loc
,
14256 (Entry_Max_Queue_Lengths_Array
(Ptyp
), Loc
),
14257 Attribute_Name
=> Name_Unrestricted_Access
));
14259 Append_To
(Args
, Make_Null
(Loc
));
14262 -- Edge cases exist where entry initialization functions are
14263 -- called, but no entries exist, so null is appended.
14265 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14266 Append_To
(Args
, Make_Null
(Loc
));
14269 -- Entry_Bodies parameter. This is a pointer to an array of
14270 -- pointers to the entry body procedures and barrier functions of
14271 -- the object. If the protected type has no entries this object
14272 -- will not exist, in this case, pass a null (it can happen when
14273 -- there are protected interrupt handlers or interfaces).
14276 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
14278 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14279 -- multiple entries).
14282 Make_Attribute_Reference
(Loc
,
14283 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14284 Attribute_Name
=> Name_Unrestricted_Access
));
14286 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14288 -- Find index mapping function (clumsy but ok for now)
14290 while Ekind
(P_Arr
) /= E_Function
loop
14291 Next_Entity
(P_Arr
);
14295 Make_Attribute_Reference
(Loc
,
14296 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14297 Attribute_Name
=> Name_Unrestricted_Access
));
14300 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
14302 -- This is the case where we have a protected object with
14303 -- interfaces and no entries, and the single entry restriction
14304 -- is in effect. We pass a null pointer for the entry
14305 -- parameter because there is no actual entry.
14307 Append_To
(Args
, Make_Null
(Loc
));
14309 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14311 -- This is the case where we have a protected object with no
14313 -- - either interrupt handlers with non restricted profile,
14315 -- Note that the types which are used for interrupt handlers
14316 -- (Static/Dynamic_Interrupt_Protection) are derived from
14317 -- Protection_Entries. We pass two null pointers because there
14318 -- is no actual entry, and the initialization procedure needs
14319 -- both Entry_Bodies and Find_Body_Index.
14321 Append_To
(Args
, Make_Null
(Loc
));
14322 Append_To
(Args
, Make_Null
(Loc
));
14326 Make_Procedure_Call_Statement
(Loc
,
14328 New_Occurrence_Of
(RTE
(Called_Subp
), Loc
),
14329 Parameter_Associations
=> Args
));
14333 if Has_Attach_Handler
(Ptyp
) then
14335 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14336 -- make the following call:
14338 -- Install_Handlers (_object,
14339 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14341 -- or, in the case of Ravenscar:
14343 -- Install_Restricted_Handlers
14344 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14347 Args
: constant List_Id
:= New_List
;
14348 Table
: constant List_Id
:= New_List
;
14349 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
14352 -- Build the Priority parameter (only for ravenscar)
14356 -- Priority comes from a pragma
14358 if Present
(Prio_Var
) then
14359 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14361 -- Priority is the default one
14366 (RTE
(RE_Default_Interrupt_Priority
), Loc
));
14370 -- Build the Attach_Handler table argument
14372 while Present
(Ritem
) loop
14373 if Nkind
(Ritem
) = N_Pragma
14374 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
14377 Handler
: constant Node_Id
:=
14378 First
(Pragma_Argument_Associations
(Ritem
));
14380 Interrupt
: constant Node_Id
:= Next
(Handler
);
14381 Expr
: constant Node_Id
:= Expression
(Interrupt
);
14385 Make_Aggregate
(Loc
, Expressions
=> New_List
(
14386 Unchecked_Convert_To
14387 (RTE
(RE_System_Interrupt_Id
), Expr
),
14388 Make_Attribute_Reference
(Loc
,
14390 Make_Selected_Component
(Loc
,
14392 Make_Identifier
(Loc
, Name_uInit
),
14394 Duplicate_Subexpr_No_Checks
14395 (Expression
(Handler
))),
14396 Attribute_Name
=> Name_Access
))));
14400 Next_Rep_Item
(Ritem
);
14403 -- Append the table argument we just built
14405 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
14407 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14408 -- call to the statements.
14411 -- Call a simplified version of Install_Handlers to be used
14412 -- when the Ravenscar restrictions are in effect
14413 -- (Install_Restricted_Handlers).
14416 Make_Procedure_Call_Statement
(Loc
,
14419 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
14420 Parameter_Associations
=> Args
));
14423 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14425 -- First, prepends the _object argument
14428 Make_Attribute_Reference
(Loc
,
14430 Make_Selected_Component
(Loc
,
14431 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14433 Make_Identifier
(Loc
, Name_uObject
)),
14434 Attribute_Name
=> Name_Unchecked_Access
));
14437 -- Then, insert call to Install_Handlers
14440 Make_Procedure_Call_Statement
(Loc
,
14442 New_Occurrence_Of
(RTE
(RE_Install_Handlers
), Loc
),
14443 Parameter_Associations
=> Args
));
14449 end Make_Initialize_Protection
;
14451 ---------------------------
14452 -- Make_Task_Create_Call --
14453 ---------------------------
14455 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
14456 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
14466 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
14467 Tnam
:= Chars
(Ttyp
);
14469 -- Get task declaration. In the case of a task type declaration, this is
14470 -- simply the parent of the task type entity. In the single task
14471 -- declaration, this parent will be the implicit type, and we can find
14472 -- the corresponding single task declaration by searching forward in the
14473 -- declaration list in the tree.
14475 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14476 -- this type should have been removed during semantic analysis.
14478 Tdec
:= Parent
(Ttyp
);
14479 while Nkind
(Tdec
) not in
14480 N_Task_Type_Declaration | N_Single_Task_Declaration
14485 -- Now we can find the task definition from this declaration
14487 Tdef
:= Task_Definition
(Tdec
);
14489 -- Build the parameter list for the call. Note that _Init is the name
14490 -- of the formal for the object to be initialized, which is the task
14491 -- value record itself.
14495 -- Priority parameter. Set to Unspecified_Priority unless there is a
14496 -- Priority rep item, in which case we take the value from the rep item.
14497 -- Not used on Ravenscar_EDF profile.
14499 if not (Restricted_Profile
and then Task_Dispatching_Policy
= 'E') then
14500 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
14502 Make_Selected_Component
(Loc
,
14503 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14504 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
14507 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14511 -- Optional Stack parameter
14513 if Restricted_Profile
then
14515 -- If the stack has been preallocated by the expander then
14516 -- pass its address. Otherwise, pass a null address.
14518 if Preallocated_Stacks_On_Target
then
14520 Make_Attribute_Reference
(Loc
,
14522 Make_Selected_Component
(Loc
,
14523 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14524 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
14525 Attribute_Name
=> Name_Address
));
14529 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
14533 -- Size parameter. If no Storage_Size pragma is present, then
14534 -- the size is taken from the taskZ variable for the type, which
14535 -- is either Unspecified_Size, or has been reset by the use of
14536 -- a Storage_Size attribute definition clause. If a pragma is
14537 -- present, then the size is taken from the _Size field of the
14538 -- task value record, which was set from the pragma value.
14540 if Present
(Tdef
) and then Has_Storage_Size_Pragma
(Tdef
) then
14542 Make_Selected_Component
(Loc
,
14543 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14544 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
14548 New_Occurrence_Of
(Storage_Size_Variable
(Ttyp
), Loc
));
14551 -- Secondary_Stack parameter used for restricted profiles
14553 if Restricted_Profile
then
14555 -- If the secondary stack has been allocated by the expander then
14556 -- pass its access pointer. Otherwise, pass null.
14558 if Create_Secondary_Stack_For_Task
(Ttyp
) then
14560 Make_Attribute_Reference
(Loc
,
14562 Make_Selected_Component
(Loc
,
14563 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14565 Make_Identifier
(Loc
, Name_uSecondary_Stack
)),
14566 Attribute_Name
=> Name_Unrestricted_Access
));
14569 Append_To
(Args
, Make_Null
(Loc
));
14573 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
14574 -- is a Secondary_Stack_Size pragma, in which case take the value from
14575 -- the pragma. If the restriction No_Secondary_Stack is active then a
14576 -- size of 0 is passed regardless to prevent the allocation of the
14579 if Restriction_Active
(No_Secondary_Stack
) then
14580 Append_To
(Args
, Make_Integer_Literal
(Loc
, 0));
14582 elsif Has_Rep_Pragma
14583 (Ttyp
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
14586 Make_Selected_Component
(Loc
,
14587 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14589 Make_Identifier
(Loc
, Name_uSecondary_Stack_Size
)));
14593 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
14596 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14597 -- Task_Info pragma, in which case we take the value from the pragma.
14599 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
14601 Make_Selected_Component
(Loc
,
14602 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14603 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
14607 New_Occurrence_Of
(RTE
(RE_Unspecified_Task_Info
), Loc
));
14610 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14611 -- in which case we take the value from the rep item. The parameter is
14612 -- passed as an Integer because in the case of unspecified CPU the
14613 -- value is not in the range of CPU_Range.
14615 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
14617 Convert_To
(Standard_Integer
,
14618 Make_Selected_Component
(Loc
,
14619 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14620 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
14623 New_Occurrence_Of
(RTE
(RE_Unspecified_CPU
), Loc
));
14626 if not Restricted_Profile
or else Task_Dispatching_Policy
= 'E' then
14628 -- Deadline parameter. If no Relative_Deadline pragma is present,
14629 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14630 -- the deadline is taken from the _Relative_Deadline field of the
14631 -- task value record, which was set from the pragma value. Note that
14632 -- this parameter must not be generated for the restricted profiles
14633 -- since Ravenscar does not allow deadlines.
14635 -- Case where pragma Relative_Deadline applies: use given value
14637 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
14639 Make_Selected_Component
(Loc
,
14640 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14642 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
14644 -- No pragma Relative_Deadline apply to the task
14648 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14652 if not Restricted_Profile
then
14654 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14655 -- present, then the dispatching domain is null. If a rep item is
14656 -- present, then the dispatching domain is taken from the
14657 -- _Dispatching_Domain field of the task value record, which was set
14658 -- from the rep item value.
14660 -- Case where Dispatching_Domain rep item applies: use given value
14663 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
14666 Make_Selected_Component
(Loc
,
14668 Make_Identifier
(Loc
, Name_uInit
),
14670 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
14672 -- No pragma or aspect Dispatching_Domain applies to the task
14675 Append_To
(Args
, Make_Null
(Loc
));
14678 -- Number of entries. This is an expression of the form:
14680 -- n + _Init.a'Length + _Init.a'B'Length + ...
14682 -- where a,b... are the entry family names for the task definition
14685 Build_Entry_Count_Expression
14690 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
14692 Append_To
(Args
, Ecount
);
14694 -- Master parameter. This is a reference to the _Master parameter of
14695 -- the initialization procedure, except in the case of the pragma
14696 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14697 -- System.Tasking.Library_Task_Level.
14699 if Restriction_Active
(No_Task_Hierarchy
) = False then
14700 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
14702 Append_To
(Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
14706 -- State parameter. This is a pointer to the task body procedure. The
14707 -- required value is obtained by taking 'Unrestricted_Access of the task
14708 -- body procedure and converting it (with an unchecked conversion) to
14709 -- the type required by the task kernel. For further details, see the
14710 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14711 -- than 'Address in order to avoid creating trampolines.
14714 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
14715 Subp_Ptr_Typ
: constant Node_Id
:=
14716 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
14717 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
14720 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
14721 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
14723 -- Be sure to freeze a reference to the access-to-subprogram type,
14724 -- otherwise gigi will complain that it's in the wrong scope, because
14725 -- it's actually inside the init procedure for the record type that
14726 -- corresponds to the task type.
14728 Set_Itype
(Ref
, Subp_Ptr_Typ
);
14729 Append_Freeze_Action
(Task_Rec
, Ref
);
14732 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
14733 Make_Qualified_Expression
(Loc
,
14734 Subtype_Mark
=> New_Occurrence_Of
(Subp_Ptr_Typ
, Loc
),
14736 Make_Attribute_Reference
(Loc
,
14737 Prefix
=> New_Occurrence_Of
(Body_Proc
, Loc
),
14738 Attribute_Name
=> Name_Unrestricted_Access
))));
14741 -- Discriminants parameter. This is just the address of the task
14742 -- value record itself (which contains the discriminant values
14745 Make_Attribute_Reference
(Loc
,
14746 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14747 Attribute_Name
=> Name_Address
));
14749 -- Elaborated parameter. This is an access to the elaboration Boolean
14752 Make_Attribute_Reference
(Loc
,
14753 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
14754 Attribute_Name
=> Name_Unchecked_Access
));
14756 -- Add Chain parameter (not done for sequential elaboration policy, see
14757 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14759 if Partition_Elaboration_Policy
/= 'S' then
14760 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
14763 -- Task name parameter. Take this from the _Task_Id parameter to the
14764 -- init call unless there is a Task_Name pragma, in which case we take
14765 -- the value from the pragma.
14767 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
14768 -- Copy expression in full, because it may be dynamic and have
14775 (Pragma_Argument_Associations
14777 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
14780 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
14783 -- Created_Task parameter. This is the _Task_Id field of the task
14787 Make_Selected_Component
(Loc
,
14788 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14789 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
14795 if Restricted_Profile
then
14796 if Partition_Elaboration_Policy
= 'S' then
14797 Create_RE
:= RE_Create_Restricted_Task_Sequential
;
14799 Create_RE
:= RE_Create_Restricted_Task
;
14802 Create_RE
:= RE_Create_Task
;
14805 Name
:= New_Occurrence_Of
(RTE
(Create_RE
), Loc
);
14809 Make_Procedure_Call_Statement
(Loc
,
14811 Parameter_Associations
=> Args
);
14812 end Make_Task_Create_Call
;
14814 ------------------------------
14815 -- Next_Protected_Operation --
14816 ------------------------------
14818 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
14822 -- Check whether there is a subsequent body for a protected operation
14823 -- in the current protected body. In Ada2012 that includes expression
14824 -- functions that are completions.
14826 Next_Op
:= Next
(N
);
14827 while Present
(Next_Op
)
14828 and then Nkind
(Next_Op
) not in
14829 N_Subprogram_Body | N_Entry_Body | N_Expression_Function
14835 end Next_Protected_Operation
;
14837 ---------------------
14838 -- Null_Statements --
14839 ---------------------
14841 function Null_Statements
(Stats
: List_Id
) return Boolean is
14845 Stmt
:= First
(Stats
);
14846 while Nkind
(Stmt
) /= N_Empty
14847 and then (Nkind
(Stmt
) in N_Null_Statement | N_Label
14849 (Nkind
(Stmt
) = N_Pragma
14851 Pragma_Name_Unmapped
(Stmt
) in Name_Unreferenced
14858 return Nkind
(Stmt
) = N_Empty
;
14859 end Null_Statements
;
14861 --------------------------
14862 -- Parameter_Block_Pack --
14863 --------------------------
14865 function Parameter_Block_Pack
14867 Blk_Typ
: Entity_Id
;
14871 Stmts
: List_Id
) return Entity_Id
14873 Actual
: Entity_Id
;
14874 Expr
: Node_Id
:= Empty
;
14875 Formal
: Entity_Id
;
14876 Has_Param
: Boolean := False;
14879 Temp_Asn
: Node_Id
;
14880 Temp_Nam
: Node_Id
;
14883 Actual
:= First
(Actuals
);
14884 Formal
:= Defining_Identifier
(First
(Formals
));
14885 Params
:= New_List
;
14886 while Present
(Actual
) loop
14887 if Is_By_Copy_Type
(Etype
(Actual
)) then
14889 -- Jnn : aliased <formal-type>
14891 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14894 Make_Object_Declaration
(Loc
,
14895 Aliased_Present
=> True,
14896 Defining_Identifier
=> Temp_Nam
,
14897 Object_Definition
=>
14898 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
14900 -- The object is initialized with an explicit assignment
14901 -- later. Indicate that it does not need an initialization
14902 -- to prevent spurious warnings if the type excludes null.
14904 Set_No_Initialization
(Last
(Decls
));
14906 if Ekind
(Formal
) /= E_Out_Parameter
then
14912 New_Occurrence_Of
(Temp_Nam
, Loc
);
14914 Set_Assignment_OK
(Temp_Asn
);
14917 Make_Assignment_Statement
(Loc
,
14919 Expression
=> New_Copy_Tree
(Actual
)));
14922 -- If the actual is not controlling, generate:
14924 -- Jnn'unchecked_access
14926 -- and add it to aggegate for access to formals. Note that the
14927 -- actual may be by-copy but still be a controlling actual if it
14928 -- is an access to class-wide interface.
14930 if not Is_Controlling_Actual
(Actual
) then
14932 Make_Attribute_Reference
(Loc
,
14933 Attribute_Name
=> Name_Unchecked_Access
,
14934 Prefix
=> New_Occurrence_Of
(Temp_Nam
, Loc
)));
14939 -- The controlling parameter is omitted
14942 if not Is_Controlling_Actual
(Actual
) then
14944 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14950 Next_Actual
(Actual
);
14951 Next_Formal_With_Extras
(Formal
);
14955 Expr
:= Make_Aggregate
(Loc
, Params
);
14960 -- J1'unchecked_access;
14961 -- <actual2>'reference;
14964 P
:= Make_Temporary
(Loc
, 'P');
14967 Make_Object_Declaration
(Loc
,
14968 Defining_Identifier
=> P
,
14969 Object_Definition
=> New_Occurrence_Of
(Blk_Typ
, Loc
),
14970 Expression
=> Expr
));
14973 end Parameter_Block_Pack
;
14975 ----------------------------
14976 -- Parameter_Block_Unpack --
14977 ----------------------------
14979 function Parameter_Block_Unpack
14983 Formals
: List_Id
) return List_Id
14985 Actual
: Entity_Id
;
14987 Formal
: Entity_Id
;
14988 Has_Asnmt
: Boolean := False;
14989 Result
: constant List_Id
:= New_List
;
14992 Actual
:= First
(Actuals
);
14993 Formal
:= Defining_Identifier
(First
(Formals
));
14994 while Present
(Actual
) loop
14995 if Is_By_Copy_Type
(Etype
(Actual
))
14996 and then Ekind
(Formal
) /= E_In_Parameter
14999 -- <actual> := P.<formal>;
15002 Make_Assignment_Statement
(Loc
,
15006 Make_Explicit_Dereference
(Loc
,
15007 Make_Selected_Component
(Loc
,
15009 New_Occurrence_Of
(P
, Loc
),
15011 Make_Identifier
(Loc
, Chars
(Formal
)))));
15013 Set_Assignment_OK
(Name
(Asnmt
));
15014 Append_To
(Result
, Asnmt
);
15019 Next_Actual
(Actual
);
15020 Next_Formal_With_Extras
(Formal
);
15026 return New_List
(Make_Null_Statement
(Loc
));
15028 end Parameter_Block_Unpack
;
15030 ---------------------
15031 -- Reset_Scopes_To --
15032 ---------------------
15034 procedure Reset_Scopes_To
(Bod
: Node_Id
; E
: Entity_Id
) is
15035 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
;
15036 -- Temporaries may have been declared during expansion of the procedure
15037 -- created for an entry body or an accept alternative. Indicate that
15038 -- their scope is the new body, to ensure proper generation of uplevel
15039 -- references where needed during unnesting.
15041 procedure Reset_Scopes
is new Traverse_Proc
(Reset_Scope
);
15047 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
is
15051 -- If this is a block statement with an Identifier, it forms a scope,
15052 -- so we want to reset its scope but not look inside.
15055 and then Nkind
(N
) = N_Block_Statement
15056 and then Present
(Identifier
(N
))
15058 Set_Scope
(Entity
(Identifier
(N
)), E
);
15061 -- Ditto for a package declaration or a full type declaration, etc.
15063 elsif (Nkind
(N
) = N_Package_Declaration
15064 and then N
/= Specification
(N
))
15065 or else Nkind
(N
) in N_Declaration
15066 or else Nkind
(N
) in N_Renaming_Declaration
15068 Set_Scope
(Defining_Entity
(N
), E
);
15073 -- Scan declarations in new body. Declarations in the statement
15074 -- part will be handled during later traversal.
15076 Decl
:= First
(Declarations
(N
));
15077 while Present
(Decl
) loop
15078 Reset_Scopes
(Decl
);
15082 elsif Nkind
(N
) = N_Freeze_Entity
then
15084 -- Scan the actions associated with a freeze node, which may
15085 -- actually be declarations with entities that need to have
15086 -- their scopes reset.
15088 Decl
:= First
(Actions
(N
));
15089 while Present
(Decl
) loop
15090 Reset_Scopes
(Decl
);
15094 elsif N
/= Bod
and then Nkind
(N
) in N_Proper_Body
then
15096 -- A subprogram without a separate declaration may be encountered,
15097 -- and we need to reset the subprogram's entity's scope.
15099 if Nkind
(N
) = N_Subprogram_Body
then
15100 Set_Scope
(Defining_Entity
(Specification
(N
)), E
);
15109 -- Start of processing for Reset_Scopes_To
15112 Reset_Scopes
(Bod
);
15113 end Reset_Scopes_To
;
15115 ----------------------
15116 -- Set_Discriminals --
15117 ----------------------
15119 procedure Set_Discriminals
(Dec
: Node_Id
) is
15122 D_Minal
: Entity_Id
;
15125 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
15126 Pdef
:= Defining_Identifier
(Dec
);
15128 if Has_Discriminants
(Pdef
) then
15129 D
:= First_Discriminant
(Pdef
);
15130 while Present
(D
) loop
15132 Make_Defining_Identifier
(Sloc
(D
),
15133 Chars
=> New_External_Name
(Chars
(D
), 'D'));
15135 Mutate_Ekind
(D_Minal
, E_Constant
);
15136 Set_Etype
(D_Minal
, Etype
(D
));
15137 Set_Scope
(D_Minal
, Pdef
);
15138 Set_Discriminal
(D
, D_Minal
);
15139 Set_Discriminal_Link
(D_Minal
, D
);
15141 Next_Discriminant
(D
);
15144 end Set_Discriminals
;
15146 -----------------------
15147 -- Trivial_Accept_OK --
15148 -----------------------
15150 function Trivial_Accept_OK
return Boolean is
15152 case Opt
.Task_Dispatching_Policy
is
15154 -- If we have the default task dispatching policy in effect, we can
15155 -- definitely do the optimization (one way of looking at this is to
15156 -- think of the formal definition of the default policy being allowed
15157 -- to run any task it likes after a rendezvous, so even if notionally
15158 -- a full rescheduling occurs, we can say that our dispatching policy
15159 -- (i.e. the default dispatching policy) reorders the queue to be the
15160 -- same as just before the call.
15165 -- FIFO_Within_Priorities certainly does not permit this
15166 -- optimization since the Rendezvous is a scheduling action that may
15167 -- require some other task to be run.
15172 -- For now, disallow the optimization for all other policies. This
15173 -- may be over-conservative, but it is certainly not incorrect.
15178 end Trivial_Accept_OK
;