1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Exp_Ch3; use Exp_Ch3;
32 with Exp_Ch6; use Exp_Ch6;
33 with Exp_Ch11; use Exp_Ch11;
34 with Exp_Dbug; use Exp_Dbug;
35 with Exp_Sel; use Exp_Sel;
36 with Exp_Smem; use Exp_Smem;
37 with Exp_Tss; use Exp_Tss;
38 with Exp_Util; use Exp_Util;
39 with Freeze; use Freeze;
41 with Itypes; use Itypes;
42 with Namet; use Namet;
43 with Nlists; use Nlists;
44 with Nmake; use Nmake;
46 with Restrict; use Restrict;
47 with Rident; use Rident;
48 with Rtsfind; use Rtsfind;
50 with Sem_Aux; use Sem_Aux;
51 with Sem_Ch5; use Sem_Ch5;
52 with Sem_Ch6; use Sem_Ch6;
53 with Sem_Ch8; use Sem_Ch8;
54 with Sem_Ch9; use Sem_Ch9;
55 with Sem_Ch11; use Sem_Ch11;
56 with Sem_Elab; use Sem_Elab;
57 with Sem_Eval; use Sem_Eval;
58 with Sem_Prag; use Sem_Prag;
59 with Sem_Res; use Sem_Res;
60 with Sem_Util; use Sem_Util;
61 with Sinfo; use Sinfo;
62 with Snames; use Snames;
63 with Stand; use Stand;
64 with Targparm; use Targparm;
65 with Tbuild; use Tbuild;
66 with Uintp; use Uintp;
67 with Validsw; use Validsw;
69 package body Exp_Ch9 is
71 -- The following constant establishes the upper bound for the index of
72 -- an entry family. It is used to limit the allocated size of protected
73 -- types with defaulted discriminant of an integer type, when the bound
74 -- of some entry family depends on a discriminant. The limitation to entry
75 -- families of 128K should be reasonable in all cases, and is a documented
76 -- implementation restriction.
78 Entry_Family_Bound : constant Pos := 2**16;
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 function Actual_Index_Expression
88 Tsk : Entity_Id) return Node_Id;
89 -- Compute the index position for an entry call. Tsk is the target task. If
90 -- the bounds of some entry family depend on discriminants, the expression
91 -- computed by this function uses the discriminants of the target task.
93 procedure Add_Object_Pointer
97 -- Prepend an object pointer declaration to the declaration list Decls.
98 -- This object pointer is initialized to a type conversion of the System.
99 -- Address pointer passed to entry barrier functions and entry body
102 procedure Add_Formal_Renamings
107 -- Create renaming declarations for the formals, inside the procedure that
108 -- implements an entry body. The renamings make the original names of the
109 -- formals accessible to gdb, and serve no other purpose.
110 -- Spec is the specification of the procedure being built.
111 -- Decls is the list of declarations to be enhanced.
112 -- Ent is the entity for the original entry body.
114 function Build_Accept_Body (Astat : Node_Id) return Node_Id;
115 -- Transform accept statement into a block with added exception handler.
116 -- Used both for simple accept statements and for accept alternatives in
117 -- select statements. Astat is the accept statement.
119 function Build_Barrier_Function
122 Pid : Node_Id) return Node_Id;
123 -- Build the function body returning the value of the barrier expression
124 -- for the specified entry body.
126 function Build_Barrier_Function_Specification
128 Def_Id : Entity_Id) return Node_Id;
129 -- Build a specification for a function implementing the protected entry
130 -- barrier of the specified entry body.
132 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id);
133 -- Build the body of a wrapper procedure for an entry or entry family that
134 -- has contract cases, preconditions, or postconditions. The body gathers
135 -- the executable contract items and expands them in the usual way, and
136 -- performs the entry call itself. This way preconditions are evaluated
137 -- before the call is queued. E is the entry in question, and Decl is the
138 -- enclosing synchronized type declaration at whose freeze point the
139 -- generated body is analyzed.
141 function Build_Corresponding_Record
144 Loc : Source_Ptr) return Node_Id;
145 -- Common to tasks and protected types. Copy discriminant specifications,
146 -- build record declaration. N is the type declaration, Ctyp is the
147 -- concurrent entity (task type or protected type).
149 function Build_Dispatching_Tag_Check
151 N : Node_Id) return Node_Id;
152 -- Utility to create the tree to check whether the dispatching call in
153 -- a timed entry call, a conditional entry call, or an asynchronous
154 -- transfer of control is a call to a primitive of a non-synchronized type.
155 -- K is the temporary that holds the tagged kind of the target object, and
156 -- N is the enclosing construct.
158 function Build_Entry_Count_Expression
159 (Concurrent_Type : Node_Id;
160 Component_List : List_Id;
161 Loc : Source_Ptr) return Node_Id;
162 -- Compute number of entries for concurrent object. This is a count of
163 -- simple entries, followed by an expression that computes the length
164 -- of the range of each entry family. A single array with that size is
165 -- allocated for each concurrent object of the type.
167 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
168 -- Build the function that translates the entry index in the call
169 -- (which depends on the size of entry families) into an index into the
170 -- Entry_Bodies_Array, to determine the body and barrier function used
171 -- in a protected entry call. A pointer to this function appears in every
174 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
175 -- Build subprogram declaration for previous one
177 function Build_Lock_Free_Protected_Subprogram_Body
180 Unprot_Spec : Node_Id) return Node_Id;
181 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
182 -- the subprogram specification of the unprotected version of N. Transform
183 -- N such that it invokes the unprotected version of the body.
185 function Build_Lock_Free_Unprotected_Subprogram_Body
187 Prot_Typ : Node_Id) return Node_Id;
188 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
189 -- of N where the original statements of N are synchronized through atomic
190 -- actions such as compare and exchange. Prior to invoking this routine, it
191 -- has been established that N can be implemented in a lock-free fashion.
193 function Build_Parameter_Block
197 Decls : List_Id) return Entity_Id;
198 -- Generate an access type for each actual parameter in the list Actuals.
199 -- Create an encapsulating record that contains all the actuals and return
200 -- its type. Generate:
201 -- type Ann1 is access all <actual1-type>
203 -- type AnnN is access all <actualN-type>
204 -- type Pnn is record
210 function Build_Protected_Entry
213 Pid : Node_Id) return Node_Id;
214 -- Build the procedure implementing the statement sequence of the specified
217 function Build_Protected_Entry_Specification
220 Ent_Id : Entity_Id) return Node_Id;
221 -- Build a specification for the procedure implementing the statements of
222 -- the specified entry body. Add attributes associating it with the entry
223 -- defining identifier Ent_Id.
225 function Build_Protected_Spec
227 Obj_Type : Entity_Id;
229 Unprotected : Boolean := False) return List_Id;
230 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
231 -- Subprogram_Type. Builds signature of protected subprogram, adding the
232 -- formal that corresponds to the object itself. For an access to protected
233 -- subprogram, there is no object type to specify, so the parameter has
234 -- type Address and mode In. An indirect call through such a pointer will
235 -- convert the address to a reference to the actual object. The object is
236 -- a limited record and therefore a by_reference type.
238 function Build_Protected_Subprogram_Body
241 N_Op_Spec : Node_Id) return Node_Id;
242 -- This function is used to construct the protected version of a protected
243 -- subprogram. Its statement sequence first defers abort, then locks the
244 -- associated protected object, and then enters a block that contains a
245 -- call to the unprotected version of the subprogram (for details, see
246 -- Build_Unprotected_Subprogram_Body). This block statement requires a
247 -- cleanup handler that unlocks the object in all cases. For details,
248 -- see Exp_Ch7.Expand_Cleanup_Actions.
250 function Build_Renamed_Formal_Declaration
254 Renamed_Formal : Node_Id) return Node_Id;
255 -- Create a renaming declaration for a formal, within a protected entry
256 -- body or an accept body. The renamed object is a component of the
257 -- parameter block that is a parameter in the entry call.
259 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
260 -- does not dereference the corresponding component to prevent an illegal
261 -- use of the incomplete type (AI05-0151).
263 function Build_Selected_Name
265 Selector : Entity_Id;
266 Append_Char : Character := ' ') return Name_Id;
267 -- Build a name in the form of Prefix__Selector, with an optional character
268 -- appended. This is used for internal subprograms generated for operations
269 -- of protected types, including barrier functions. For the subprograms
270 -- generated for entry bodies and entry barriers, the generated name
271 -- includes a sequence number that makes names unique in the presence of
272 -- entry overloading. This is necessary because entry body procedures and
273 -- barrier functions all have the same signature.
275 procedure Build_Simple_Entry_Call
280 -- Some comments here would be useful ???
282 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
283 -- This routine constructs a specification for the procedure that we will
284 -- build for the task body for task type T. The spec has the form:
286 -- procedure tnameB (_Task : access tnameV);
288 -- where name is the character name taken from the task type entity that
289 -- is passed as the argument to the procedure, and tnameV is the task
290 -- value type that is associated with the task type.
292 function Build_Unprotected_Subprogram_Body
294 Pid : Node_Id) return Node_Id;
295 -- This routine constructs the unprotected version of a protected
296 -- subprogram body, which contains all of the code in the original,
297 -- unexpanded body. This is the version of the protected subprogram that is
298 -- called from all protected operations on the same object, including the
299 -- protected version of the same subprogram.
301 procedure Build_Wrapper_Bodies
305 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
306 -- record of a concurrent type. N is the insertion node where all bodies
307 -- will be placed. This routine builds the bodies of the subprograms which
308 -- serve as an indirection mechanism to overriding primitives of concurrent
309 -- types, entries and protected procedures. Any new body is analyzed.
311 procedure Build_Wrapper_Specs
315 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
316 -- record of a concurrent type. N is the insertion node where all specs
317 -- will be placed. This routine builds the specs of the subprograms which
318 -- serve as an indirection mechanism to overriding primitives of concurrent
319 -- types, entries and protected procedures. Any new spec is analyzed.
321 procedure Collect_Entry_Families
324 Current_Node : in out Node_Id;
325 Conctyp : Entity_Id);
326 -- For each entry family in a concurrent type, create an anonymous array
327 -- type of the right size, and add a component to the corresponding_record.
329 function Concurrent_Object
330 (Spec_Id : Entity_Id;
331 Conc_Typ : Entity_Id) return Entity_Id;
332 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
333 -- the entity associated with the concurrent object in the Protected_Body_
334 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
335 -- denotes formal parameter _O, _object or _task.
337 function Copy_Result_Type (Res : Node_Id) return Node_Id;
338 -- Copy the result type of a function specification, when building the
339 -- internal operation corresponding to a protected function, or when
340 -- expanding an access to protected function. If the result is an anonymous
341 -- access to subprogram itself, we need to create a new signature with the
342 -- same parameter names and the same resolved types, but with new entities
345 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean;
346 -- Return whether a secondary stack for the task T should be created by the
347 -- expander. The secondary stack for a task will be created by the expander
348 -- if the size of the stack has been specified by the Secondary_Stack_Size
349 -- representation aspect and either the No_Implicit_Heap_Allocations or
350 -- No_Implicit_Task_Allocations restrictions are in effect and the
351 -- No_Secondary_Stack restriction is not.
353 procedure Debug_Private_Data_Declarations (Decls : List_Id);
354 -- Decls is a list which may contain the declarations created by Install_
355 -- Private_Data_Declarations. All generated entities are marked as needing
356 -- debug info and debug nodes are manually generation where necessary. This
357 -- step of the expansion must to be done after private data has been moved
358 -- to its final resting scope to ensure proper visibility of debug objects.
360 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id);
361 -- If control flow optimizations are suppressed, and Alt is an accept,
362 -- delay, or entry call alternative with no trailing statements, insert
363 -- a null trailing statement with the given Loc (which is the sloc of
364 -- the accept, delay, or entry call statement). There might not be any
365 -- generated code for the accept, delay, or entry call itself (the effect
366 -- of these statements is part of the general processing done for the
367 -- enclosing selective accept, timed entry call, or asynchronous select),
368 -- and the null statement is there to carry the sloc of that statement to
369 -- the back-end for trace-based coverage analysis purposes.
371 procedure Extract_Dispatching_Call
373 Call_Ent : out Entity_Id;
374 Object : out Entity_Id;
375 Actuals : out List_Id;
376 Formals : out List_Id);
377 -- Given a dispatching call, extract the entity of the name of the call,
378 -- its actual dispatching object, its actual parameters and the formal
379 -- parameters of the overridden interface-level version. If the type of
380 -- the dispatching object is an access type then an explicit dereference
381 -- is returned in Object.
383 procedure Extract_Entry
385 Concval : out Node_Id;
387 Index : out Node_Id);
388 -- Given an entry call, returns the associated concurrent object, the entry
389 -- name, and the entry family index.
391 function Family_Offset
396 Cap : Boolean) return Node_Id;
397 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
398 -- accept statement, or the upper bound in the discrete subtype of an entry
399 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
400 -- type of the entry. If Cap is true, the result is capped according to
401 -- Entry_Family_Bound.
408 Cap : Boolean) return Node_Id;
409 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
410 -- family, and handle properly the superflat case. This is equivalent to
411 -- the use of 'Length on the index type, but must use Family_Offset to
412 -- handle properly the case of bounds that depend on discriminants. If
413 -- Cap is true, the result is capped according to Entry_Family_Bound.
415 procedure Find_Enclosing_Context
417 Context : out Node_Id;
418 Context_Id : out Entity_Id;
419 Context_Decls : out List_Id);
420 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
421 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
422 -- nearest enclosing body, block, package, or return statement and return
423 -- its constituents. Context is the enclosing construct, Context_Id is
424 -- the scope of Context_Id and Context_Decls is the declarative list of
427 function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
428 -- Given a subprogram identifier, return the entity which is associated
429 -- with the protection entry index in the Protected_Body_Subprogram or
430 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
433 function Is_Potentially_Large_Family
434 (Base_Index : Entity_Id;
437 Hi : Node_Id) return Boolean;
439 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
440 -- Determine whether Id is a function or a procedure and is marked as a
441 -- private primitive.
443 function Null_Statements (Stats : List_Id) return Boolean;
444 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
445 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
446 -- to still count as null. Returns True for a null sequence. The argument
447 -- is the list of statements from the DO-END sequence.
449 function Parameter_Block_Pack
455 Stmts : List_Id) return Entity_Id;
456 -- Set the components of the generated parameter block with the values
457 -- of the actual parameters. Generate aliased temporaries to capture the
458 -- values for types that are passed by copy. Otherwise generate a reference
459 -- to the actual's value. Return the address of the aggregate block.
461 -- Jnn1 : alias <formal-type1>;
462 -- Jnn1 := <actual1>;
465 -- Jnn1'unchecked_access;
466 -- <actual2>'reference;
469 function Parameter_Block_Unpack
473 Formals : List_Id) return List_Id;
474 -- Retrieve the values of the components from the parameter block and
475 -- assign then to the original actual parameters. Generate:
476 -- <actual1> := P.<formal1>;
478 -- <actualN> := P.<formalN>;
480 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id);
481 -- Reset the scope of declarations and blocks at the top level of Bod to
482 -- be E. Bod is either a block or a subprogram body. Used after expanding
483 -- various kinds of entry bodies into their corresponding constructs. This
484 -- is needed during unnesting to determine whether a body generated for an
485 -- entry or an accept alternative includes uplevel references.
487 function Trivial_Accept_OK return Boolean;
488 -- If there is no DO-END block for an accept, or if the DO-END block has
489 -- only null statements, then it is possible to do the Rendezvous with much
490 -- less overhead using the Accept_Trivial routine in the run-time library.
491 -- However, this is not always a valid optimization. Whether it is valid or
492 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
493 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
494 -- a rescheduling is required, so this optimization is not allowed. This
495 -- function returns True if the optimization is permitted.
497 -----------------------------
498 -- Actual_Index_Expression --
499 -----------------------------
501 function Actual_Index_Expression
505 Tsk : Entity_Id) return Node_Id
507 Ttyp : constant Entity_Id := Etype (Tsk);
515 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
516 -- Compute difference between bounds of entry family
518 --------------------------
519 -- Actual_Family_Offset --
520 --------------------------
522 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
524 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
525 -- Replace a reference to a discriminant with a selected component
526 -- denoting the discriminant of the target task.
528 -----------------------------
529 -- Actual_Discriminant_Ref --
530 -----------------------------
532 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
533 Typ : constant Entity_Id := Etype (Bound);
537 if not Is_Entity_Name (Bound)
538 or else Ekind (Entity (Bound)) /= E_Discriminant
540 if Nkind (Bound) = N_Attribute_Reference then
543 B := New_Copy_Tree (Bound);
548 Make_Selected_Component (Sloc,
549 Prefix => New_Copy_Tree (Tsk),
550 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
552 Analyze_And_Resolve (B, Typ);
556 Make_Attribute_Reference (Sloc,
557 Attribute_Name => Name_Pos,
558 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
559 Expressions => New_List (B));
560 end Actual_Discriminant_Ref;
562 -- Start of processing for Actual_Family_Offset
566 Make_Op_Subtract (Sloc,
567 Left_Opnd => Actual_Discriminant_Ref (Hi),
568 Right_Opnd => Actual_Discriminant_Ref (Lo));
569 end Actual_Family_Offset;
571 -- Start of processing for Actual_Index_Expression
574 -- The queues of entries and entry families appear in textual order in
575 -- the associated record. The entry index is computed as the sum of the
576 -- number of queues for all entries that precede the designated one, to
577 -- which is added the index expression, if this expression denotes a
578 -- member of a family.
580 -- The following is a place holder for the count of simple entries
582 Num := Make_Integer_Literal (Sloc, 1);
584 -- We construct an expression which is a series of addition operations.
585 -- See comments in Entry_Index_Expression, which is identical in
588 if Present (Index) then
589 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
595 Actual_Family_Offset (
596 Make_Attribute_Reference (Sloc,
597 Attribute_Name => Name_Pos,
598 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
599 Expressions => New_List (Relocate_Node (Index))),
600 Type_Low_Bound (S)));
605 -- Now add lengths of preceding entries and entry families
607 Prev := First_Entity (Ttyp);
608 while Chars (Prev) /= Chars (Ent)
609 or else (Ekind (Prev) /= Ekind (Ent))
610 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
612 if Ekind (Prev) = E_Entry then
613 Set_Intval (Num, Intval (Num) + 1);
615 elsif Ekind (Prev) = E_Entry_Family then
617 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
619 -- The need for the following full view retrieval stems from this
620 -- complex case of nested generics and tasking:
623 -- type Formal_Index is range <>;
626 -- type Index is private;
633 -- type Index is new Formal_Index range 1 .. 10;
636 -- package body Outer is
638 -- entry Fam (Index); -- (2)
641 -- package body Inner is -- (3)
649 -- We are currently building the index expression for the entry
650 -- call "T.E" (1). Part of the expansion must mention the range
651 -- of the discrete type "Index" (2) of entry family "Fam".
653 -- However only the private view of type "Index" is available to
654 -- the inner generic (3) because there was no prior mention of
655 -- the type inside "Inner". This visibility requirement is
656 -- implicit and cannot be detected during the construction of
657 -- the generic trees and needs special handling.
660 and then Is_Private_Type (S)
661 and then Present (Full_View (S))
666 Lo := Type_Low_Bound (S);
667 Hi := Type_High_Bound (S);
674 Left_Opnd => Actual_Family_Offset (Hi, Lo),
675 Right_Opnd => Make_Integer_Literal (Sloc, 1)));
677 -- Other components are anonymous types to be ignored
687 end Actual_Index_Expression;
689 --------------------------
690 -- Add_Formal_Renamings --
691 --------------------------
693 procedure Add_Formal_Renamings
699 Ptr : constant Entity_Id :=
701 (Next (First (Parameter_Specifications (Spec))));
702 -- The name of the formal that holds the address of the parameter block
709 Renamed_Formal : Node_Id;
712 Formal := First_Formal (Ent);
713 while Present (Formal) loop
714 Comp := Entry_Component (Formal);
716 Make_Defining_Identifier (Sloc (Formal),
717 Chars => Chars (Formal));
718 Set_Etype (New_F, Etype (Formal));
719 Set_Scope (New_F, Ent);
721 -- Now we set debug info needed on New_F even though it does not come
722 -- from source, so that the debugger will get the right information
723 -- for these generated names.
725 Set_Debug_Info_Needed (New_F);
727 if Ekind (Formal) = E_In_Parameter then
728 Set_Ekind (New_F, E_Constant);
730 Set_Ekind (New_F, E_Variable);
731 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
734 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
737 Make_Selected_Component (Loc,
739 Unchecked_Convert_To (Entry_Parameters_Type (Ent),
740 Make_Identifier (Loc, Chars (Ptr))),
741 Selector_Name => New_Occurrence_Of (Comp, Loc));
744 Build_Renamed_Formal_Declaration
745 (New_F, Formal, Comp, Renamed_Formal);
747 Append (Decl, Decls);
748 Set_Renamed_Object (Formal, New_F);
749 Next_Formal (Formal);
751 end Add_Formal_Renamings;
753 ------------------------
754 -- Add_Object_Pointer --
755 ------------------------
757 procedure Add_Object_Pointer
759 Conc_Typ : Entity_Id;
762 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ);
767 -- Create the renaming declaration for the Protection object of a
768 -- protected type. _Object is used by Complete_Entry_Body.
769 -- ??? An attempt to make this a renaming was unsuccessful.
771 -- Build the entity for the access type
774 Make_Defining_Identifier (Loc,
775 New_External_Name (Chars (Rec_Typ), 'P'));
778 -- _object : poVP := poVP!O;
781 Make_Object_Declaration (Loc,
782 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject),
783 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc),
785 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO)));
786 Set_Debug_Info_Needed (Defining_Identifier (Decl));
787 Prepend_To (Decls, Decl);
790 -- type poVP is access poV;
793 Make_Full_Type_Declaration (Loc,
794 Defining_Identifier =>
797 Make_Access_To_Object_Definition (Loc,
798 Subtype_Indication =>
799 New_Occurrence_Of (Rec_Typ, Loc)));
800 Set_Debug_Info_Needed (Defining_Identifier (Decl));
801 Prepend_To (Decls, Decl);
802 end Add_Object_Pointer;
804 -----------------------
805 -- Build_Accept_Body --
806 -----------------------
808 function Build_Accept_Body (Astat : Node_Id) return Node_Id is
809 Loc : constant Source_Ptr := Sloc (Astat);
810 Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
817 -- At the end of the statement sequence, Complete_Rendezvous is called.
818 -- A label skipping the Complete_Rendezvous, and all other accept
819 -- processing, has already been added for the expansion of requeue
820 -- statements. The Sloc is copied from the last statement since it
821 -- is really part of this last statement.
825 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
826 Insert_Before (Last (Statements (Stats)), Call);
829 -- If exception handlers are present, then append Complete_Rendezvous
830 -- calls to the handlers, and construct the required outer block. As
831 -- above, the Sloc is copied from the last statement in the sequence.
833 if Present (Exception_Handlers (Stats)) then
834 Hand := First (Exception_Handlers (Stats));
835 while Present (Hand) loop
838 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
839 Append (Call, Statements (Hand));
845 Make_Handled_Sequence_Of_Statements (Loc,
846 Statements => New_List (
847 Make_Block_Statement (Loc,
848 Handled_Statement_Sequence => Stats)));
854 -- At this stage we know that the new statement sequence does
855 -- not have an exception handler part, so we supply one to call
856 -- Exceptional_Complete_Rendezvous. This handler is
858 -- when all others =>
859 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
861 -- We handle Abort_Signal to make sure that we properly catch the abort
862 -- case and wake up the caller.
864 Ohandle := Make_Others_Choice (Loc);
865 Set_All_Others (Ohandle);
867 Set_Exception_Handlers (New_S,
869 Make_Implicit_Exception_Handler (Loc,
870 Exception_Choices => New_List (Ohandle),
872 Statements => New_List (
873 Make_Procedure_Call_Statement (Sloc (Stats),
874 Name => New_Occurrence_Of (
875 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
876 Parameter_Associations => New_List (
877 Make_Function_Call (Sloc (Stats),
880 (RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
882 Set_Parent (New_S, Astat); -- temp parent for Analyze call
883 Analyze_Exception_Handlers (Exception_Handlers (New_S));
884 Expand_Exception_Handlers (New_S);
886 -- Exceptional_Complete_Rendezvous must be called with abort still
887 -- deferred, which is the case for a "when all others" handler.
890 end Build_Accept_Body;
892 -----------------------------------
893 -- Build_Activation_Chain_Entity --
894 -----------------------------------
896 procedure Build_Activation_Chain_Entity (N : Node_Id) is
897 function Has_Activation_Chain (Stmt : Node_Id) return Boolean;
898 -- Determine whether an extended return statement has activation chain
900 --------------------------
901 -- Has_Activation_Chain --
902 --------------------------
904 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is
908 Decl := First (Return_Object_Declarations (Stmt));
909 while Present (Decl) loop
910 if Nkind (Decl) = N_Object_Declaration
911 and then Chars (Defining_Identifier (Decl)) = Name_uChain
920 end Has_Activation_Chain;
925 Context_Id : Entity_Id;
928 -- Start of processing for Build_Activation_Chain_Entity
931 -- Activation chain is never used for sequential elaboration policy, see
932 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
934 if Partition_Elaboration_Policy = 'S' then
938 Find_Enclosing_Context (N, Context, Context_Id, Decls);
940 -- If activation chain entity has not been declared already, create one
942 if Nkind (Context) = N_Extended_Return_Statement
943 or else No (Activation_Chain_Entity (Context))
945 -- Since extended return statements do not store the entity of the
946 -- chain, examine the return object declarations to avoid creating
949 if Nkind (Context) = N_Extended_Return_Statement
950 and then Has_Activation_Chain (Context)
956 Loc : constant Source_Ptr := Sloc (Context);
961 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
963 -- Note: An extended return statement is not really a task
964 -- activator, but it does have an activation chain on which to
965 -- store the tasks temporarily. On successful return, the tasks
966 -- on this chain are moved to the chain passed in by the caller.
967 -- We do not build an Activation_Chain_Entity for an extended
968 -- return statement, because we do not want to build a call to
969 -- Activate_Tasks. Task activation is the responsibility of the
972 if Nkind (Context) /= N_Extended_Return_Statement then
973 Set_Activation_Chain_Entity (Context, Chain);
977 Make_Object_Declaration (Loc,
978 Defining_Identifier => Chain,
979 Aliased_Present => True,
981 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc));
983 Prepend_To (Decls, Decl);
985 -- Ensure that _chain appears in the proper scope of the context
987 if Context_Id /= Current_Scope then
988 Push_Scope (Context_Id);
996 end Build_Activation_Chain_Entity;
998 ----------------------------
999 -- Build_Barrier_Function --
1000 ----------------------------
1002 function Build_Barrier_Function
1005 Pid : Node_Id) return Node_Id
1007 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
1008 Cond : constant Node_Id := Condition (Ent_Formals);
1009 Loc : constant Source_Ptr := Sloc (Cond);
1010 Func_Id : constant Entity_Id := Barrier_Function (Ent);
1011 Op_Decls : constant List_Id := New_List;
1013 Func_Body : Node_Id;
1016 -- Add a declaration for the Protection object, renaming declarations
1017 -- for the discriminals and privals and finally a declaration for the
1018 -- entry family index (if applicable).
1020 Install_Private_Data_Declarations (Sloc (N),
1026 Family => Ekind (Ent) = E_Entry_Family);
1028 -- If compiling with -fpreserve-control-flow, make sure we insert an
1029 -- IF statement so that the back-end knows to generate a conditional
1030 -- branch instruction, even if the condition is just the name of a
1031 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1032 -- such redundant IF statements under -fpreserve-control-flow
1033 -- (whether coming from this routine, or directly from source).
1035 if Opt.Suppress_Control_Flow_Optimizations then
1037 Make_Implicit_If_Statement (Cond,
1039 Then_Statements => New_List (
1040 Make_Simple_Return_Statement (Loc,
1041 New_Occurrence_Of (Standard_True, Loc))),
1043 Else_Statements => New_List (
1044 Make_Simple_Return_Statement (Loc,
1045 New_Occurrence_Of (Standard_False, Loc))));
1048 Stmt := Make_Simple_Return_Statement (Loc, Cond);
1051 -- Note: the condition in the barrier function needs to be properly
1052 -- processed for the C/Fortran boolean possibility, but this happens
1053 -- automatically since the return statement does this normalization.
1056 Make_Subprogram_Body (Loc,
1058 Build_Barrier_Function_Specification (Loc,
1059 Make_Defining_Identifier (Loc, Chars (Func_Id))),
1060 Declarations => Op_Decls,
1061 Handled_Statement_Sequence =>
1062 Make_Handled_Sequence_Of_Statements (Loc,
1063 Statements => New_List (Stmt)));
1064 Set_Is_Entry_Barrier_Function (Func_Body);
1067 end Build_Barrier_Function;
1069 ------------------------------------------
1070 -- Build_Barrier_Function_Specification --
1071 ------------------------------------------
1073 function Build_Barrier_Function_Specification
1075 Def_Id : Entity_Id) return Node_Id
1078 Set_Debug_Info_Needed (Def_Id);
1081 Make_Function_Specification (Loc,
1082 Defining_Unit_Name => Def_Id,
1083 Parameter_Specifications => New_List (
1084 Make_Parameter_Specification (Loc,
1085 Defining_Identifier =>
1086 Make_Defining_Identifier (Loc, Name_uO),
1088 New_Occurrence_Of (RTE (RE_Address), Loc)),
1090 Make_Parameter_Specification (Loc,
1091 Defining_Identifier =>
1092 Make_Defining_Identifier (Loc, Name_uE),
1094 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
1096 Result_Definition =>
1097 New_Occurrence_Of (Standard_Boolean, Loc));
1098 end Build_Barrier_Function_Specification;
1100 --------------------------
1101 -- Build_Call_With_Task --
1102 --------------------------
1104 function Build_Call_With_Task
1106 E : Entity_Id) return Node_Id
1108 Loc : constant Source_Ptr := Sloc (N);
1111 Make_Function_Call (Loc,
1112 Name => New_Occurrence_Of (E, Loc),
1113 Parameter_Associations => New_List (Concurrent_Ref (N)));
1114 end Build_Call_With_Task;
1116 -----------------------------
1117 -- Build_Class_Wide_Master --
1118 -----------------------------
1120 procedure Build_Class_Wide_Master (Typ : Entity_Id) is
1121 Loc : constant Source_Ptr := Sloc (Typ);
1122 Master_Decl : Node_Id;
1123 Master_Id : Entity_Id;
1124 Master_Scope : Entity_Id;
1126 Related_Node : Node_Id;
1130 -- Nothing to do if there is no task hierarchy
1132 if Restriction_Active (No_Task_Hierarchy) then
1136 -- Find the declaration that created the access type, which is either a
1137 -- type declaration, or an object declaration with an access definition,
1138 -- in which case the type is anonymous.
1140 if Is_Itype (Typ) then
1141 Related_Node := Associated_Node_For_Itype (Typ);
1143 Related_Node := Parent (Typ);
1146 Master_Scope := Find_Master_Scope (Typ);
1148 -- Nothing to do if the master scope already contains a _master entity.
1149 -- The only exception to this is the following scenario:
1152 -- Transient_Scope_1
1155 -- Transient_Scope_2
1158 -- In this case the source scope is marked as having the master entity
1159 -- even though the actual declaration appears inside an inner scope. If
1160 -- the second transient scope requires a _master, it cannot use the one
1161 -- already declared because the entity is not visible.
1163 Name_Id := Make_Identifier (Loc, Name_uMaster);
1164 Master_Decl := Empty;
1166 if not Has_Master_Entity (Master_Scope)
1167 or else No (Current_Entity_In_Scope (Name_Id))
1170 Set_Has_Master_Entity (Master_Scope);
1173 -- _master : constant Integer := Current_Master.all;
1176 Make_Object_Declaration (Loc,
1177 Defining_Identifier =>
1178 Make_Defining_Identifier (Loc, Name_uMaster),
1179 Constant_Present => True,
1180 Object_Definition =>
1181 New_Occurrence_Of (Standard_Integer, Loc),
1183 Make_Explicit_Dereference (Loc,
1184 New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
1186 Insert_Action (Find_Hook_Context (Related_Node), Master_Decl);
1187 Analyze (Master_Decl);
1189 -- Mark the containing scope as a task master. Masters associated
1190 -- with return statements are already marked at this stage (see
1191 -- Analyze_Subprogram_Body).
1193 if Ekind (Current_Scope) /= E_Return_Statement then
1195 Par : Node_Id := Related_Node;
1198 while Nkind (Par) /= N_Compilation_Unit loop
1199 Par := Parent (Par);
1201 -- If we fall off the top, we are at the outer level,
1202 -- and the environment task is our effective master,
1203 -- so nothing to mark.
1205 if Nkind_In (Par, N_Block_Statement,
1209 Set_Is_Task_Master (Par);
1219 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M'));
1222 -- typeMnn renames _master;
1225 Make_Object_Renaming_Declaration (Loc,
1226 Defining_Identifier => Master_Id,
1227 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
1230 -- If the master is declared locally, add the renaming declaration
1231 -- immediately after it, to prevent access-before-elaboration in the
1234 if Present (Master_Decl) then
1235 Insert_After (Master_Decl, Ren_Decl);
1239 Insert_Action (Related_Node, Ren_Decl);
1242 Set_Master_Id (Typ, Master_Id);
1243 end Build_Class_Wide_Master;
1245 ----------------------------
1246 -- Build_Contract_Wrapper --
1247 ----------------------------
1249 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is
1250 Conc_Typ : constant Entity_Id := Scope (E);
1251 Loc : constant Source_Ptr := Sloc (E);
1253 procedure Add_Discriminant_Renamings
1254 (Obj_Id : Entity_Id;
1256 -- Add renaming declarations for all discriminants of concurrent type
1257 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1258 -- represents the concurrent object.
1260 procedure Add_Matching_Formals
1262 Actuals : in out List_Id);
1263 -- Add formal parameters that match those of entry E to list Formals.
1264 -- The routine also adds matching actuals for the new formals to list
1267 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id);
1268 -- Relocate pragma Prag to list To. The routine creates a new list if
1269 -- To does not exist.
1271 --------------------------------
1272 -- Add_Discriminant_Renamings --
1273 --------------------------------
1275 procedure Add_Discriminant_Renamings
1276 (Obj_Id : Entity_Id;
1282 -- Inspect the discriminants of the concurrent type and generate a
1283 -- renaming for each one.
1285 if Has_Discriminants (Conc_Typ) then
1286 Discr := First_Discriminant (Conc_Typ);
1287 while Present (Discr) loop
1289 Make_Object_Renaming_Declaration (Loc,
1290 Defining_Identifier =>
1291 Make_Defining_Identifier (Loc, Chars (Discr)),
1293 New_Occurrence_Of (Etype (Discr), Loc),
1295 Make_Selected_Component (Loc,
1296 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1298 Make_Identifier (Loc, Chars (Discr)))));
1300 Next_Discriminant (Discr);
1303 end Add_Discriminant_Renamings;
1305 --------------------------
1306 -- Add_Matching_Formals --
1307 --------------------------
1309 procedure Add_Matching_Formals
1311 Actuals : in out List_Id)
1314 New_Formal : Entity_Id;
1317 -- Inspect the formal parameters of the entry and generate a new
1318 -- matching formal with the same name for the wrapper. A reference
1319 -- to the new formal becomes an actual in the entry call.
1321 Formal := First_Formal (E);
1322 while Present (Formal) loop
1323 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal));
1325 Make_Parameter_Specification (Loc,
1326 Defining_Identifier => New_Formal,
1327 In_Present => In_Present (Parent (Formal)),
1328 Out_Present => Out_Present (Parent (Formal)),
1330 New_Occurrence_Of (Etype (Formal), Loc)));
1332 if No (Actuals) then
1333 Actuals := New_List;
1336 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
1337 Next_Formal (Formal);
1339 end Add_Matching_Formals;
1341 ---------------------
1342 -- Transfer_Pragma --
1343 ---------------------
1345 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is
1353 New_Prag := Relocate_Node (Prag);
1355 Set_Analyzed (New_Prag, False);
1356 Append (New_Prag, To);
1357 end Transfer_Pragma;
1361 Items : constant Node_Id := Contract (E);
1362 Actuals : List_Id := No_List;
1365 Decls : List_Id := No_List;
1367 Has_Pragma : Boolean := False;
1368 Index_Id : Entity_Id;
1371 Wrapper_Id : Entity_Id;
1373 -- Start of processing for Build_Contract_Wrapper
1376 -- This routine generates a specialized wrapper for a protected or task
1377 -- entry [family] which implements precondition/postcondition semantics.
1378 -- Preconditions and case guards of contract cases are checked before
1379 -- the protected action or rendezvous takes place. Postconditions and
1380 -- consequences of contract cases are checked after the protected action
1381 -- or rendezvous takes place. The structure of the generated wrapper is
1384 -- procedure Wrapper
1385 -- (Obj_Id : Conc_Typ; -- concurrent object
1386 -- [Index : Index_Typ;] -- index of entry family
1387 -- [Formal_1 : ...; -- parameters of original entry
1390 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1391 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1393 -- <precondition checks>
1394 -- <case guard checks>
1396 -- procedure _Postconditions is
1398 -- <postcondition checks>
1399 -- <consequence checks>
1400 -- end _Postconditions;
1403 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1407 -- Create the wrapper only when the entry has at least one executable
1408 -- contract item such as contract cases, precondition or postcondition.
1410 if Present (Items) then
1412 -- Inspect the list of pre/postconditions and transfer all available
1413 -- pragmas to the declarative list of the wrapper.
1415 Prag := Pre_Post_Conditions (Items);
1416 while Present (Prag) loop
1417 if Nam_In (Pragma_Name_Unmapped (Prag),
1418 Name_Postcondition, Name_Precondition)
1419 and then Is_Checked (Prag)
1422 Transfer_Pragma (Prag, To => Decls);
1425 Prag := Next_Pragma (Prag);
1428 -- Inspect the list of test/contract cases and transfer only contract
1429 -- cases pragmas to the declarative part of the wrapper.
1431 Prag := Contract_Test_Cases (Items);
1432 while Present (Prag) loop
1433 if Pragma_Name (Prag) = Name_Contract_Cases
1434 and then Is_Checked (Prag)
1437 Transfer_Pragma (Prag, To => Decls);
1440 Prag := Next_Pragma (Prag);
1444 -- The entry lacks executable contract items and a wrapper is not needed
1446 if not Has_Pragma then
1450 -- Create the profile of the wrapper. The first formal parameter is the
1451 -- concurrent object.
1454 Make_Defining_Identifier (Loc,
1455 Chars => New_External_Name (Chars (Conc_Typ), 'A'));
1457 Formals := New_List (
1458 Make_Parameter_Specification (Loc,
1459 Defining_Identifier => Obj_Id,
1460 Out_Present => True,
1462 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc)));
1464 -- Construct the call to the original entry. The call will be gradually
1465 -- augmented with an optional entry index and extra parameters.
1468 Make_Selected_Component (Loc,
1469 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1470 Selector_Name => New_Occurrence_Of (E, Loc));
1472 -- When creating a wrapper for an entry family, the second formal is the
1475 if Ekind (E) = E_Entry_Family then
1476 Index_Id := Make_Defining_Identifier (Loc, Name_I);
1479 Make_Parameter_Specification (Loc,
1480 Defining_Identifier => Index_Id,
1482 New_Occurrence_Of (Entry_Index_Type (E), Loc)));
1484 -- The call to the original entry becomes an indexed component to
1485 -- accommodate the entry index.
1488 Make_Indexed_Component (Loc,
1490 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc)));
1493 -- Add formal parameters to match those of the entry and build actuals
1494 -- for the entry call.
1496 Add_Matching_Formals (Formals, Actuals);
1499 Make_Procedure_Call_Statement (Loc,
1501 Parameter_Associations => Actuals);
1503 -- Add renaming declarations for the discriminants of the enclosing type
1504 -- as the various contract items may reference them.
1506 Add_Discriminant_Renamings (Obj_Id, Decls);
1509 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E'));
1510 Set_Contract_Wrapper (E, Wrapper_Id);
1511 Set_Is_Entry_Wrapper (Wrapper_Id);
1513 -- The wrapper body is analyzed when the enclosing type is frozen
1515 Append_Freeze_Action (Defining_Entity (Decl),
1516 Make_Subprogram_Body (Loc,
1518 Make_Procedure_Specification (Loc,
1519 Defining_Unit_Name => Wrapper_Id,
1520 Parameter_Specifications => Formals),
1521 Declarations => Decls,
1522 Handled_Statement_Sequence =>
1523 Make_Handled_Sequence_Of_Statements (Loc,
1524 Statements => New_List (Call))));
1525 end Build_Contract_Wrapper;
1527 --------------------------------
1528 -- Build_Corresponding_Record --
1529 --------------------------------
1531 function Build_Corresponding_Record
1534 Loc : Source_Ptr) return Node_Id
1536 Rec_Ent : constant Entity_Id :=
1537 Make_Defining_Identifier
1538 (Loc, New_External_Name (Chars (Ctyp), 'V'));
1541 New_Disc : Entity_Id;
1545 Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
1546 Set_Ekind (Rec_Ent, E_Record_Type);
1547 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
1548 Set_Is_Concurrent_Record_Type (Rec_Ent, True);
1549 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
1550 Set_Stored_Constraint (Rec_Ent, No_Elist);
1553 -- Use discriminals to create list of discriminants for record, and
1554 -- create new discriminals for use in default expressions, etc. It is
1555 -- worth noting that a task discriminant gives rise to 5 entities;
1557 -- a) The original discriminant.
1558 -- b) The discriminal for use in the task.
1559 -- c) The discriminant of the corresponding record.
1560 -- d) The discriminal for the init proc of the corresponding record.
1561 -- e) The local variable that renames the discriminant in the procedure
1562 -- for the task body.
1564 -- In fact the discriminals b) are used in the renaming declarations
1565 -- for e). See details in einfo (Handling of Discriminants).
1567 if Present (Discriminant_Specifications (N)) then
1569 Disc := First_Discriminant (Ctyp);
1571 while Present (Disc) loop
1572 New_Disc := CR_Discriminant (Disc);
1575 Make_Discriminant_Specification (Loc,
1576 Defining_Identifier => New_Disc,
1577 Discriminant_Type =>
1578 New_Occurrence_Of (Etype (Disc), Loc),
1580 New_Copy (Discriminant_Default_Value (Disc))));
1582 Next_Discriminant (Disc);
1589 -- Now we can construct the record type declaration. Note that this
1590 -- record is "limited tagged". It is "limited" to reflect the underlying
1591 -- limitedness of the task or protected object that it represents, and
1592 -- ensuring for example that it is properly passed by reference. It is
1593 -- "tagged" to give support to dispatching calls through interfaces. We
1594 -- propagate here the list of interfaces covered by the concurrent type
1595 -- (Ada 2005: AI-345).
1598 Make_Full_Type_Declaration (Loc,
1599 Defining_Identifier => Rec_Ent,
1600 Discriminant_Specifications => Dlist,
1602 Make_Record_Definition (Loc,
1604 Make_Component_List (Loc, Component_Items => Cdecls),
1606 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp),
1607 Interface_List => Interface_List (N),
1608 Limited_Present => True));
1609 end Build_Corresponding_Record;
1611 ---------------------------------
1612 -- Build_Dispatching_Tag_Check --
1613 ---------------------------------
1615 function Build_Dispatching_Tag_Check
1617 N : Node_Id) return Node_Id
1619 Loc : constant Source_Ptr := Sloc (N);
1626 New_Occurrence_Of (K, Loc),
1628 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)),
1632 New_Occurrence_Of (K, Loc),
1634 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc)));
1635 end Build_Dispatching_Tag_Check;
1637 ----------------------------------
1638 -- Build_Entry_Count_Expression --
1639 ----------------------------------
1641 function Build_Entry_Count_Expression
1642 (Concurrent_Type : Node_Id;
1643 Component_List : List_Id;
1644 Loc : Source_Ptr) return Node_Id
1656 -- Count number of non-family entries
1659 Ent := First_Entity (Concurrent_Type);
1660 while Present (Ent) loop
1661 if Ekind (Ent) = E_Entry then
1668 Ecount := Make_Integer_Literal (Loc, Eindx);
1670 -- Loop through entry families building the addition nodes
1672 Ent := First_Entity (Concurrent_Type);
1673 Comp := First (Component_List);
1674 while Present (Ent) loop
1675 if Ekind (Ent) = E_Entry_Family then
1676 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
1680 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1681 Hi := Type_High_Bound (Typ);
1682 Lo := Type_Low_Bound (Typ);
1683 Large := Is_Potentially_Large_Family
1684 (Base_Type (Typ), Concurrent_Type, Lo, Hi);
1687 Left_Opnd => Ecount,
1689 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large));
1696 end Build_Entry_Count_Expression;
1698 ---------------------------
1699 -- Build_Parameter_Block --
1700 ---------------------------
1702 function Build_Parameter_Block
1706 Decls : List_Id) return Entity_Id
1712 Has_Comp : Boolean := False;
1716 Actual := First (Actuals);
1718 Formal := Defining_Identifier (First (Formals));
1720 while Present (Actual) loop
1721 if not Is_Controlling_Actual (Actual) then
1724 -- type Ann is access all <actual-type>
1726 Comp_Nam := Make_Temporary (Loc, 'A');
1727 Set_Is_Param_Block_Component_Type (Comp_Nam);
1730 Make_Full_Type_Declaration (Loc,
1731 Defining_Identifier => Comp_Nam,
1733 Make_Access_To_Object_Definition (Loc,
1734 All_Present => True,
1735 Constant_Present => Ekind (Formal) = E_In_Parameter,
1736 Subtype_Indication =>
1737 New_Occurrence_Of (Etype (Actual), Loc))));
1743 Make_Component_Declaration (Loc,
1744 Defining_Identifier =>
1745 Make_Defining_Identifier (Loc, Chars (Formal)),
1746 Component_Definition =>
1747 Make_Component_Definition (Loc,
1750 Subtype_Indication =>
1751 New_Occurrence_Of (Comp_Nam, Loc))));
1756 Next_Actual (Actual);
1757 Next_Formal_With_Extras (Formal);
1760 Rec_Nam := Make_Temporary (Loc, 'P');
1765 -- type Pnn is record
1770 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1771 -- the original parameter names and Ann1 .. AnnN are the access to
1775 Make_Full_Type_Declaration (Loc,
1776 Defining_Identifier =>
1779 Make_Record_Definition (Loc,
1781 Make_Component_List (Loc, Comps))));
1784 -- type Pnn is null record;
1787 Make_Full_Type_Declaration (Loc,
1788 Defining_Identifier =>
1791 Make_Record_Definition (Loc,
1792 Null_Present => True,
1793 Component_List => Empty)));
1797 end Build_Parameter_Block;
1799 --------------------------------------
1800 -- Build_Renamed_Formal_Declaration --
1801 --------------------------------------
1803 function Build_Renamed_Formal_Declaration
1807 Renamed_Formal : Node_Id) return Node_Id
1809 Loc : constant Source_Ptr := Sloc (New_F);
1813 -- If the formal is a tagged incomplete type, it is already passed
1814 -- by reference, so it is sufficient to rename the pointer component
1815 -- that corresponds to the actual. Otherwise we need to dereference
1816 -- the pointer component to obtain the actual.
1818 if Is_Incomplete_Type (Etype (Formal))
1819 and then Is_Tagged_Type (Etype (Formal))
1822 Make_Object_Renaming_Declaration (Loc,
1823 Defining_Identifier => New_F,
1824 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc),
1825 Name => Renamed_Formal);
1829 Make_Object_Renaming_Declaration (Loc,
1830 Defining_Identifier => New_F,
1831 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc),
1833 Make_Explicit_Dereference (Loc, Renamed_Formal));
1837 end Build_Renamed_Formal_Declaration;
1839 --------------------------
1840 -- Build_Wrapper_Bodies --
1841 --------------------------
1843 procedure Build_Wrapper_Bodies
1848 Rec_Typ : Entity_Id;
1850 function Build_Wrapper_Body
1852 Subp_Id : Entity_Id;
1853 Obj_Typ : Entity_Id;
1854 Formals : List_Id) return Node_Id;
1855 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1856 -- associated with a protected or task type. Subp_Id is the subprogram
1857 -- name which will be wrapped. Obj_Typ is the type of the new formal
1858 -- parameter which handles dispatching and object notation. Formals are
1859 -- the original formals of Subp_Id which will be explicitly replicated.
1861 ------------------------
1862 -- Build_Wrapper_Body --
1863 ------------------------
1865 function Build_Wrapper_Body
1867 Subp_Id : Entity_Id;
1868 Obj_Typ : Entity_Id;
1869 Formals : List_Id) return Node_Id
1871 Body_Spec : Node_Id;
1874 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals);
1876 -- The subprogram is not overriding or is not a primitive declared
1877 -- between two views.
1879 if No (Body_Spec) then
1884 Actuals : List_Id := No_List;
1886 First_Form : Node_Id;
1891 -- Map formals to actuals. Use the list built for the wrapper
1892 -- spec, skipping the object notation parameter.
1894 First_Form := First (Parameter_Specifications (Body_Spec));
1896 Formal := First_Form;
1899 if Present (Formal) then
1900 Actuals := New_List;
1901 while Present (Formal) loop
1903 Make_Identifier (Loc,
1904 Chars => Chars (Defining_Identifier (Formal))));
1909 -- Special processing for primitives declared between a private
1910 -- type and its completion: the wrapper needs a properly typed
1911 -- parameter if the wrapped operation has a controlling first
1912 -- parameter. Note that this might not be the case for a function
1913 -- with a controlling result.
1915 if Is_Private_Primitive_Subprogram (Subp_Id) then
1916 if No (Actuals) then
1917 Actuals := New_List;
1920 if Is_Controlling_Formal (First_Formal (Subp_Id)) then
1921 Prepend_To (Actuals,
1922 Unchecked_Convert_To
1923 (Corresponding_Concurrent_Type (Obj_Typ),
1924 Make_Identifier (Loc, Name_uO)));
1927 Prepend_To (Actuals,
1928 Make_Identifier (Loc,
1929 Chars => Chars (Defining_Identifier (First_Form))));
1932 Nam := New_Occurrence_Of (Subp_Id, Loc);
1934 -- An access-to-variable object parameter requires an explicit
1935 -- dereference in the unchecked conversion. This case occurs
1936 -- when a protected entry wrapper must override an interface
1937 -- level procedure with interface access as first parameter.
1939 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1941 if Nkind (Parameter_Type (First_Form)) =
1945 Make_Explicit_Dereference (Loc,
1946 Prefix => Make_Identifier (Loc, Name_uO));
1948 Conv_Id := Make_Identifier (Loc, Name_uO);
1952 Make_Selected_Component (Loc,
1954 Unchecked_Convert_To
1955 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id),
1956 Selector_Name => New_Occurrence_Of (Subp_Id, Loc));
1959 -- Create the subprogram body. For a function, the call to the
1960 -- actual subprogram has to be converted to the corresponding
1961 -- record if it is a controlling result.
1963 if Ekind (Subp_Id) = E_Function then
1969 Make_Function_Call (Loc,
1971 Parameter_Associations => Actuals);
1973 if Has_Controlling_Result (Subp_Id) then
1975 Unchecked_Convert_To
1976 (Corresponding_Record_Type (Etype (Subp_Id)), Res);
1980 Make_Subprogram_Body (Loc,
1981 Specification => Body_Spec,
1982 Declarations => Empty_List,
1983 Handled_Statement_Sequence =>
1984 Make_Handled_Sequence_Of_Statements (Loc,
1985 Statements => New_List (
1986 Make_Simple_Return_Statement (Loc, Res))));
1991 Make_Subprogram_Body (Loc,
1992 Specification => Body_Spec,
1993 Declarations => Empty_List,
1994 Handled_Statement_Sequence =>
1995 Make_Handled_Sequence_Of_Statements (Loc,
1996 Statements => New_List (
1997 Make_Procedure_Call_Statement (Loc,
1999 Parameter_Associations => Actuals))));
2002 end Build_Wrapper_Body;
2004 -- Start of processing for Build_Wrapper_Bodies
2007 if Is_Concurrent_Type (Typ) then
2008 Rec_Typ := Corresponding_Record_Type (Typ);
2013 -- Generate wrapper bodies for a concurrent type which implements an
2016 if Present (Interfaces (Rec_Typ)) then
2018 Insert_Nod : Node_Id;
2020 Prim_Elmt : Elmt_Id;
2021 Prim_Decl : Node_Id;
2023 Wrap_Body : Node_Id;
2024 Wrap_Id : Entity_Id;
2029 -- Examine all primitive operations of the corresponding record
2030 -- type, looking for wrapper specs. Generate bodies in order to
2033 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ));
2034 while Present (Prim_Elmt) loop
2035 Prim := Node (Prim_Elmt);
2037 if (Ekind (Prim) = E_Function
2038 or else Ekind (Prim) = E_Procedure)
2039 and then Is_Primitive_Wrapper (Prim)
2041 Subp := Wrapped_Entity (Prim);
2042 Prim_Decl := Parent (Parent (Prim));
2045 Build_Wrapper_Body (Loc,
2048 Formals => Parameter_Specifications (Parent (Subp)));
2049 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body));
2051 Set_Corresponding_Spec (Wrap_Body, Prim);
2052 Set_Corresponding_Body (Prim_Decl, Wrap_Id);
2054 Insert_After (Insert_Nod, Wrap_Body);
2055 Insert_Nod := Wrap_Body;
2057 Analyze (Wrap_Body);
2060 Next_Elmt (Prim_Elmt);
2064 end Build_Wrapper_Bodies;
2066 ------------------------
2067 -- Build_Wrapper_Spec --
2068 ------------------------
2070 function Build_Wrapper_Spec
2071 (Subp_Id : Entity_Id;
2072 Obj_Typ : Entity_Id;
2073 Formals : List_Id) return Node_Id
2075 function Overriding_Possible
2076 (Iface_Op : Entity_Id;
2077 Wrapper : Entity_Id) return Boolean;
2078 -- Determine whether a primitive operation can be overridden by Wrapper.
2079 -- Iface_Op is the candidate primitive operation of an interface type,
2080 -- Wrapper is the generated entry wrapper.
2082 function Replicate_Formals
2084 Formals : List_Id) return List_Id;
2085 -- An explicit parameter replication is required due to the Is_Entry_
2086 -- Formal flag being set for all the formals of an entry. The explicit
2087 -- replication removes the flag that would otherwise cause a different
2088 -- path of analysis.
2090 -------------------------
2091 -- Overriding_Possible --
2092 -------------------------
2094 function Overriding_Possible
2095 (Iface_Op : Entity_Id;
2096 Wrapper : Entity_Id) return Boolean
2098 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op);
2099 Wrapper_Spec : constant Node_Id := Parent (Wrapper);
2101 function Type_Conformant_Parameters
2102 (Iface_Op_Params : List_Id;
2103 Wrapper_Params : List_Id) return Boolean;
2104 -- Determine whether the parameters of the generated entry wrapper
2105 -- and those of a primitive operation are type conformant. During
2106 -- this check, the first parameter of the primitive operation is
2107 -- skipped if it is a controlling argument: protected functions
2108 -- may have a controlling result.
2110 --------------------------------
2111 -- Type_Conformant_Parameters --
2112 --------------------------------
2114 function Type_Conformant_Parameters
2115 (Iface_Op_Params : List_Id;
2116 Wrapper_Params : List_Id) return Boolean
2118 Iface_Op_Param : Node_Id;
2119 Iface_Op_Typ : Entity_Id;
2120 Wrapper_Param : Node_Id;
2121 Wrapper_Typ : Entity_Id;
2124 -- Skip the first (controlling) parameter of primitive operation
2126 Iface_Op_Param := First (Iface_Op_Params);
2128 if Present (First_Formal (Iface_Op))
2129 and then Is_Controlling_Formal (First_Formal (Iface_Op))
2131 Iface_Op_Param := Next (Iface_Op_Param);
2134 Wrapper_Param := First (Wrapper_Params);
2135 while Present (Iface_Op_Param)
2136 and then Present (Wrapper_Param)
2138 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param);
2139 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param);
2141 -- The two parameters must be mode conformant
2143 if not Conforming_Types
2144 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant)
2149 Next (Iface_Op_Param);
2150 Next (Wrapper_Param);
2153 -- One of the lists is longer than the other
2155 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then
2160 end Type_Conformant_Parameters;
2162 -- Start of processing for Overriding_Possible
2165 if Chars (Iface_Op) /= Chars (Wrapper) then
2169 -- If an inherited subprogram is implemented by a protected procedure
2170 -- or an entry, then the first parameter of the inherited subprogram
2171 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2173 if Ekind (Iface_Op) = E_Procedure
2174 and then Present (Parameter_Specifications (Iface_Op_Spec))
2177 Obj_Param : constant Node_Id :=
2178 First (Parameter_Specifications (Iface_Op_Spec));
2180 if not Out_Present (Obj_Param)
2181 and then Nkind (Parameter_Type (Obj_Param)) /=
2190 Type_Conformant_Parameters
2191 (Parameter_Specifications (Iface_Op_Spec),
2192 Parameter_Specifications (Wrapper_Spec));
2193 end Overriding_Possible;
2195 -----------------------
2196 -- Replicate_Formals --
2197 -----------------------
2199 function Replicate_Formals
2201 Formals : List_Id) return List_Id
2203 New_Formals : constant List_Id := New_List;
2205 Param_Type : Node_Id;
2208 Formal := First (Formals);
2210 -- Skip the object parameter when dealing with primitives declared
2211 -- between two views.
2213 if Is_Private_Primitive_Subprogram (Subp_Id)
2214 and then not Has_Controlling_Result (Subp_Id)
2216 Formal := Next (Formal);
2219 while Present (Formal) loop
2221 -- Create an explicit copy of the entry parameter
2223 -- When creating the wrapper subprogram for a primitive operation
2224 -- of a protected interface we must construct an equivalent
2225 -- signature to that of the overriding operation. For regular
2226 -- parameters we can just use the type of the formal, but for
2227 -- access to subprogram parameters we need to reanalyze the
2228 -- parameter type to create local entities for the signature of
2229 -- the subprogram type. Using the entities of the overriding
2230 -- subprogram will result in out-of-scope errors in the back-end.
2232 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then
2233 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal));
2236 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc);
2239 Append_To (New_Formals,
2240 Make_Parameter_Specification (Loc,
2241 Defining_Identifier =>
2242 Make_Defining_Identifier (Loc,
2243 Chars => Chars (Defining_Identifier (Formal))),
2244 In_Present => In_Present (Formal),
2245 Out_Present => Out_Present (Formal),
2246 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
2247 Parameter_Type => Param_Type));
2253 end Replicate_Formals;
2257 Loc : constant Source_Ptr := Sloc (Subp_Id);
2258 First_Param : Node_Id := Empty;
2260 Iface_Elmt : Elmt_Id;
2261 Iface_Op : Entity_Id;
2262 Iface_Op_Elmt : Elmt_Id;
2263 Overridden_Subp : Entity_Id;
2265 -- Start of processing for Build_Wrapper_Spec
2268 -- No point in building wrappers for untagged concurrent types
2270 pragma Assert (Is_Tagged_Type (Obj_Typ));
2272 -- Check if this subprogram has a profile that matches some interface
2275 Check_Synchronized_Overriding (Subp_Id, Overridden_Subp);
2277 if Present (Overridden_Subp) then
2279 First (Parameter_Specifications (Parent (Overridden_Subp)));
2281 -- An entry or a protected procedure can override a routine where the
2282 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2283 -- type. Since the wrapper must have the exact same signature as that of
2284 -- the overridden subprogram, we try to find the overriding candidate
2285 -- and use its controlling formal.
2287 -- Check every implemented interface
2289 elsif Present (Interfaces (Obj_Typ)) then
2290 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
2291 Search : while Present (Iface_Elmt) loop
2292 Iface := Node (Iface_Elmt);
2294 -- Check every interface primitive
2296 if Present (Primitive_Operations (Iface)) then
2297 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
2298 while Present (Iface_Op_Elmt) loop
2299 Iface_Op := Node (Iface_Op_Elmt);
2301 -- Ignore predefined primitives
2303 if not Is_Predefined_Dispatching_Operation (Iface_Op) then
2304 Iface_Op := Ultimate_Alias (Iface_Op);
2306 -- The current primitive operation can be overridden by
2307 -- the generated entry wrapper.
2309 if Overriding_Possible (Iface_Op, Subp_Id) then
2311 First (Parameter_Specifications (Parent (Iface_Op)));
2317 Next_Elmt (Iface_Op_Elmt);
2321 Next_Elmt (Iface_Elmt);
2325 -- Do not generate the wrapper if no interface primitive is covered by
2326 -- the subprogram and it is not a primitive declared between two views
2327 -- (see Process_Full_View).
2330 and then not Is_Private_Primitive_Subprogram (Subp_Id)
2336 Wrapper_Id : constant Entity_Id :=
2337 Make_Defining_Identifier (Loc, Chars (Subp_Id));
2338 New_Formals : List_Id;
2339 Obj_Param : Node_Id;
2340 Obj_Param_Typ : Entity_Id;
2343 -- Minimum decoration is needed to catch the entity in
2344 -- Sem_Ch6.Override_Dispatching_Operation.
2346 if Ekind (Subp_Id) = E_Function then
2347 Set_Ekind (Wrapper_Id, E_Function);
2349 Set_Ekind (Wrapper_Id, E_Procedure);
2352 Set_Is_Primitive_Wrapper (Wrapper_Id);
2353 Set_Wrapped_Entity (Wrapper_Id, Subp_Id);
2354 Set_Is_Private_Primitive (Wrapper_Id,
2355 Is_Private_Primitive_Subprogram (Subp_Id));
2357 -- Process the formals
2359 New_Formals := Replicate_Formals (Loc, Formals);
2361 -- A function with a controlling result and no first controlling
2362 -- formal needs no additional parameter.
2364 if Has_Controlling_Result (Subp_Id)
2366 (No (First_Formal (Subp_Id))
2367 or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
2371 -- Routine Subp_Id has been found to override an interface primitive.
2372 -- If the interface operation has an access parameter, create a copy
2373 -- of it, with the same null exclusion indicator if present.
2375 elsif Present (First_Param) then
2376 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
2378 Make_Access_Definition (Loc,
2380 New_Occurrence_Of (Obj_Typ, Loc),
2381 Null_Exclusion_Present =>
2382 Null_Exclusion_Present (Parameter_Type (First_Param)),
2384 Constant_Present (Parameter_Type (First_Param)));
2386 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc);
2390 Make_Parameter_Specification (Loc,
2391 Defining_Identifier =>
2392 Make_Defining_Identifier (Loc,
2394 In_Present => In_Present (First_Param),
2395 Out_Present => Out_Present (First_Param),
2396 Parameter_Type => Obj_Param_Typ);
2398 Prepend_To (New_Formals, Obj_Param);
2400 -- If we are dealing with a primitive declared between two views,
2401 -- implemented by a synchronized operation, we need to create
2402 -- a default parameter. The mode of the parameter must match that
2403 -- of the primitive operation.
2406 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
2409 Make_Parameter_Specification (Loc,
2410 Defining_Identifier =>
2411 Make_Defining_Identifier (Loc, Name_uO),
2413 In_Present (Parent (First_Entity (Subp_Id))),
2414 Out_Present => Ekind (Subp_Id) /= E_Function,
2415 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
2417 Prepend_To (New_Formals, Obj_Param);
2420 -- Build the final spec. If it is a function with a controlling
2421 -- result, it is a primitive operation of the corresponding
2422 -- record type, so mark the spec accordingly.
2424 if Ekind (Subp_Id) = E_Function then
2429 if Has_Controlling_Result (Subp_Id) then
2432 (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
2434 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
2438 Make_Function_Specification (Loc,
2439 Defining_Unit_Name => Wrapper_Id,
2440 Parameter_Specifications => New_Formals,
2441 Result_Definition => Res_Def);
2445 Make_Procedure_Specification (Loc,
2446 Defining_Unit_Name => Wrapper_Id,
2447 Parameter_Specifications => New_Formals);
2450 end Build_Wrapper_Spec;
2452 -------------------------
2453 -- Build_Wrapper_Specs --
2454 -------------------------
2456 procedure Build_Wrapper_Specs
2462 Rec_Typ : Entity_Id;
2463 procedure Scan_Declarations (L : List_Id);
2464 -- Common processing for visible and private declarations
2465 -- of a protected type.
2467 procedure Scan_Declarations (L : List_Id) is
2469 Wrap_Decl : Node_Id;
2470 Wrap_Spec : Node_Id;
2478 while Present (Decl) loop
2481 if Nkind (Decl) = N_Entry_Declaration
2482 and then Ekind (Defining_Identifier (Decl)) = E_Entry
2486 (Subp_Id => Defining_Identifier (Decl),
2488 Formals => Parameter_Specifications (Decl));
2490 elsif Nkind (Decl) = N_Subprogram_Declaration then
2493 (Subp_Id => Defining_Unit_Name (Specification (Decl)),
2496 Parameter_Specifications (Specification (Decl)));
2499 if Present (Wrap_Spec) then
2501 Make_Subprogram_Declaration (Loc,
2502 Specification => Wrap_Spec);
2504 Insert_After (N, Wrap_Decl);
2507 Analyze (Wrap_Decl);
2512 end Scan_Declarations;
2514 -- start of processing for Build_Wrapper_Specs
2517 if Is_Protected_Type (Typ) then
2518 Def := Protected_Definition (Parent (Typ));
2519 else pragma Assert (Is_Task_Type (Typ));
2520 Def := Task_Definition (Parent (Typ));
2523 Rec_Typ := Corresponding_Record_Type (Typ);
2525 -- Generate wrapper specs for a concurrent type which implements an
2526 -- interface. Operations in both the visible and private parts may
2527 -- implement progenitor operations.
2529 if Present (Interfaces (Rec_Typ)) and then Present (Def) then
2530 Scan_Declarations (Visible_Declarations (Def));
2531 Scan_Declarations (Private_Declarations (Def));
2533 end Build_Wrapper_Specs;
2535 ---------------------------
2536 -- Build_Find_Body_Index --
2537 ---------------------------
2539 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
2540 Loc : constant Source_Ptr := Sloc (Typ);
2543 Has_F : Boolean := False;
2545 If_St : Node_Id := Empty;
2548 Decls : List_Id := New_List;
2551 Siz : Node_Id := Empty;
2553 procedure Add_If_Clause (Expr : Node_Id);
2554 -- Add test for range of current entry
2556 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
2557 -- If a bound of an entry is given by a discriminant, retrieve the
2558 -- actual value of the discriminant from the enclosing object.
2564 procedure Add_If_Clause (Expr : Node_Id) is
2566 Stats : constant List_Id :=
2568 Make_Simple_Return_Statement (Loc,
2569 Expression => Make_Integer_Literal (Loc, Index + 1)));
2572 -- Index for current entry body
2576 -- Compute total length of entry queues so far
2584 Right_Opnd => Expr);
2589 Left_Opnd => Make_Identifier (Loc, Name_uE),
2592 -- Map entry queue indexes in the range of the current family
2593 -- into the current index, that designates the entry body.
2597 Make_Implicit_If_Statement (Typ,
2599 Then_Statements => Stats,
2600 Elsif_Parts => New_List);
2604 Append_To (Elsif_Parts (If_St),
2605 Make_Elsif_Part (Loc,
2607 Then_Statements => Stats));
2611 ------------------------------
2612 -- Convert_Discriminant_Ref --
2613 ------------------------------
2615 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
2619 if Is_Entity_Name (Bound)
2620 and then Ekind (Entity (Bound)) = E_Discriminant
2623 Make_Selected_Component (Loc,
2625 Unchecked_Convert_To (Corresponding_Record_Type (Typ),
2626 Make_Explicit_Dereference (Loc,
2627 Make_Identifier (Loc, Name_uObject))),
2628 Selector_Name => Make_Identifier (Loc, Chars (Bound)));
2629 Set_Etype (B, Etype (Entity (Bound)));
2631 B := New_Copy_Tree (Bound);
2635 end Convert_Discriminant_Ref;
2637 -- Start of processing for Build_Find_Body_Index
2640 Spec := Build_Find_Body_Index_Spec (Typ);
2642 Ent := First_Entity (Typ);
2643 while Present (Ent) loop
2644 if Ekind (Ent) = E_Entry_Family then
2654 -- If the protected type has no entry families, there is a one-one
2655 -- correspondence between entry queue and entry body.
2658 Make_Simple_Return_Statement (Loc,
2659 Expression => Make_Identifier (Loc, Name_uE));
2662 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2665 -- if E <= l1 then return 1;
2666 -- elsif E <= l1 + l2 then return 2;
2671 Ent := First_Entity (Typ);
2673 Add_Object_Pointer (Loc, Typ, Decls);
2675 while Present (Ent) loop
2676 if Ekind (Ent) = E_Entry then
2677 Add_If_Clause (Make_Integer_Literal (Loc, 1));
2679 elsif Ekind (Ent) = E_Entry_Family then
2680 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
2681 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
2682 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
2683 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
2692 Make_Simple_Return_Statement (Loc,
2693 Expression => Make_Integer_Literal (Loc, 1));
2695 elsif Nkind (Ret) = N_If_Statement then
2697 -- Ranges are in increasing order, so last one doesn't need guard
2700 Nod : constant Node_Id := Last (Elsif_Parts (Ret));
2703 Set_Else_Statements (Ret, Then_Statements (Nod));
2709 Make_Subprogram_Body (Loc,
2710 Specification => Spec,
2711 Declarations => Decls,
2712 Handled_Statement_Sequence =>
2713 Make_Handled_Sequence_Of_Statements (Loc,
2714 Statements => New_List (Ret)));
2715 end Build_Find_Body_Index;
2717 --------------------------------
2718 -- Build_Find_Body_Index_Spec --
2719 --------------------------------
2721 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
2722 Loc : constant Source_Ptr := Sloc (Typ);
2723 Id : constant Entity_Id :=
2724 Make_Defining_Identifier (Loc,
2725 Chars => New_External_Name (Chars (Typ), 'F'));
2726 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
2727 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
2731 Make_Function_Specification (Loc,
2732 Defining_Unit_Name => Id,
2733 Parameter_Specifications => New_List (
2734 Make_Parameter_Specification (Loc,
2735 Defining_Identifier => Parm1,
2737 New_Occurrence_Of (RTE (RE_Address), Loc)),
2739 Make_Parameter_Specification (Loc,
2740 Defining_Identifier => Parm2,
2742 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
2744 Result_Definition => New_Occurrence_Of (
2745 RTE (RE_Protected_Entry_Index), Loc));
2746 end Build_Find_Body_Index_Spec;
2748 -----------------------------------------------
2749 -- Build_Lock_Free_Protected_Subprogram_Body --
2750 -----------------------------------------------
2752 function Build_Lock_Free_Protected_Subprogram_Body
2755 Unprot_Spec : Node_Id) return Node_Id
2757 Actuals : constant List_Id := New_List;
2758 Loc : constant Source_Ptr := Sloc (N);
2759 Spec : constant Node_Id := Specification (N);
2760 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec);
2762 Prot_Spec : Node_Id;
2766 -- Create the protected version of the body
2769 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode);
2771 -- Build the actual parameters which appear in the call to the
2772 -- unprotected version of the body.
2774 Formal := First (Parameter_Specifications (Prot_Spec));
2775 while Present (Formal) loop
2777 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
2782 -- Function case, generate:
2783 -- return <Unprot_Func_Call>;
2785 if Nkind (Spec) = N_Function_Specification then
2787 Make_Simple_Return_Statement (Loc,
2789 Make_Function_Call (Loc,
2791 Make_Identifier (Loc, Chars (Unprot_Id)),
2792 Parameter_Associations => Actuals));
2794 -- Procedure case, call the unprotected version
2798 Make_Procedure_Call_Statement (Loc,
2800 Make_Identifier (Loc, Chars (Unprot_Id)),
2801 Parameter_Associations => Actuals);
2805 Make_Subprogram_Body (Loc,
2806 Declarations => Empty_List,
2807 Specification => Prot_Spec,
2808 Handled_Statement_Sequence =>
2809 Make_Handled_Sequence_Of_Statements (Loc,
2810 Statements => New_List (Stmt)));
2811 end Build_Lock_Free_Protected_Subprogram_Body;
2813 -------------------------------------------------
2814 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2815 -------------------------------------------------
2817 -- Procedures which meet the lock-free implementation requirements and
2818 -- reference a unique scalar component Comp are expanded in the following
2821 -- procedure P (...) is
2822 -- Expected_Comp : constant Comp_Type :=
2824 -- (System.Atomic_Primitives.Lock_Free_Read_N
2825 -- (_Object.Comp'Address));
2829 -- <original declarations before the object renaming declaration
2832 -- Desired_Comp : Comp_Type := Expected_Comp;
2833 -- Comp : Comp_Type renames Desired_Comp;
2835 -- <original delarations after the object renaming declaration
2839 -- <original statements>
2840 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2841 -- (_Object.Comp'Address,
2842 -- Interfaces.Unsigned_N (Expected_Comp),
2843 -- Interfaces.Unsigned_N (Desired_Comp));
2848 -- Each return and raise statement of P is transformed into an atomic
2851 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2852 -- (_Object.Comp'Address,
2853 -- Interfaces.Unsigned_N (Expected_Comp),
2854 -- Interfaces.Unsigned_N (Desired_Comp));
2856 -- <original statement>
2861 -- Functions which meet the lock-free implementation requirements and
2862 -- reference a unique scalar component Comp are expanded in the following
2865 -- function F (...) return ... is
2866 -- <original declarations before the object renaming declaration
2869 -- Expected_Comp : constant Comp_Type :=
2871 -- (System.Atomic_Primitives.Lock_Free_Read_N
2872 -- (_Object.Comp'Address));
2873 -- Comp : Comp_Type renames Expected_Comp;
2875 -- <original delarations after the object renaming declaration of
2879 -- <original statements>
2882 function Build_Lock_Free_Unprotected_Subprogram_Body
2884 Prot_Typ : Node_Id) return Node_Id
2886 function Referenced_Component (N : Node_Id) return Entity_Id;
2887 -- Subprograms which meet the lock-free implementation criteria are
2888 -- allowed to reference only one unique component. Return the prival
2889 -- of the said component.
2891 --------------------------
2892 -- Referenced_Component --
2893 --------------------------
2895 function Referenced_Component (N : Node_Id) return Entity_Id is
2898 Source_Comp : Entity_Id := Empty;
2901 -- Find the unique source component which N references in its
2904 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop
2906 Element : Lock_Free_Subprogram renames
2907 Lock_Free_Subprogram_Table.Table (Index);
2909 if Element.Sub_Body = N then
2910 Source_Comp := Element.Comp_Id;
2916 if No (Source_Comp) then
2920 -- Find the prival which corresponds to the source component within
2921 -- the declarations of N.
2923 Decl := First (Declarations (N));
2924 while Present (Decl) loop
2926 -- Privals appear as object renamings
2928 if Nkind (Decl) = N_Object_Renaming_Declaration then
2929 Comp := Defining_Identifier (Decl);
2931 if Present (Prival_Link (Comp))
2932 and then Prival_Link (Comp) = Source_Comp
2942 end Referenced_Component;
2946 Comp : constant Entity_Id := Referenced_Component (N);
2947 Loc : constant Source_Ptr := Sloc (N);
2948 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N);
2949 Decls : List_Id := Declarations (N);
2951 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
2954 -- Add renamings for the protection object, discriminals, privals, and
2955 -- the entry index constant for use by debugger.
2957 Debug_Private_Data_Declarations (Decls);
2959 -- Perform the lock-free expansion when the subprogram references a
2960 -- protected component.
2962 if Present (Comp) then
2963 Protected_Component_Ref : declare
2964 Comp_Decl : constant Node_Id := Parent (Comp);
2965 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl);
2966 Comp_Type : constant Entity_Id := Etype (Comp);
2968 Is_Procedure : constant Boolean :=
2969 Ekind (Corresponding_Spec (N)) = E_Procedure;
2970 -- Indicates if N is a protected procedure body
2972 Block_Decls : List_Id := No_List;
2973 Try_Write : Entity_Id;
2974 Desired_Comp : Entity_Id;
2977 Label_Id : Entity_Id := Empty;
2979 Expected_Comp : Entity_Id;
2982 New_Copy_List (Statements (Hand_Stmt_Seq));
2984 Unsigned : Entity_Id;
2986 function Process_Node (N : Node_Id) return Traverse_Result;
2987 -- Transform a single node if it is a return statement, a raise
2988 -- statement or a reference to Comp.
2990 procedure Process_Stmts (Stmts : List_Id);
2991 -- Given a statement sequence Stmts, wrap any return or raise
2992 -- statements in the following manner:
2994 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2995 -- (_Object.Comp'Address,
2996 -- Interfaces.Unsigned_N (Expected_Comp),
2997 -- Interfaces.Unsigned_N (Desired_Comp))
3008 function Process_Node (N : Node_Id) return Traverse_Result is
3010 procedure Wrap_Statement (Stmt : Node_Id);
3011 -- Wrap an arbitrary statement inside an if statement where the
3012 -- condition does an atomic check on the state of the object.
3014 --------------------
3015 -- Wrap_Statement --
3016 --------------------
3018 procedure Wrap_Statement (Stmt : Node_Id) is
3020 -- The first time through, create the declaration of a label
3021 -- which is used to skip the remainder of source statements
3022 -- if the state of the object has changed.
3024 if No (Label_Id) then
3026 Make_Identifier (Loc, New_External_Name ('L', 0));
3027 Set_Entity (Label_Id,
3028 Make_Defining_Identifier (Loc, Chars (Label_Id)));
3032 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3033 -- (_Object.Comp'Address,
3034 -- Interfaces.Unsigned_N (Expected_Comp),
3035 -- Interfaces.Unsigned_N (Desired_Comp))
3043 Make_Implicit_If_Statement (N,
3045 Make_Function_Call (Loc,
3047 New_Occurrence_Of (Try_Write, Loc),
3048 Parameter_Associations => New_List (
3049 Make_Attribute_Reference (Loc,
3050 Prefix => Relocate_Node (Comp_Sel_Nam),
3051 Attribute_Name => Name_Address),
3053 Unchecked_Convert_To (Unsigned,
3054 New_Occurrence_Of (Expected_Comp, Loc)),
3056 Unchecked_Convert_To (Unsigned,
3057 New_Occurrence_Of (Desired_Comp, Loc)))),
3059 Then_Statements => New_List (Relocate_Node (Stmt)),
3061 Else_Statements => New_List (
3062 Make_Goto_Statement (Loc,
3064 New_Occurrence_Of (Entity (Label_Id), Loc)))));
3067 -- Start of processing for Process_Node
3070 -- Wrap each return and raise statement that appear inside a
3071 -- procedure. Skip the last return statement which is added by
3072 -- default since it is transformed into an exit statement.
3075 and then ((Nkind (N) = N_Simple_Return_Statement
3076 and then N /= Last (Stmts))
3077 or else Nkind (N) = N_Extended_Return_Statement
3078 or else (Nkind_In (N, N_Raise_Constraint_Error,
3079 N_Raise_Program_Error,
3081 N_Raise_Storage_Error)
3082 and then Comes_From_Source (N)))
3090 Set_Analyzed (N, False);
3095 procedure Process_Nodes is new Traverse_Proc (Process_Node);
3101 procedure Process_Stmts (Stmts : List_Id) is
3104 Stmt := First (Stmts);
3105 while Present (Stmt) loop
3106 Process_Nodes (Stmt);
3111 -- Start of processing for Protected_Component_Ref
3114 -- Get the type size
3116 if Known_Static_Esize (Comp_Type) then
3117 Typ_Size := UI_To_Int (Esize (Comp_Type));
3119 -- If the Esize (Object_Size) is unknown at compile time, look at
3120 -- the RM_Size (Value_Size) since it may have been set by an
3121 -- explicit representation clause.
3123 elsif Known_Static_RM_Size (Comp_Type) then
3124 Typ_Size := UI_To_Int (RM_Size (Comp_Type));
3126 -- Should not happen since this has already been checked in
3127 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3130 raise Program_Error;
3133 -- Retrieve all relevant atomic routines and types
3137 Try_Write := RTE (RE_Lock_Free_Try_Write_8);
3138 Read := RTE (RE_Lock_Free_Read_8);
3139 Unsigned := RTE (RE_Uint8);
3142 Try_Write := RTE (RE_Lock_Free_Try_Write_16);
3143 Read := RTE (RE_Lock_Free_Read_16);
3144 Unsigned := RTE (RE_Uint16);
3147 Try_Write := RTE (RE_Lock_Free_Try_Write_32);
3148 Read := RTE (RE_Lock_Free_Read_32);
3149 Unsigned := RTE (RE_Uint32);
3152 Try_Write := RTE (RE_Lock_Free_Try_Write_64);
3153 Read := RTE (RE_Lock_Free_Read_64);
3154 Unsigned := RTE (RE_Uint64);
3157 raise Program_Error;
3161 -- Expected_Comp : constant Comp_Type :=
3163 -- (System.Atomic_Primitives.Lock_Free_Read_N
3164 -- (_Object.Comp'Address));
3167 Make_Defining_Identifier (Loc,
3168 New_External_Name (Chars (Comp), Suffix => "_saved"));
3171 Make_Object_Declaration (Loc,
3172 Defining_Identifier => Expected_Comp,
3173 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3174 Constant_Present => True,
3176 Unchecked_Convert_To (Comp_Type,
3177 Make_Function_Call (Loc,
3178 Name => New_Occurrence_Of (Read, Loc),
3179 Parameter_Associations => New_List (
3180 Make_Attribute_Reference (Loc,
3181 Prefix => Relocate_Node (Comp_Sel_Nam),
3182 Attribute_Name => Name_Address)))));
3184 -- Protected procedures
3186 if Is_Procedure then
3187 -- Move the original declarations inside the generated block
3189 Block_Decls := Decls;
3191 -- Reset the declarations list of the protected procedure to
3192 -- contain only Decl.
3194 Decls := New_List (Decl);
3197 -- Desired_Comp : Comp_Type := Expected_Comp;
3200 Make_Defining_Identifier (Loc,
3201 New_External_Name (Chars (Comp), Suffix => "_current"));
3203 -- Insert the declarations of Expected_Comp and Desired_Comp in
3204 -- the block declarations right before the renaming of the
3205 -- protected component.
3207 Insert_Before (Comp_Decl,
3208 Make_Object_Declaration (Loc,
3209 Defining_Identifier => Desired_Comp,
3210 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3212 New_Occurrence_Of (Expected_Comp, Loc)));
3214 -- Protected function
3217 Desired_Comp := Expected_Comp;
3219 -- Insert the declaration of Expected_Comp in the function
3220 -- declarations right before the renaming of the protected
3223 Insert_Before (Comp_Decl, Decl);
3226 -- Rewrite the protected component renaming declaration to be a
3227 -- renaming of Desired_Comp.
3230 -- Comp : Comp_Type renames Desired_Comp;
3233 Make_Object_Renaming_Declaration (Loc,
3234 Defining_Identifier =>
3235 Defining_Identifier (Comp_Decl),
3237 New_Occurrence_Of (Comp_Type, Loc),
3239 New_Occurrence_Of (Desired_Comp, Loc)));
3241 -- Wrap any return or raise statements in Stmts in same the manner
3242 -- described in Process_Stmts.
3244 Process_Stmts (Stmts);
3247 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3248 -- (_Object.Comp'Address,
3249 -- Interfaces.Unsigned_N (Expected_Comp),
3250 -- Interfaces.Unsigned_N (Desired_Comp))
3252 if Is_Procedure then
3254 Make_Exit_Statement (Loc,
3256 Make_Function_Call (Loc,
3258 New_Occurrence_Of (Try_Write, Loc),
3259 Parameter_Associations => New_List (
3260 Make_Attribute_Reference (Loc,
3261 Prefix => Relocate_Node (Comp_Sel_Nam),
3262 Attribute_Name => Name_Address),
3264 Unchecked_Convert_To (Unsigned,
3265 New_Occurrence_Of (Expected_Comp, Loc)),
3267 Unchecked_Convert_To (Unsigned,
3268 New_Occurrence_Of (Desired_Comp, Loc)))));
3270 -- Small optimization: transform the default return statement
3271 -- of a procedure into the atomic exit statement.
3273 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then
3274 Rewrite (Last (Stmts), Stmt);
3276 Append_To (Stmts, Stmt);
3280 -- Create the declaration of the label used to skip the rest of
3281 -- the source statements when the object state changes.
3283 if Present (Label_Id) then
3284 Label := Make_Label (Loc, Label_Id);
3286 Make_Implicit_Label_Declaration (Loc,
3287 Defining_Identifier => Entity (Label_Id),
3288 Label_Construct => Label));
3289 Append_To (Stmts, Label);
3301 if Is_Procedure then
3304 Make_Loop_Statement (Loc,
3305 Statements => New_List (
3306 Make_Block_Statement (Loc,
3307 Declarations => Block_Decls,
3308 Handled_Statement_Sequence =>
3309 Make_Handled_Sequence_Of_Statements (Loc,
3310 Statements => Stmts))),
3311 End_Label => Empty));
3315 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts);
3316 end Protected_Component_Ref;
3319 -- Make an unprotected version of the subprogram for use within the same
3320 -- object, with new name and extra parameter representing the object.
3323 Make_Subprogram_Body (Loc,
3325 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode),
3326 Declarations => Decls,
3327 Handled_Statement_Sequence => Hand_Stmt_Seq);
3328 end Build_Lock_Free_Unprotected_Subprogram_Body;
3330 -------------------------
3331 -- Build_Master_Entity --
3332 -------------------------
3334 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is
3335 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ);
3337 Context_Id : Entity_Id;
3343 if Is_Itype (Obj_Or_Typ) then
3344 Par := Associated_Node_For_Itype (Obj_Or_Typ);
3346 Par := Parent (Obj_Or_Typ);
3349 -- When creating a master for a record component which is either a task
3350 -- or access-to-task, the enclosing record is the master scope and the
3351 -- proper insertion point is the component list.
3353 if Is_Record_Type (Current_Scope) then
3355 Context_Id := Current_Scope;
3356 Decls := List_Containing (Context);
3358 -- Default case for object declarations and access types. Note that the
3359 -- context is updated to the nearest enclosing body, block, package, or
3360 -- return statement.
3363 Find_Enclosing_Context (Par, Context, Context_Id, Decls);
3366 -- Nothing to do if the context already has a master
3368 if Has_Master_Entity (Context_Id) then
3371 -- Nothing to do if tasks or tasking hierarchies are prohibited
3373 elsif Restriction_Active (No_Tasking)
3374 or else Restriction_Active (No_Task_Hierarchy)
3379 -- Create a master, generate:
3380 -- _Master : constant Master_Id := Current_Master.all;
3383 Make_Object_Declaration (Loc,
3384 Defining_Identifier =>
3385 Make_Defining_Identifier (Loc, Name_uMaster),
3386 Constant_Present => True,
3387 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
3389 Make_Explicit_Dereference (Loc,
3390 New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
3392 -- The master is inserted at the start of the declarative list of the
3395 Prepend_To (Decls, Decl);
3397 -- In certain cases where transient scopes are involved, the immediate
3398 -- scope is not always the proper master scope. Ensure that the master
3399 -- declaration and entity appear in the same context.
3401 if Context_Id /= Current_Scope then
3402 Push_Scope (Context_Id);
3409 -- Mark the enclosing scope and its associated construct as being task
3412 Set_Has_Master_Entity (Context_Id);
3414 while Present (Context)
3415 and then Nkind (Context) /= N_Compilation_Unit
3417 if Nkind_In (Context, N_Block_Statement,
3421 Set_Is_Task_Master (Context);
3424 elsif Nkind (Parent (Context)) = N_Subunit then
3425 Context := Corresponding_Stub (Parent (Context));
3428 Context := Parent (Context);
3430 end Build_Master_Entity;
3432 ---------------------------
3433 -- Build_Master_Renaming --
3434 ---------------------------
3436 procedure Build_Master_Renaming
3437 (Ptr_Typ : Entity_Id;
3438 Ins_Nod : Node_Id := Empty)
3440 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
3442 Master_Decl : Node_Id;
3443 Master_Id : Entity_Id;
3446 -- Nothing to do if tasks or tasking hierarchies are prohibited
3448 if Restriction_Active (No_Tasking)
3449 or else Restriction_Active (No_Task_Hierarchy)
3454 -- Determine the proper context to insert the master renaming
3456 if Present (Ins_Nod) then
3458 elsif Is_Itype (Ptr_Typ) then
3459 Context := Associated_Node_For_Itype (Ptr_Typ);
3461 Context := Parent (Ptr_Typ);
3465 -- <Ptr_Typ>M : Master_Id renames _Master;
3468 Make_Defining_Identifier (Loc,
3469 New_External_Name (Chars (Ptr_Typ), 'M'));
3472 Make_Object_Renaming_Declaration (Loc,
3473 Defining_Identifier => Master_Id,
3474 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
3475 Name => Make_Identifier (Loc, Name_uMaster));
3477 Insert_Action (Context, Master_Decl);
3479 -- The renamed master now services the access type
3481 Set_Master_Id (Ptr_Typ, Master_Id);
3482 end Build_Master_Renaming;
3484 -----------------------------------------
3485 -- Build_Private_Protected_Declaration --
3486 -----------------------------------------
3488 function Build_Private_Protected_Declaration
3489 (N : Node_Id) return Entity_Id
3491 procedure Analyze_Pragmas (From : Node_Id);
3492 -- Analyze all pragmas which follow arbitrary node From
3494 procedure Move_Pragmas (From : Node_Id; To : Node_Id);
3495 -- Find all suitable source pragmas at the top of subprogram body From's
3496 -- declarations and insert them after arbitrary node To.
3498 -- Very similar to Move_Pragmas in sem_ch6 ???
3500 ---------------------
3501 -- Analyze_Pragmas --
3502 ---------------------
3504 procedure Analyze_Pragmas (From : Node_Id) is
3508 Decl := Next (From);
3509 while Present (Decl) loop
3510 if Nkind (Decl) = N_Pragma then
3511 Analyze_Pragma (Decl);
3513 -- No candidate pragmas are available for analysis
3521 end Analyze_Pragmas;
3527 procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
3529 Insert_Nod : Node_Id;
3530 Next_Decl : Node_Id;
3533 pragma Assert (Nkind (From) = N_Subprogram_Body);
3535 -- The pragmas are moved in an order-preserving fashion
3539 -- Inspect the declarations of the subprogram body and relocate all
3540 -- candidate pragmas.
3542 Decl := First (Declarations (From));
3543 while Present (Decl) loop
3545 -- Preserve the following declaration for iteration purposes, due
3546 -- to possible relocation of a pragma.
3548 Next_Decl := Next (Decl);
3550 -- We add an exception here for Unreferenced pragmas since the
3551 -- internally generated spec gets analyzed within
3552 -- Build_Private_Protected_Declaration and will lead to spurious
3553 -- warnings due to the way references are checked.
3555 if Nkind (Decl) = N_Pragma
3556 and then Pragma_Name_Unmapped (Decl) /= Name_Unreferenced
3559 Insert_After (Insert_Nod, Decl);
3562 -- Skip internally generated code
3564 elsif not Comes_From_Source (Decl) then
3567 -- No candidate pragmas are available for relocation
3579 Body_Id : constant Entity_Id := Defining_Entity (N);
3580 Loc : constant Source_Ptr := Sloc (N);
3585 Spec_Id : Entity_Id;
3587 -- Start of processing for Build_Private_Protected_Declaration
3590 Formal := First_Formal (Body_Id);
3592 -- The protected operation always has at least one formal, namely the
3593 -- object itself, but it is only placed in the parameter list if
3594 -- expansion is enabled.
3596 if Present (Formal) or else Expander_Active then
3597 Formals := Copy_Parameter_List (Body_Id);
3603 Make_Defining_Identifier (Sloc (Body_Id),
3604 Chars => Chars (Body_Id));
3606 -- Indicate that the entity comes from source, to ensure that cross-
3607 -- reference information is properly generated. The body itself is
3608 -- rewritten during expansion, and the body entity will not appear in
3609 -- calls to the operation.
3611 Set_Comes_From_Source (Spec_Id, True);
3613 if Nkind (Specification (N)) = N_Procedure_Specification then
3615 Make_Procedure_Specification (Loc,
3616 Defining_Unit_Name => Spec_Id,
3617 Parameter_Specifications => Formals);
3620 Make_Function_Specification (Loc,
3621 Defining_Unit_Name => Spec_Id,
3622 Parameter_Specifications => Formals,
3623 Result_Definition =>
3624 New_Occurrence_Of (Etype (Body_Id), Loc));
3627 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
3628 Set_Corresponding_Body (Decl, Body_Id);
3629 Set_Corresponding_Spec (N, Spec_Id);
3631 Insert_Before (N, Decl);
3633 -- Associate all aspects and pragmas of the body with the spec. This
3634 -- ensures that these annotations apply to the initial declaration of
3635 -- the subprogram body.
3637 Move_Aspects (From => N, To => Decl);
3638 Move_Pragmas (From => N, To => Decl);
3642 -- The analysis of the spec may generate pragmas which require manual
3643 -- analysis. Since the generation of the spec and the relocation of the
3644 -- annotations is driven by the expansion of the stand-alone body, the
3645 -- pragmas will not be analyzed in a timely manner. Do this now.
3647 Analyze_Pragmas (Decl);
3649 Set_Convention (Spec_Id, Convention_Protected);
3650 Set_Has_Completion (Spec_Id);
3653 end Build_Private_Protected_Declaration;
3655 ---------------------------
3656 -- Build_Protected_Entry --
3657 ---------------------------
3659 function Build_Protected_Entry
3662 Pid : Node_Id) return Node_Id
3664 Bod_Decls : constant List_Id := New_List;
3665 Decls : constant List_Id := Declarations (N);
3666 End_Lab : constant Node_Id :=
3667 End_Label (Handled_Statement_Sequence (N));
3668 End_Loc : constant Source_Ptr :=
3669 Sloc (Last (Statements (Handled_Statement_Sequence (N))));
3670 -- Used for the generated call to Complete_Entry_Body
3672 Loc : constant Source_Ptr := Sloc (N);
3676 Bod_Stmts : List_Id;
3679 Proc_Body : Node_Id;
3681 EH_Loc : Source_Ptr;
3682 -- Used for the exception handler, inserted at end of the body
3685 -- Set the source location on the exception handler only when debugging
3686 -- the expanded code (see Make_Implicit_Exception_Handler).
3688 if Debug_Generated_Code then
3691 -- Otherwise the inserted code should not be visible to the debugger
3694 EH_Loc := No_Location;
3698 Make_Defining_Identifier (Loc,
3699 Chars => Chars (Protected_Body_Subprogram (Ent)));
3700 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty);
3702 -- Add the following declarations:
3704 -- type poVP is access poV;
3705 -- _object : poVP := poVP (_O);
3707 -- where _O is the formal parameter associated with the concurrent
3708 -- object. These declarations are needed for Complete_Entry_Body.
3710 Add_Object_Pointer (Loc, Pid, Bod_Decls);
3712 -- Add renamings for all formals, the Protection object, discriminals,
3713 -- privals and the entry index constant for use by debugger.
3715 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc);
3716 Debug_Private_Data_Declarations (Decls);
3718 -- Put the declarations and the statements from the entry
3722 Make_Block_Statement (Loc,
3723 Declarations => Decls,
3724 Handled_Statement_Sequence => Handled_Statement_Sequence (N)));
3726 -- Analyze now and reset scopes for declarations so that Scope fields
3727 -- currently denoting the entry will now denote the block scope, and
3728 -- the block's scope will be set to the new procedure entity.
3730 Analyze_Statements (Bod_Stmts);
3732 Set_Scope (Entity (Identifier (First (Bod_Stmts))), Bod_Id);
3735 (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts))));
3737 case Corresponding_Runtime_Package (Pid) is
3738 when System_Tasking_Protected_Objects_Entries =>
3739 Append_To (Bod_Stmts,
3740 Make_Procedure_Call_Statement (End_Loc,
3742 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
3743 Parameter_Associations => New_List (
3744 Make_Attribute_Reference (End_Loc,
3746 Make_Selected_Component (End_Loc,
3748 Make_Identifier (End_Loc, Name_uObject),
3750 Make_Identifier (End_Loc, Name_uObject)),
3751 Attribute_Name => Name_Unchecked_Access))));
3753 when System_Tasking_Protected_Objects_Single_Entry =>
3755 -- Historically, a call to Complete_Single_Entry_Body was
3756 -- inserted, but it was a null procedure.
3761 raise Program_Error;
3764 -- When exceptions cannot be propagated, we never need to call
3765 -- Exception_Complete_Entry_Body.
3767 if No_Exception_Handlers_Set then
3769 Make_Subprogram_Body (Loc,
3770 Specification => Bod_Spec,
3771 Declarations => Bod_Decls,
3772 Handled_Statement_Sequence =>
3773 Make_Handled_Sequence_Of_Statements (Loc,
3774 Statements => Bod_Stmts,
3775 End_Label => End_Lab));
3778 Ohandle := Make_Others_Choice (Loc);
3779 Set_All_Others (Ohandle);
3781 case Corresponding_Runtime_Package (Pid) is
3782 when System_Tasking_Protected_Objects_Entries =>
3785 (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
3787 when System_Tasking_Protected_Objects_Single_Entry =>
3790 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
3793 raise Program_Error;
3796 -- Establish link between subprogram body entity and source entry
3798 Set_Corresponding_Protected_Entry (Bod_Id, Ent);
3800 -- Create body of entry procedure. The renaming declarations are
3801 -- placed ahead of the block that contains the actual entry body.
3804 Make_Subprogram_Body (Loc,
3805 Specification => Bod_Spec,
3806 Declarations => Bod_Decls,
3807 Handled_Statement_Sequence =>
3808 Make_Handled_Sequence_Of_Statements (Loc,
3809 Statements => Bod_Stmts,
3810 End_Label => End_Lab,
3811 Exception_Handlers => New_List (
3812 Make_Implicit_Exception_Handler (EH_Loc,
3813 Exception_Choices => New_List (Ohandle),
3815 Statements => New_List (
3816 Make_Procedure_Call_Statement (EH_Loc,
3818 Parameter_Associations => New_List (
3819 Make_Attribute_Reference (EH_Loc,
3821 Make_Selected_Component (EH_Loc,
3823 Make_Identifier (EH_Loc, Name_uObject),
3825 Make_Identifier (EH_Loc, Name_uObject)),
3826 Attribute_Name => Name_Unchecked_Access),
3828 Make_Function_Call (EH_Loc,
3831 (RTE (RE_Get_GNAT_Exception), Loc)))))))));
3833 Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent));
3836 end Build_Protected_Entry;
3838 -----------------------------------------
3839 -- Build_Protected_Entry_Specification --
3840 -----------------------------------------
3842 function Build_Protected_Entry_Specification
3845 Ent_Id : Entity_Id) return Node_Id
3847 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP);
3850 Set_Debug_Info_Needed (Def_Id);
3852 if Present (Ent_Id) then
3853 Append_Elmt (P, Accept_Address (Ent_Id));
3857 Make_Procedure_Specification (Loc,
3858 Defining_Unit_Name => Def_Id,
3859 Parameter_Specifications => New_List (
3860 Make_Parameter_Specification (Loc,
3861 Defining_Identifier =>
3862 Make_Defining_Identifier (Loc, Name_uO),
3864 New_Occurrence_Of (RTE (RE_Address), Loc)),
3866 Make_Parameter_Specification (Loc,
3867 Defining_Identifier => P,
3869 New_Occurrence_Of (RTE (RE_Address), Loc)),
3871 Make_Parameter_Specification (Loc,
3872 Defining_Identifier =>
3873 Make_Defining_Identifier (Loc, Name_uE),
3875 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))));
3876 end Build_Protected_Entry_Specification;
3878 --------------------------
3879 -- Build_Protected_Spec --
3880 --------------------------
3882 function Build_Protected_Spec
3884 Obj_Type : Entity_Id;
3886 Unprotected : Boolean := False) return List_Id
3888 Loc : constant Source_Ptr := Sloc (N);
3891 New_Plist : List_Id;
3892 New_Param : Node_Id;
3895 New_Plist := New_List;
3897 Formal := First_Formal (Ident);
3898 while Present (Formal) loop
3900 Make_Parameter_Specification (Loc,
3901 Defining_Identifier =>
3902 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
3903 Aliased_Present => Aliased_Present (Parent (Formal)),
3904 In_Present => In_Present (Parent (Formal)),
3905 Out_Present => Out_Present (Parent (Formal)),
3906 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc));
3909 Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
3910 Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal));
3913 Append (New_Param, New_Plist);
3914 Next_Formal (Formal);
3917 -- If the subprogram is a procedure and the context is not an access
3918 -- to protected subprogram, the parameter is in-out. Otherwise it is
3922 Make_Parameter_Specification (Loc,
3923 Defining_Identifier =>
3924 Make_Defining_Identifier (Loc, Name_uObject),
3927 (Etype (Ident) = Standard_Void_Type
3928 and then not Is_RTE (Obj_Type, RE_Address)),
3930 New_Occurrence_Of (Obj_Type, Loc));
3931 Set_Debug_Info_Needed (Defining_Identifier (Decl));
3932 Prepend_To (New_Plist, Decl);
3935 end Build_Protected_Spec;
3937 ---------------------------------------
3938 -- Build_Protected_Sub_Specification --
3939 ---------------------------------------
3941 function Build_Protected_Sub_Specification
3943 Prot_Typ : Entity_Id;
3944 Mode : Subprogram_Protection_Mode) return Node_Id
3946 Loc : constant Source_Ptr := Sloc (N);
3950 New_Plist : List_Id;
3953 Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
3954 (Dispatching_Mode => ' ',
3955 Protected_Mode => 'P',
3956 Unprotected_Mode => 'N');
3959 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
3961 Decl := Unit_Declaration_Node (Corresponding_Spec (N));
3966 Def_Id := Defining_Unit_Name (Specification (Decl));
3969 Build_Protected_Spec
3970 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id,
3971 Mode = Unprotected_Mode);
3973 Make_Defining_Identifier (Loc,
3974 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
3976 -- Reference the original nondispatching subprogram since the analysis
3977 -- of the object.operation notation may need its original name (see
3978 -- Sem_Ch4.Names_Match).
3980 if Mode = Dispatching_Mode then
3981 Set_Ekind (New_Id, Ekind (Def_Id));
3982 Set_Original_Protected_Subprogram (New_Id, Def_Id);
3985 -- Link the protected or unprotected version to the original subprogram
3988 Set_Ekind (New_Id, Ekind (Def_Id));
3989 Set_Protected_Subprogram (New_Id, Def_Id);
3991 -- The unprotected operation carries the user code, and debugging
3992 -- information must be generated for it, even though this spec does
3993 -- not come from source. It is also convenient to allow gdb to step
3994 -- into the protected operation, even though it only contains lock/
3997 Set_Debug_Info_Needed (New_Id);
3999 -- If a pragma Eliminate applies to the source entity, the internal
4000 -- subprograms will be eliminated as well.
4002 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
4004 if Nkind (Specification (Decl)) = N_Procedure_Specification then
4006 Make_Procedure_Specification (Loc,
4007 Defining_Unit_Name => New_Id,
4008 Parameter_Specifications => New_Plist);
4010 -- Create a new specification for the anonymous subprogram type
4014 Make_Function_Specification (Loc,
4015 Defining_Unit_Name => New_Id,
4016 Parameter_Specifications => New_Plist,
4017 Result_Definition =>
4018 Copy_Result_Type (Result_Definition (Specification (Decl))));
4020 Set_Return_Present (Defining_Unit_Name (New_Spec));
4024 end Build_Protected_Sub_Specification;
4026 -------------------------------------
4027 -- Build_Protected_Subprogram_Body --
4028 -------------------------------------
4030 function Build_Protected_Subprogram_Body
4033 N_Op_Spec : Node_Id) return Node_Id
4035 Exc_Safe : constant Boolean := not Might_Raise (N);
4036 -- True if N cannot raise an exception
4038 Loc : constant Source_Ptr := Sloc (N);
4039 Op_Spec : constant Node_Id := Specification (N);
4040 P_Op_Spec : constant Node_Id :=
4041 Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
4044 Lock_Name : Node_Id;
4045 Lock_Stmt : Node_Id;
4046 Object_Parm : Node_Id;
4049 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
4050 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
4054 Unprot_Call : Node_Id;
4057 -- Build a list of the formal parameters of the protected version of
4058 -- the subprogram to use as the actual parameters of the unprotected
4061 Uactuals := New_List;
4062 Pformal := First (Parameter_Specifications (P_Op_Spec));
4063 while Present (Pformal) loop
4064 Append_To (Uactuals,
4065 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
4069 -- Make a call to the unprotected version of the subprogram built above
4070 -- for use by the protected version built below.
4072 if Nkind (Op_Spec) = N_Function_Specification then
4074 R := Make_Temporary (Loc, 'R');
4077 Make_Object_Declaration (Loc,
4078 Defining_Identifier => R,
4079 Constant_Present => True,
4080 Object_Definition =>
4081 New_Copy (Result_Definition (N_Op_Spec)),
4083 Make_Function_Call (Loc,
4085 Make_Identifier (Loc,
4086 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4087 Parameter_Associations => Uactuals));
4090 Make_Simple_Return_Statement (Loc,
4091 Expression => New_Occurrence_Of (R, Loc));
4095 Make_Simple_Return_Statement (Loc,
4097 Make_Function_Call (Loc,
4099 Make_Identifier (Loc,
4100 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4101 Parameter_Associations => Uactuals));
4104 Lock_Kind := RE_Lock_Read_Only;
4108 Make_Procedure_Call_Statement (Loc,
4110 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
4111 Parameter_Associations => Uactuals);
4113 Lock_Kind := RE_Lock;
4116 -- Wrap call in block that will be covered by an at_end handler
4118 if not Exc_Safe then
4120 Make_Block_Statement (Loc,
4121 Handled_Statement_Sequence =>
4122 Make_Handled_Sequence_Of_Statements (Loc,
4123 Statements => New_List (Unprot_Call)));
4126 -- Make the protected subprogram body. This locks the protected
4127 -- object and calls the unprotected version of the subprogram.
4129 case Corresponding_Runtime_Package (Pid) is
4130 when System_Tasking_Protected_Objects_Entries =>
4131 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc);
4133 when System_Tasking_Protected_Objects_Single_Entry =>
4134 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc);
4136 when System_Tasking_Protected_Objects =>
4137 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc);
4140 raise Program_Error;
4144 Make_Attribute_Reference (Loc,
4146 Make_Selected_Component (Loc,
4147 Prefix => Make_Identifier (Loc, Name_uObject),
4148 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4149 Attribute_Name => Name_Unchecked_Access);
4152 Make_Procedure_Call_Statement (Loc,
4154 Parameter_Associations => New_List (Object_Parm));
4156 if Abort_Allowed then
4158 Build_Runtime_Call (Loc, RE_Abort_Defer),
4162 Stmts := New_List (Lock_Stmt);
4165 if not Exc_Safe then
4166 Append (Unprot_Call, Stmts);
4168 if Nkind (Op_Spec) = N_Function_Specification then
4170 Stmts := Empty_List;
4172 Append (Unprot_Call, Stmts);
4175 -- Historical note: Previously, call to the cleanup was inserted
4176 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4177 -- which is also shared by the 'not Exc_Safe' path.
4179 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
4181 if Nkind (Op_Spec) = N_Function_Specification then
4182 Append_To (Stmts, Return_Stmt);
4183 Append_To (Pre_Stmts,
4184 Make_Block_Statement (Loc,
4185 Declarations => New_List (Unprot_Call),
4186 Handled_Statement_Sequence =>
4187 Make_Handled_Sequence_Of_Statements (Loc,
4188 Statements => Stmts)));
4194 Make_Subprogram_Body (Loc,
4195 Declarations => Empty_List,
4196 Specification => P_Op_Spec,
4197 Handled_Statement_Sequence =>
4198 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
4200 -- Mark this subprogram as a protected subprogram body so that the
4201 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4202 -- path as otherwise the cleanup has already been inserted.
4204 if not Exc_Safe then
4205 Set_Is_Protected_Subprogram_Body (Sub_Body);
4209 end Build_Protected_Subprogram_Body;
4211 -------------------------------------
4212 -- Build_Protected_Subprogram_Call --
4213 -------------------------------------
4215 procedure Build_Protected_Subprogram_Call
4219 External : Boolean := True)
4221 Loc : constant Source_Ptr := Sloc (N);
4222 Sub : constant Entity_Id := Entity (Name);
4228 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
4231 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
4234 if Present (Parameter_Associations (N)) then
4235 Params := New_Copy_List_Tree (Parameter_Associations (N));
4240 -- If the type is an untagged derived type, convert to the root type,
4241 -- which is the one on which the operations are defined.
4243 if Nkind (Rec) = N_Unchecked_Type_Conversion
4244 and then not Is_Tagged_Type (Etype (Rec))
4245 and then Is_Derived_Type (Etype (Rec))
4247 Set_Etype (Rec, Root_Type (Etype (Rec)));
4248 Set_Subtype_Mark (Rec,
4249 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
4252 Prepend (Rec, Params);
4254 if Ekind (Sub) = E_Procedure then
4256 Make_Procedure_Call_Statement (Loc,
4258 Parameter_Associations => Params));
4261 pragma Assert (Ekind (Sub) = E_Function);
4263 Make_Function_Call (Loc,
4265 Parameter_Associations => Params));
4267 -- Preserve type of call for subsequent processing (required for
4268 -- call to Wrap_Transient_Expression in the case of a shared passive
4271 Set_Etype (N, Etype (New_Sub));
4275 and then Nkind (Rec) = N_Unchecked_Type_Conversion
4276 and then Is_Entity_Name (Expression (Rec))
4277 and then Is_Shared_Passive (Entity (Expression (Rec)))
4279 Add_Shared_Var_Lock_Procs (N);
4281 end Build_Protected_Subprogram_Call;
4283 ---------------------------------------------
4284 -- Build_Protected_Subprogram_Call_Cleanup --
4285 ---------------------------------------------
4287 procedure Build_Protected_Subprogram_Call_Cleanup
4296 -- If the associated protected object has entries, a protected
4297 -- procedure has to service entry queues. In this case generate:
4299 -- Service_Entries (_object._object'Access);
4301 if Nkind (Op_Spec) = N_Procedure_Specification
4302 and then Has_Entries (Conc_Typ)
4304 case Corresponding_Runtime_Package (Conc_Typ) is
4305 when System_Tasking_Protected_Objects_Entries =>
4306 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc);
4308 when System_Tasking_Protected_Objects_Single_Entry =>
4309 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc);
4312 raise Program_Error;
4316 Make_Procedure_Call_Statement (Loc,
4318 Parameter_Associations => New_List (
4319 Make_Attribute_Reference (Loc,
4321 Make_Selected_Component (Loc,
4322 Prefix => Make_Identifier (Loc, Name_uObject),
4323 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4324 Attribute_Name => Name_Unchecked_Access))));
4328 -- Unlock (_object._object'Access);
4330 case Corresponding_Runtime_Package (Conc_Typ) is
4331 when System_Tasking_Protected_Objects_Entries =>
4332 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc);
4334 when System_Tasking_Protected_Objects_Single_Entry =>
4335 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc);
4337 when System_Tasking_Protected_Objects =>
4338 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc);
4341 raise Program_Error;
4345 Make_Procedure_Call_Statement (Loc,
4347 Parameter_Associations => New_List (
4348 Make_Attribute_Reference (Loc,
4350 Make_Selected_Component (Loc,
4351 Prefix => Make_Identifier (Loc, Name_uObject),
4352 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4353 Attribute_Name => Name_Unchecked_Access))));
4359 if Abort_Allowed then
4360 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4362 end Build_Protected_Subprogram_Call_Cleanup;
4364 -------------------------
4365 -- Build_Selected_Name --
4366 -------------------------
4368 function Build_Selected_Name
4369 (Prefix : Entity_Id;
4370 Selector : Entity_Id;
4371 Append_Char : Character := ' ') return Name_Id
4373 Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
4374 Select_Len : Natural;
4377 Get_Name_String (Chars (Selector));
4378 Select_Len := Name_Len;
4379 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
4380 Get_Name_String (Chars (Prefix));
4382 -- If scope is anonymous type, discard suffix to recover name of
4383 -- single protected object. Otherwise use protected type name.
4385 if Name_Buffer (Name_Len) = 'T' then
4386 Name_Len := Name_Len - 1;
4389 Add_Str_To_Name_Buffer ("__");
4390 for J in 1 .. Select_Len loop
4391 Add_Char_To_Name_Buffer (Select_Buffer (J));
4394 -- Now add the Append_Char if specified. The encoding to follow
4395 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4396 -- then the entity is associated to a protected type subprogram.
4397 -- Otherwise, it is a protected type entry. For each case, the
4398 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4400 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4402 if Append_Char /= ' ' then
4403 if Append_Char = 'P' or Append_Char = 'N' then
4404 Add_Char_To_Name_Buffer (Append_Char);
4407 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
4408 return New_External_Name (Name_Find, ' ', -1);
4413 end Build_Selected_Name;
4415 -----------------------------
4416 -- Build_Simple_Entry_Call --
4417 -----------------------------
4419 -- A task entry call is converted to a call to Call_Simple
4422 -- P : parms := (parm, parm, parm);
4424 -- Call_Simple (acceptor-task, entry-index, P'Address);
4430 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4431 -- the parameters, and the constructed aggregate value contains either the
4432 -- parameters or, in the case of non-elementary types, references to these
4433 -- parameters. Then the address of this aggregate is passed to the runtime
4434 -- routine, along with the task id value and the task entry index value.
4435 -- Pnn is only required if parameters are present.
4437 -- The assignments after the call are present only in the case of in-out
4438 -- or out parameters for elementary types, and are used to assign back the
4439 -- resulting values of such parameters.
4441 -- Note: the reason that we insert a block here is that in the context
4442 -- of selects, conditional entry calls etc. the entry call statement
4443 -- appears on its own, not as an element of a list.
4445 -- A protected entry call is converted to a Protected_Entry_Call:
4448 -- P : E1_Params := (param, param, param);
4450 -- Bnn : Communications_Block;
4453 -- P : E1_Params := (param, param, param);
4454 -- Bnn : Communications_Block;
4457 -- Protected_Entry_Call (
4458 -- Object => po._object'Access,
4459 -- E => <entry index>;
4460 -- Uninterpreted_Data => P'Address;
4461 -- Mode => Simple_Call;
4468 procedure Build_Simple_Entry_Call
4477 -- If call has been inlined, nothing left to do
4479 if Nkind (N) = N_Block_Statement then
4483 -- Convert entry call to Call_Simple call
4486 Loc : constant Source_Ptr := Sloc (N);
4487 Parms : constant List_Id := Parameter_Associations (N);
4488 Stats : constant List_Id := New_List;
4491 Comm_Name : Entity_Id;
4495 Ent_Acc : Entity_Id;
4497 Iface_Tag : Entity_Id;
4498 Iface_Typ : Entity_Id;
4511 -- Simple entry and entry family cases merge here
4513 Ent := Entity (Ename);
4514 Ent_Acc := Entry_Parameters_Type (Ent);
4515 Conctyp := Etype (Concval);
4517 -- If prefix is an access type, dereference to obtain the task type
4519 if Is_Access_Type (Conctyp) then
4520 Conctyp := Designated_Type (Conctyp);
4523 -- Special case for protected subprogram calls
4525 if Is_Protected_Type (Conctyp)
4526 and then Is_Subprogram (Entity (Ename))
4528 if not Is_Eliminated (Entity (Ename)) then
4529 Build_Protected_Subprogram_Call
4530 (N, Ename, Convert_Concurrent (Concval, Conctyp));
4537 -- First parameter is the Task_Id value from the task value or the
4538 -- Object from the protected object value, obtained by selecting
4539 -- the _Task_Id or _Object from the result of doing an unchecked
4540 -- conversion to convert the value to the corresponding record type.
4542 if Nkind (Concval) = N_Function_Call
4543 and then Is_Task_Type (Conctyp)
4544 and then Ada_Version >= Ada_2005
4547 ExpR : constant Node_Id := Relocate_Node (Concval);
4548 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR);
4553 Make_Object_Declaration (Loc,
4554 Defining_Identifier => Obj,
4555 Object_Definition => New_Occurrence_Of (Conctyp, Loc),
4556 Expression => ExpR);
4557 Set_Etype (Obj, Conctyp);
4558 Decls := New_List (Decl);
4559 Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
4566 Parm1 := Concurrent_Ref (Concval);
4568 -- Second parameter is the entry index, computed by the routine
4569 -- provided for this purpose. The value of this expression is
4570 -- assigned to an intermediate variable to assure that any entry
4571 -- family index expressions are evaluated before the entry
4574 if not Is_Protected_Type (Conctyp)
4576 Corresponding_Runtime_Package (Conctyp) =
4577 System_Tasking_Protected_Objects_Entries
4579 X := Make_Defining_Identifier (Loc, Name_uX);
4582 Make_Object_Declaration (Loc,
4583 Defining_Identifier => X,
4584 Object_Definition =>
4585 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
4586 Expression => Actual_Index_Expression (
4587 Loc, Entity (Ename), Index, Concval));
4589 Append_To (Decls, Xdecl);
4590 Parm2 := New_Occurrence_Of (X, Loc);
4597 -- The third parameter is the packaged parameters. If there are
4598 -- none, then it is just the null address, since nothing is passed.
4601 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
4604 -- Case of parameters present, where third argument is the address
4605 -- of a packaged record containing the required parameter values.
4608 -- First build a list of parameter values, which are references to
4609 -- objects of the parameter types.
4613 Actual := First_Actual (N);
4614 Formal := First_Formal (Ent);
4615 while Present (Actual) loop
4617 -- If it is a by-copy type, copy it to a new variable. The
4618 -- packaged record has a field that points to this variable.
4620 if Is_By_Copy_Type (Etype (Actual)) then
4622 Make_Object_Declaration (Loc,
4623 Defining_Identifier => Make_Temporary (Loc, 'J'),
4624 Aliased_Present => True,
4625 Object_Definition =>
4626 New_Occurrence_Of (Etype (Formal), Loc));
4628 -- Mark the object as not needing initialization since the
4629 -- initialization is performed separately, avoiding errors
4630 -- on cases such as formals of null-excluding access types.
4632 Set_No_Initialization (N_Node);
4634 -- We must make a separate assignment statement for the
4635 -- case of limited types. We cannot assign it unless the
4636 -- Assignment_OK flag is set first. An out formal of an
4637 -- access type or whose type has a Default_Value must also
4638 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4639 -- but no constraint, predicate, or null-exclusion check is
4640 -- applied before the call.
4642 if Ekind (Formal) /= E_Out_Parameter
4643 or else Is_Access_Type (Etype (Formal))
4645 (Is_Scalar_Type (Etype (Formal))
4647 Present (Default_Aspect_Value (Etype (Formal))))
4650 New_Occurrence_Of (Defining_Identifier (N_Node), Loc);
4651 Set_Assignment_OK (N_Var);
4653 Make_Assignment_Statement (Loc,
4655 Expression => Relocate_Node (Actual)));
4657 -- Mark the object as internal, so we don't later reset
4658 -- No_Initialization flag in Default_Initialize_Object,
4659 -- which would lead to needless default initialization.
4660 -- We don't set this outside the if statement, because
4661 -- out scalar parameters without Default_Value do require
4662 -- default initialization if Initialize_Scalars applies.
4664 Set_Is_Internal (Defining_Identifier (N_Node));
4666 -- If actual is an out parameter of a null-excluding
4667 -- access type, there is access check on entry, so set
4668 -- Suppress_Assignment_Checks on the generated statement
4669 -- that assigns the actual to the parameter block.
4671 Set_Suppress_Assignment_Checks (Last (Stats));
4674 Append (N_Node, Decls);
4677 Make_Attribute_Reference (Loc,
4678 Attribute_Name => Name_Unchecked_Access,
4681 (Defining_Identifier (N_Node), Loc)));
4684 -- Interface class-wide formal
4686 if Ada_Version >= Ada_2005
4687 and then Ekind (Etype (Formal)) = E_Class_Wide_Type
4688 and then Is_Interface (Etype (Formal))
4690 Iface_Typ := Etype (Etype (Formal));
4693 -- formal_iface_type! (actual.iface_tag)'reference
4696 Find_Interface_Tag (Etype (Actual), Iface_Typ);
4697 pragma Assert (Present (Iface_Tag));
4700 Make_Reference (Loc,
4701 Unchecked_Convert_To (Iface_Typ,
4702 Make_Selected_Component (Loc,
4704 Relocate_Node (Actual),
4706 New_Occurrence_Of (Iface_Tag, Loc)))));
4712 Make_Reference (Loc, Relocate_Node (Actual)));
4716 Next_Actual (Actual);
4717 Next_Formal_With_Extras (Formal);
4720 -- Now build the declaration of parameters initialized with the
4721 -- aggregate containing this constructed parameter list.
4723 P := Make_Defining_Identifier (Loc, Name_uP);
4726 Make_Object_Declaration (Loc,
4727 Defining_Identifier => P,
4728 Object_Definition =>
4729 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc),
4731 Make_Aggregate (Loc, Expressions => Plist));
4734 Make_Attribute_Reference (Loc,
4735 Prefix => New_Occurrence_Of (P, Loc),
4736 Attribute_Name => Name_Address);
4738 Append (Pdecl, Decls);
4741 -- Now we can create the call, case of protected type
4743 if Is_Protected_Type (Conctyp) then
4744 case Corresponding_Runtime_Package (Conctyp) is
4745 when System_Tasking_Protected_Objects_Entries =>
4747 -- Change the type of the index declaration
4749 Set_Object_Definition (Xdecl,
4750 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc));
4752 -- Some additional declarations for protected entry calls
4758 -- Bnn : Communications_Block;
4760 Comm_Name := Make_Temporary (Loc, 'B');
4763 Make_Object_Declaration (Loc,
4764 Defining_Identifier => Comm_Name,
4765 Object_Definition =>
4767 (RTE (RE_Communication_Block), Loc)));
4769 -- Some additional statements for protected entry calls
4771 -- Protected_Entry_Call
4772 -- (Object => po._object'Access,
4773 -- E => <entry index>;
4774 -- Uninterpreted_Data => P'Address;
4775 -- Mode => Simple_Call;
4779 Make_Procedure_Call_Statement (Loc,
4781 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
4783 Parameter_Associations => New_List (
4784 Make_Attribute_Reference (Loc,
4785 Attribute_Name => Name_Unchecked_Access,
4789 New_Occurrence_Of (RTE (RE_Simple_Call), Loc),
4790 New_Occurrence_Of (Comm_Name, Loc)));
4792 when System_Tasking_Protected_Objects_Single_Entry =>
4794 -- Protected_Single_Entry_Call
4795 -- (Object => po._object'Access,
4796 -- Uninterpreted_Data => P'Address);
4799 Make_Procedure_Call_Statement (Loc,
4802 (RTE (RE_Protected_Single_Entry_Call), Loc),
4804 Parameter_Associations => New_List (
4805 Make_Attribute_Reference (Loc,
4806 Attribute_Name => Name_Unchecked_Access,
4811 raise Program_Error;
4814 -- Case of task type
4818 Make_Procedure_Call_Statement (Loc,
4820 New_Occurrence_Of (RTE (RE_Call_Simple), Loc),
4821 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
4825 Append_To (Stats, Call);
4827 -- If there are out or in/out parameters by copy add assignment
4828 -- statements for the result values.
4830 if Present (Parms) then
4831 Actual := First_Actual (N);
4832 Formal := First_Formal (Ent);
4834 Set_Assignment_OK (Actual);
4835 while Present (Actual) loop
4836 if Is_By_Copy_Type (Etype (Actual))
4837 and then Ekind (Formal) /= E_In_Parameter
4840 Make_Assignment_Statement (Loc,
4841 Name => New_Copy (Actual),
4843 Make_Explicit_Dereference (Loc,
4844 Make_Selected_Component (Loc,
4845 Prefix => New_Occurrence_Of (P, Loc),
4847 Make_Identifier (Loc, Chars (Formal)))));
4849 -- In all cases (including limited private types) we want
4850 -- the assignment to be valid.
4852 Set_Assignment_OK (Name (N_Node));
4854 -- If the call is the triggering alternative in an
4855 -- asynchronous select, or the entry_call alternative of a
4856 -- conditional entry call, the assignments for in-out
4857 -- parameters are incorporated into the statement list that
4858 -- follows, so that there are executed only if the entry
4861 if (Nkind (Parent (N)) = N_Triggering_Alternative
4862 and then N = Triggering_Statement (Parent (N)))
4864 (Nkind (Parent (N)) = N_Entry_Call_Alternative
4865 and then N = Entry_Call_Statement (Parent (N)))
4867 if No (Statements (Parent (N))) then
4868 Set_Statements (Parent (N), New_List);
4871 Prepend (N_Node, Statements (Parent (N)));
4874 Insert_After (Call, N_Node);
4878 Next_Actual (Actual);
4879 Next_Formal_With_Extras (Formal);
4883 -- Finally, create block and analyze it
4886 Make_Block_Statement (Loc,
4887 Declarations => Decls,
4888 Handled_Statement_Sequence =>
4889 Make_Handled_Sequence_Of_Statements (Loc,
4890 Statements => Stats)));
4894 end Build_Simple_Entry_Call;
4896 --------------------------------
4897 -- Build_Task_Activation_Call --
4898 --------------------------------
4900 procedure Build_Task_Activation_Call (N : Node_Id) is
4901 function Activation_Call_Loc return Source_Ptr;
4902 -- Find a suitable source location for the activation call
4904 -------------------------
4905 -- Activation_Call_Loc --
4906 -------------------------
4908 function Activation_Call_Loc return Source_Ptr is
4910 -- The activation call must carry the location of the "end" keyword
4911 -- when the context is a package declaration.
4913 if Nkind (N) = N_Package_Declaration then
4914 return End_Keyword_Location (N);
4916 -- Otherwise the activation call must carry the location of the
4920 return Begin_Keyword_Location (N);
4922 end Activation_Call_Loc;
4933 -- Start of processing for Build_Task_Activation_Call
4936 -- For sequential elaboration policy, all the tasks will be activated at
4937 -- the end of the elaboration.
4939 if Partition_Elaboration_Policy = 'S' then
4942 -- Do not create an activation call for a package spec if the package
4943 -- has a completing body. The activation call will be inserted after
4944 -- the "begin" of the body.
4946 elsif Nkind (N) = N_Package_Declaration
4947 and then Present (Corresponding_Body (N))
4952 -- Obtain the activation chain entity. Block statements, entry bodies,
4953 -- subprogram bodies, and task bodies keep the entity in their nodes.
4954 -- Package bodies on the other hand store it in the declaration of the
4955 -- corresponding package spec.
4959 if Nkind (Owner) = N_Package_Body then
4960 Owner := Unit_Declaration_Node (Corresponding_Spec (Owner));
4963 Chain := Activation_Chain_Entity (Owner);
4965 -- Nothing to do when there are no tasks to activate. This is indicated
4966 -- by a missing activation chain entity.
4972 -- The location of the activation call must be as close as possible to
4973 -- the intended semantic location of the activation because the ABE
4974 -- mechanism relies heavily on accurate locations.
4976 Loc := Activation_Call_Loc;
4978 if Restricted_Profile then
4979 Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc);
4981 Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc);
4985 Make_Procedure_Call_Statement (Loc,
4987 Parameter_Associations =>
4988 New_List (Make_Attribute_Reference (Loc,
4989 Prefix => New_Occurrence_Of (Chain, Loc),
4990 Attribute_Name => Name_Unchecked_Access)));
4992 if Nkind (N) = N_Package_Declaration then
4993 if Present (Private_Declarations (Specification (N))) then
4994 Append (Call, Private_Declarations (Specification (N)));
4996 Append (Call, Visible_Declarations (Specification (N)));
5000 -- The call goes at the start of the statement sequence after the
5001 -- start of exception range label if one is present.
5003 if Present (Handled_Statement_Sequence (N)) then
5004 Stmt := First (Statements (Handled_Statement_Sequence (N)));
5006 -- A special case, skip exception range label if one is present
5007 -- (from front end zcx processing).
5009 if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then
5013 -- Another special case, if the first statement is a block from
5014 -- optimization of a local raise to a goto, then the call goes
5015 -- inside this block.
5017 if Nkind (Stmt) = N_Block_Statement
5018 and then Exception_Junk (Stmt)
5020 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
5023 -- Insertion point is after any exception label pushes, since we
5024 -- want it covered by any local handlers.
5026 while Nkind (Stmt) in N_Push_xxx_Label loop
5030 -- Now we have the proper insertion point
5032 Insert_Before (Stmt, Call);
5035 Set_Handled_Statement_Sequence (N,
5036 Make_Handled_Sequence_Of_Statements (Loc,
5037 Statements => New_List (Call)));
5043 if Legacy_Elaboration_Checks then
5044 Check_Task_Activation (N);
5046 end Build_Task_Activation_Call;
5048 -------------------------------
5049 -- Build_Task_Allocate_Block --
5050 -------------------------------
5052 procedure Build_Task_Allocate_Block
5057 T : constant Entity_Id := Entity (Expression (N));
5058 Init : constant Entity_Id := Base_Init_Proc (T);
5059 Loc : constant Source_Ptr := Sloc (N);
5060 Chain : constant Entity_Id :=
5061 Make_Defining_Identifier (Loc, Name_uChain);
5062 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5067 Make_Block_Statement (Loc,
5068 Identifier => New_Occurrence_Of (Blkent, Loc),
5069 Declarations => New_List (
5071 -- _Chain : Activation_Chain;
5073 Make_Object_Declaration (Loc,
5074 Defining_Identifier => Chain,
5075 Aliased_Present => True,
5076 Object_Definition =>
5077 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5079 Handled_Statement_Sequence =>
5080 Make_Handled_Sequence_Of_Statements (Loc,
5082 Statements => New_List (
5086 Make_Procedure_Call_Statement (Loc,
5087 Name => New_Occurrence_Of (Init, Loc),
5088 Parameter_Associations => Args),
5090 -- Activate_Tasks (_Chain);
5092 Make_Procedure_Call_Statement (Loc,
5093 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5094 Parameter_Associations => New_List (
5095 Make_Attribute_Reference (Loc,
5096 Prefix => New_Occurrence_Of (Chain, Loc),
5097 Attribute_Name => Name_Unchecked_Access))))),
5099 Has_Created_Identifier => True,
5100 Is_Task_Allocation_Block => True);
5103 Make_Implicit_Label_Declaration (Loc,
5104 Defining_Identifier => Blkent,
5105 Label_Construct => Block));
5107 Append_To (Actions, Block);
5109 Set_Activation_Chain_Entity (Block, Chain);
5110 end Build_Task_Allocate_Block;
5112 -----------------------------------------------
5113 -- Build_Task_Allocate_Block_With_Init_Stmts --
5114 -----------------------------------------------
5116 procedure Build_Task_Allocate_Block_With_Init_Stmts
5119 Init_Stmts : List_Id)
5121 Loc : constant Source_Ptr := Sloc (N);
5122 Chain : constant Entity_Id :=
5123 Make_Defining_Identifier (Loc, Name_uChain);
5124 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5128 Append_To (Init_Stmts,
5129 Make_Procedure_Call_Statement (Loc,
5130 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5131 Parameter_Associations => New_List (
5132 Make_Attribute_Reference (Loc,
5133 Prefix => New_Occurrence_Of (Chain, Loc),
5134 Attribute_Name => Name_Unchecked_Access))));
5137 Make_Block_Statement (Loc,
5138 Identifier => New_Occurrence_Of (Blkent, Loc),
5139 Declarations => New_List (
5141 -- _Chain : Activation_Chain;
5143 Make_Object_Declaration (Loc,
5144 Defining_Identifier => Chain,
5145 Aliased_Present => True,
5146 Object_Definition =>
5147 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5149 Handled_Statement_Sequence =>
5150 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
5152 Has_Created_Identifier => True,
5153 Is_Task_Allocation_Block => True);
5156 Make_Implicit_Label_Declaration (Loc,
5157 Defining_Identifier => Blkent,
5158 Label_Construct => Block));
5160 Append_To (Actions, Block);
5162 Set_Activation_Chain_Entity (Block, Chain);
5163 end Build_Task_Allocate_Block_With_Init_Stmts;
5165 -----------------------------------
5166 -- Build_Task_Proc_Specification --
5167 -----------------------------------
5169 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
5170 Loc : constant Source_Ptr := Sloc (T);
5171 Spec_Id : Entity_Id;
5174 -- Case of explicit task type, suffix TB
5176 if Comes_From_Source (T) then
5178 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB"));
5180 -- Case of anonymous task type, suffix B
5184 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B'));
5187 Set_Is_Internal (Spec_Id);
5189 -- Associate the procedure with the task, if this is the declaration
5190 -- (and not the body) of the procedure.
5192 if No (Task_Body_Procedure (T)) then
5193 Set_Task_Body_Procedure (T, Spec_Id);
5197 Make_Procedure_Specification (Loc,
5198 Defining_Unit_Name => Spec_Id,
5199 Parameter_Specifications => New_List (
5200 Make_Parameter_Specification (Loc,
5201 Defining_Identifier =>
5202 Make_Defining_Identifier (Loc, Name_uTask),
5204 Make_Access_Definition (Loc,
5206 New_Occurrence_Of (Corresponding_Record_Type (T), Loc)))));
5207 end Build_Task_Proc_Specification;
5209 ---------------------------------------
5210 -- Build_Unprotected_Subprogram_Body --
5211 ---------------------------------------
5213 function Build_Unprotected_Subprogram_Body
5215 Pid : Node_Id) return Node_Id
5217 Decls : constant List_Id := Declarations (N);
5220 -- Add renamings for the Protection object, discriminals, privals, and
5221 -- the entry index constant for use by debugger.
5223 Debug_Private_Data_Declarations (Decls);
5225 -- Make an unprotected version of the subprogram for use within the same
5226 -- object, with a new name and an additional parameter representing the
5230 Make_Subprogram_Body (Sloc (N),
5232 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
5233 Declarations => Decls,
5234 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
5235 end Build_Unprotected_Subprogram_Body;
5237 ----------------------------
5238 -- Collect_Entry_Families --
5239 ----------------------------
5241 procedure Collect_Entry_Families
5244 Current_Node : in out Node_Id;
5245 Conctyp : Entity_Id)
5248 Efam_Decl : Node_Id;
5249 Efam_Type : Entity_Id;
5252 Efam := First_Entity (Conctyp);
5253 while Present (Efam) loop
5254 if Ekind (Efam) = E_Entry_Family then
5255 Efam_Type := Make_Temporary (Loc, 'F');
5260 (Etype (Discrete_Subtype_Definition (Parent (Efam))));
5262 Bas_Decl : Node_Id := Empty;
5267 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
5269 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
5270 Bas := Make_Temporary (Loc, 'B');
5273 Make_Subtype_Declaration (Loc,
5274 Defining_Identifier => Bas,
5275 Subtype_Indication =>
5276 Make_Subtype_Indication (Loc,
5278 New_Occurrence_Of (Standard_Integer, Loc),
5280 Make_Range_Constraint (Loc,
5281 Range_Expression => Make_Range (Loc,
5282 Make_Integer_Literal
5283 (Loc, -Entry_Family_Bound),
5284 Make_Integer_Literal
5285 (Loc, Entry_Family_Bound - 1)))));
5287 Insert_After (Current_Node, Bas_Decl);
5288 Current_Node := Bas_Decl;
5293 Make_Full_Type_Declaration (Loc,
5294 Defining_Identifier => Efam_Type,
5296 Make_Unconstrained_Array_Definition (Loc,
5298 (New_List (New_Occurrence_Of (Bas, Loc))),
5300 Component_Definition =>
5301 Make_Component_Definition (Loc,
5302 Aliased_Present => False,
5303 Subtype_Indication =>
5304 New_Occurrence_Of (Standard_Character, Loc))));
5307 Insert_After (Current_Node, Efam_Decl);
5308 Current_Node := Efam_Decl;
5309 Analyze (Efam_Decl);
5312 Make_Component_Declaration (Loc,
5313 Defining_Identifier =>
5314 Make_Defining_Identifier (Loc, Chars (Efam)),
5316 Component_Definition =>
5317 Make_Component_Definition (Loc,
5318 Aliased_Present => False,
5319 Subtype_Indication =>
5320 Make_Subtype_Indication (Loc,
5322 New_Occurrence_Of (Efam_Type, Loc),
5325 Make_Index_Or_Discriminant_Constraint (Loc,
5326 Constraints => New_List (
5328 (Etype (Discrete_Subtype_Definition
5329 (Parent (Efam))), Loc)))))));
5335 end Collect_Entry_Families;
5337 -----------------------
5338 -- Concurrent_Object --
5339 -----------------------
5341 function Concurrent_Object
5342 (Spec_Id : Entity_Id;
5343 Conc_Typ : Entity_Id) return Entity_Id
5346 -- Parameter _O or _object
5348 if Is_Protected_Type (Conc_Typ) then
5349 return First_Formal (Protected_Body_Subprogram (Spec_Id));
5354 pragma Assert (Is_Task_Type (Conc_Typ));
5355 return First_Formal (Task_Body_Procedure (Conc_Typ));
5357 end Concurrent_Object;
5359 ----------------------
5360 -- Copy_Result_Type --
5361 ----------------------
5363 function Copy_Result_Type (Res : Node_Id) return Node_Id is
5364 New_Res : constant Node_Id := New_Copy_Tree (Res);
5369 -- If the result type is an access_to_subprogram, we must create new
5370 -- entities for its spec.
5372 if Nkind (New_Res) = N_Access_Definition
5373 and then Present (Access_To_Subprogram_Definition (New_Res))
5375 -- Provide new entities for the formals
5377 Par_Spec := First (Parameter_Specifications
5378 (Access_To_Subprogram_Definition (New_Res)));
5379 while Present (Par_Spec) loop
5380 Formal := Defining_Identifier (Par_Spec);
5381 Set_Defining_Identifier (Par_Spec,
5382 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
5388 end Copy_Result_Type;
5390 --------------------
5391 -- Concurrent_Ref --
5392 --------------------
5394 -- The expression returned for a reference to a concurrent object has the
5397 -- taskV!(name)._Task_Id
5401 -- objectV!(name)._Object
5403 -- for a protected object. For the case of an access to a concurrent
5404 -- object, there is an extra explicit dereference:
5406 -- taskV!(name.all)._Task_Id
5407 -- objectV!(name.all)._Object
5409 -- here taskV and objectV are the types for the associated records, which
5410 -- contain the required _Task_Id and _Object fields for tasks and protected
5411 -- objects, respectively.
5413 -- For the case of a task type name, the expression is
5417 -- i.e. a call to the Self function which returns precisely this Task_Id
5419 -- For the case of a protected type name, the expression is
5423 -- which is a renaming of the _object field of the current object
5424 -- record, passed into protected operations as a parameter.
5426 function Concurrent_Ref (N : Node_Id) return Node_Id is
5427 Loc : constant Source_Ptr := Sloc (N);
5428 Ntyp : constant Entity_Id := Etype (N);
5432 function Is_Current_Task (T : Entity_Id) return Boolean;
5433 -- Check whether the reference is to the immediately enclosing task
5434 -- type, or to an outer one (rare but legal).
5436 ---------------------
5437 -- Is_Current_Task --
5438 ---------------------
5440 function Is_Current_Task (T : Entity_Id) return Boolean is
5444 Scop := Current_Scope;
5445 while Present (Scop) and then Scop /= Standard_Standard loop
5449 elsif Is_Task_Type (Scop) then
5452 -- If this is a procedure nested within the task type, we must
5453 -- assume that it can be called from an inner task, and therefore
5454 -- cannot treat it as a local reference.
5456 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then
5460 Scop := Scope (Scop);
5464 -- We know that we are within the task body, so should have found it
5467 raise Program_Error;
5468 end Is_Current_Task;
5470 -- Start of processing for Concurrent_Ref
5473 if Is_Access_Type (Ntyp) then
5474 Dtyp := Designated_Type (Ntyp);
5476 if Is_Protected_Type (Dtyp) then
5477 Sel := Name_uObject;
5479 Sel := Name_uTask_Id;
5483 Make_Selected_Component (Loc,
5485 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
5486 Make_Explicit_Dereference (Loc, N)),
5487 Selector_Name => Make_Identifier (Loc, Sel));
5489 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then
5490 if Is_Task_Type (Entity (N)) then
5492 if Is_Current_Task (Entity (N)) then
5494 Make_Function_Call (Loc,
5495 Name => New_Occurrence_Of (RTE (RE_Self), Loc));
5500 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T');
5501 T_Body : constant Node_Id :=
5502 Parent (Corresponding_Body (Parent (Entity (N))));
5506 Make_Object_Declaration (Loc,
5507 Defining_Identifier => T_Self,
5508 Object_Definition =>
5509 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
5511 Make_Function_Call (Loc,
5512 Name => New_Occurrence_Of (RTE (RE_Self), Loc)));
5513 Prepend (Decl, Declarations (T_Body));
5515 Set_Scope (T_Self, Entity (N));
5516 return New_Occurrence_Of (T_Self, Loc);
5521 pragma Assert (Is_Protected_Type (Entity (N)));
5524 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc);
5528 if Is_Protected_Type (Ntyp) then
5529 Sel := Name_uObject;
5530 elsif Is_Task_Type (Ntyp) then
5531 Sel := Name_uTask_Id;
5533 raise Program_Error;
5537 Make_Selected_Component (Loc,
5539 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
5541 Selector_Name => Make_Identifier (Loc, Sel));
5545 ------------------------
5546 -- Convert_Concurrent --
5547 ------------------------
5549 function Convert_Concurrent
5551 Typ : Entity_Id) return Node_Id
5554 if not Is_Concurrent_Type (Typ) then
5558 Unchecked_Convert_To
5559 (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
5561 end Convert_Concurrent;
5563 -------------------------------------
5564 -- Create_Secondary_Stack_For_Task --
5565 -------------------------------------
5567 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is
5570 (Restriction_Active (No_Implicit_Heap_Allocations)
5571 or else Restriction_Active (No_Implicit_Task_Allocations))
5572 and then not Restriction_Active (No_Secondary_Stack)
5573 and then Has_Rep_Pragma
5574 (T, Name_Secondary_Stack_Size, Check_Parents => False);
5575 end Create_Secondary_Stack_For_Task;
5577 -------------------------------------
5578 -- Debug_Private_Data_Declarations --
5579 -------------------------------------
5581 procedure Debug_Private_Data_Declarations (Decls : List_Id) is
5582 Debug_Nod : Node_Id;
5586 Decl := First (Decls);
5587 while Present (Decl) and then not Comes_From_Source (Decl) loop
5589 -- Declaration for concurrent entity _object and its access type,
5590 -- along with the entry index subtype:
5591 -- type prot_typVP is access prot_typV;
5592 -- _object : prot_typVP := prot_typV (_O);
5593 -- subtype Jnn is <Type of Index> range Low .. High;
5595 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then
5596 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5598 -- Declaration for the Protection object, discriminals, privals, and
5599 -- entry index constant:
5600 -- conc_typR : protection_typ renames _object._object;
5601 -- discr_nameD : discr_typ renames _object.discr_name;
5602 -- discr_nameD : discr_typ renames _task.discr_name;
5603 -- prival_name : comp_typ renames _object.comp_name;
5604 -- J : constant Jnn :=
5605 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5607 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
5608 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5609 Debug_Nod := Debug_Renaming_Declaration (Decl);
5611 if Present (Debug_Nod) then
5612 Insert_After (Decl, Debug_Nod);
5618 end Debug_Private_Data_Declarations;
5620 ------------------------------
5621 -- Ensure_Statement_Present --
5622 ------------------------------
5624 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is
5628 if Opt.Suppress_Control_Flow_Optimizations
5629 and then Is_Empty_List (Statements (Alt))
5631 Stmt := Make_Null_Statement (Loc);
5633 -- Mark NULL statement as coming from source so that it is not
5634 -- eliminated by GIGI.
5636 -- Another covert channel. If this is a requirement, it must be
5637 -- documented in sinfo/einfo ???
5639 Set_Comes_From_Source (Stmt, True);
5641 Set_Statements (Alt, New_List (Stmt));
5643 end Ensure_Statement_Present;
5645 ----------------------------
5646 -- Entry_Index_Expression --
5647 ----------------------------
5649 function Entry_Index_Expression
5653 Ttyp : Entity_Id) return Node_Id
5663 -- The queues of entries and entry families appear in textual order in
5664 -- the associated record. The entry index is computed as the sum of the
5665 -- number of queues for all entries that precede the designated one, to
5666 -- which is added the index expression, if this expression denotes a
5667 -- member of a family.
5669 -- The following is a place holder for the count of simple entries
5671 Num := Make_Integer_Literal (Sloc, 1);
5673 -- We construct an expression which is a series of addition operations.
5674 -- The first operand is the number of single entries that precede this
5675 -- one, the second operand is the index value relative to the start of
5676 -- the referenced family, and the remaining operands are the lengths of
5677 -- the entry families that precede this entry, i.e. the constructed
5680 -- number_simple_entries +
5681 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5682 -- family'length + ...
5684 -- where index-value is the given index value, and s is the index
5685 -- subtype (we have to use pos because the subtype might be an
5686 -- enumeration type preventing direct subtraction). Note that the task
5687 -- entry array is one-indexed.
5689 -- The upper bound of the entry family may be a discriminant, so we
5690 -- retrieve the lower bound explicitly to compute offset, rather than
5691 -- using the index subtype which may mention a discriminant.
5693 if Present (Index) then
5694 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
5702 Make_Attribute_Reference (Sloc,
5703 Attribute_Name => Name_Pos,
5704 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
5705 Expressions => New_List (Relocate_Node (Index))),
5713 -- Now add lengths of preceding entries and entry families
5715 Prev := First_Entity (Ttyp);
5716 while Chars (Prev) /= Chars (Ent)
5717 or else (Ekind (Prev) /= Ekind (Ent))
5718 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
5720 if Ekind (Prev) = E_Entry then
5721 Set_Intval (Num, Intval (Num) + 1);
5723 elsif Ekind (Prev) = E_Entry_Family then
5724 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
5725 Lo := Type_Low_Bound (S);
5726 Hi := Type_High_Bound (S);
5731 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
5733 -- Other components are anonymous types to be ignored
5743 end Entry_Index_Expression;
5745 ---------------------------
5746 -- Establish_Task_Master --
5747 ---------------------------
5749 procedure Establish_Task_Master (N : Node_Id) is
5753 if Restriction_Active (No_Task_Hierarchy) = False then
5754 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
5756 -- The block may have no declarations (and nevertheless be a task
5757 -- master) if it contains a call that may return an object that
5760 if No (Declarations (N)) then
5761 Set_Declarations (N, New_List (Call));
5763 Prepend_To (Declarations (N), Call);
5768 end Establish_Task_Master;
5770 --------------------------------
5771 -- Expand_Accept_Declarations --
5772 --------------------------------
5774 -- Part of the expansion of an accept statement involves the creation of
5775 -- a declaration that can be referenced from the statement sequence of
5780 -- This declaration is inserted immediately before the accept statement
5781 -- and it is important that it be inserted before the statements of the
5782 -- statement sequence are analyzed. Thus it would be too late to create
5783 -- this declaration in the Expand_N_Accept_Statement routine, which is
5784 -- why there is a separate procedure to be called directly from Sem_Ch9.
5786 -- Ann is used to hold the address of the record containing the parameters
5787 -- (see Expand_N_Entry_Call for more details on how this record is built).
5788 -- References to the parameters do an unchecked conversion of this address
5789 -- to a pointer to the required record type, and then access the field that
5790 -- holds the value of the required parameter. The entity for the address
5791 -- variable is held as the top stack element (i.e. the last element) of the
5792 -- Accept_Address stack in the corresponding entry entity, and this element
5793 -- must be set in place before the statements are processed.
5795 -- The above description applies to the case of a stand alone accept
5796 -- statement, i.e. one not appearing as part of a select alternative.
5798 -- For the case of an accept that appears as part of a select alternative
5799 -- of a selective accept, we must still create the declaration right away,
5800 -- since Ann is needed immediately, but there is an important difference:
5802 -- The declaration is inserted before the selective accept, not before
5803 -- the accept statement (which is not part of a list anyway, and so would
5804 -- not accommodate inserted declarations)
5806 -- We only need one address variable for the entire selective accept. So
5807 -- the Ann declaration is created only for the first accept alternative,
5808 -- and subsequent accept alternatives reference the same Ann variable.
5810 -- We can distinguish the two cases by seeing whether the accept statement
5811 -- is part of a list. If not, then it must be in an accept alternative.
5813 -- To expand the requeue statement, a label is provided at the end of the
5814 -- accept statement or alternative of which it is a part, so that the
5815 -- statement can be skipped after the requeue is complete. This label is
5816 -- created here rather than during the expansion of the accept statement,
5817 -- because it will be needed by any requeue statements within the accept,
5818 -- which are expanded before the accept.
5820 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
5821 Loc : constant Source_Ptr := Sloc (N);
5822 Stats : constant Node_Id := Handled_Statement_Sequence (N);
5823 Ann : Entity_Id := Empty;
5830 if Expander_Active then
5832 -- If we have no handled statement sequence, we may need to build
5833 -- a dummy sequence consisting of a null statement. This can be
5834 -- skipped if the trivial accept optimization is permitted.
5836 if not Trivial_Accept_OK
5837 and then (No (Stats) or else Null_Statements (Statements (Stats)))
5839 Set_Handled_Statement_Sequence (N,
5840 Make_Handled_Sequence_Of_Statements (Loc,
5841 Statements => New_List (Make_Null_Statement (Loc))));
5844 -- Create and declare two labels to be placed at the end of the
5845 -- accept statement. The first label is used to allow requeues to
5846 -- skip the remainder of entry processing. The second label is used
5847 -- to skip the remainder of entry processing if the rendezvous
5848 -- completes in the middle of the accept body.
5850 if Present (Handled_Statement_Sequence (N)) then
5855 Ent := Make_Temporary (Loc, 'L');
5856 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5858 Make_Implicit_Label_Declaration (Loc,
5859 Defining_Identifier => Ent,
5860 Label_Construct => Lab);
5861 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5863 Ent := Make_Temporary (Loc, 'L');
5864 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5866 Make_Implicit_Label_Declaration (Loc,
5867 Defining_Identifier => Ent,
5868 Label_Construct => Lab);
5869 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5877 -- Case of stand alone accept statement
5879 if Is_List_Member (N) then
5881 if Present (Handled_Statement_Sequence (N)) then
5882 Ann := Make_Temporary (Loc, 'A');
5885 Make_Object_Declaration (Loc,
5886 Defining_Identifier => Ann,
5887 Object_Definition =>
5888 New_Occurrence_Of (RTE (RE_Address), Loc));
5890 Insert_Before_And_Analyze (N, Adecl);
5891 Insert_Before_And_Analyze (N, Ldecl);
5892 Insert_Before_And_Analyze (N, Ldecl2);
5895 -- Case of accept statement which is in an accept alternative
5899 Acc_Alt : constant Node_Id := Parent (N);
5900 Sel_Acc : constant Node_Id := Parent (Acc_Alt);
5904 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
5905 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
5907 -- ??? Consider a single label for select statements
5909 if Present (Handled_Statement_Sequence (N)) then
5911 Statements (Handled_Statement_Sequence (N)));
5915 Statements (Handled_Statement_Sequence (N)));
5919 -- Find first accept alternative of the selective accept. A
5920 -- valid selective accept must have at least one accept in it.
5922 Alt := First (Select_Alternatives (Sel_Acc));
5924 while Nkind (Alt) /= N_Accept_Alternative loop
5928 -- If this is the first accept statement, then we have to
5929 -- create the Ann variable, as for the stand alone case, except
5930 -- that it is inserted before the selective accept. Similarly,
5931 -- a label for requeue expansion must be declared.
5933 if N = Accept_Statement (Alt) then
5934 Ann := Make_Temporary (Loc, 'A');
5936 Make_Object_Declaration (Loc,
5937 Defining_Identifier => Ann,
5938 Object_Definition =>
5939 New_Occurrence_Of (RTE (RE_Address), Loc));
5941 Insert_Before_And_Analyze (Sel_Acc, Adecl);
5943 -- If this is not the first accept statement, then find the Ann
5944 -- variable allocated by the first accept and use it.
5948 Node (Last_Elmt (Accept_Address
5949 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
5954 -- Merge here with Ann either created or referenced, and Adecl
5955 -- pointing to the corresponding declaration. Remaining processing
5956 -- is the same for the two cases.
5958 if Present (Ann) then
5959 Append_Elmt (Ann, Accept_Address (Ent));
5960 Set_Debug_Info_Needed (Ann);
5963 -- Create renaming declarations for the entry formals. Each reference
5964 -- to a formal becomes a dereference of a component of the parameter
5965 -- block, whose address is held in Ann. These declarations are
5966 -- eventually inserted into the accept block, and analyzed there so
5967 -- that they have the proper scope for gdb and do not conflict with
5968 -- other declarations.
5970 if Present (Parameter_Specifications (N))
5971 and then Present (Handled_Statement_Sequence (N))
5978 Renamed_Formal : Node_Id;
5982 Formal := First_Formal (Ent);
5984 while Present (Formal) loop
5985 Comp := Entry_Component (Formal);
5986 New_F := Make_Defining_Identifier (Loc, Chars (Formal));
5988 Set_Etype (New_F, Etype (Formal));
5989 Set_Scope (New_F, Ent);
5991 -- Now we set debug info needed on New_F even though it does
5992 -- not come from source, so that the debugger will get the
5993 -- right information for these generated names.
5995 Set_Debug_Info_Needed (New_F);
5997 if Ekind (Formal) = E_In_Parameter then
5998 Set_Ekind (New_F, E_Constant);
6000 Set_Ekind (New_F, E_Variable);
6001 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
6004 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
6007 Make_Selected_Component (Loc,
6009 Unchecked_Convert_To (
6010 Entry_Parameters_Type (Ent),
6011 New_Occurrence_Of (Ann, Loc)),
6013 New_Occurrence_Of (Comp, Loc));
6016 Build_Renamed_Formal_Declaration
6017 (New_F, Formal, Comp, Renamed_Formal);
6019 if No (Declarations (N)) then
6020 Set_Declarations (N, New_List);
6023 Append (Decl, Declarations (N));
6024 Set_Renamed_Object (Formal, New_F);
6025 Next_Formal (Formal);
6032 end Expand_Accept_Declarations;
6034 ---------------------------------------------
6035 -- Expand_Access_Protected_Subprogram_Type --
6036 ---------------------------------------------
6038 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
6039 Loc : constant Source_Ptr := Sloc (N);
6040 T : constant Entity_Id := Defining_Identifier (N);
6041 D_T : constant Entity_Id := Designated_Type (T);
6042 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D');
6043 E_T : constant Entity_Id := Make_Temporary (Loc, 'E');
6044 P_List : constant List_Id :=
6045 Build_Protected_Spec (N, RTE (RE_Address), D_T, False);
6053 -- Create access to subprogram with full signature
6055 if Etype (D_T) /= Standard_Void_Type then
6057 Make_Access_Function_Definition (Loc,
6058 Parameter_Specifications => P_List,
6059 Result_Definition =>
6060 Copy_Result_Type (Result_Definition (Type_Definition (N))));
6064 Make_Access_Procedure_Definition (Loc,
6065 Parameter_Specifications => P_List);
6069 Make_Full_Type_Declaration (Loc,
6070 Defining_Identifier => D_T2,
6071 Type_Definition => Def1);
6073 -- Declare the new types before the original one since the latter will
6074 -- refer to them through the Equivalent_Type slot.
6076 Insert_Before_And_Analyze (N, Decl1);
6078 -- Associate the access to subprogram with its original access to
6079 -- protected subprogram type. Needed by the backend to know that this
6080 -- type corresponds with an access to protected subprogram type.
6082 Set_Original_Access_Type (D_T2, T);
6084 -- Create Equivalent_Type, a record with two components for an access to
6085 -- object and an access to subprogram.
6088 Make_Component_Declaration (Loc,
6089 Defining_Identifier => Make_Temporary (Loc, 'P'),
6090 Component_Definition =>
6091 Make_Component_Definition (Loc,
6092 Aliased_Present => False,
6093 Subtype_Indication =>
6094 New_Occurrence_Of (RTE (RE_Address), Loc))),
6096 Make_Component_Declaration (Loc,
6097 Defining_Identifier => Make_Temporary (Loc, 'S'),
6098 Component_Definition =>
6099 Make_Component_Definition (Loc,
6100 Aliased_Present => False,
6101 Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
6104 Make_Full_Type_Declaration (Loc,
6105 Defining_Identifier => E_T,
6107 Make_Record_Definition (Loc,
6109 Make_Component_List (Loc, Component_Items => Comps)));
6111 Insert_Before_And_Analyze (N, Decl2);
6112 Set_Equivalent_Type (T, E_T);
6113 end Expand_Access_Protected_Subprogram_Type;
6115 --------------------------
6116 -- Expand_Entry_Barrier --
6117 --------------------------
6119 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
6120 Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N));
6121 Prot : constant Entity_Id := Scope (Ent);
6122 Spec_Decl : constant Node_Id := Parent (Prot);
6124 Func_Id : Entity_Id := Empty;
6125 -- The entity of the barrier function
6127 function Is_Global_Entity (N : Node_Id) return Traverse_Result;
6128 -- Check whether entity in Barrier is external to protected type.
6129 -- If so, barrier may not be properly synchronized.
6131 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
6132 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6135 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean;
6136 -- Check whether entity name N denotes a component of the protected
6137 -- object. This is used to check the Simple_Barrier restriction.
6139 ----------------------
6140 -- Is_Global_Entity --
6141 ----------------------
6143 function Is_Global_Entity (N : Node_Id) return Traverse_Result is
6148 if Is_Entity_Name (N) and then Present (Entity (N)) then
6152 if Ekind (E) = E_Variable then
6154 -- If the variable is local to the barrier function generated
6155 -- during expansion, it is ok. If expansion is not performed,
6156 -- then Func is Empty so this test cannot succeed.
6158 if Scope (E) = Func_Id then
6161 -- A protected call from a barrier to another object is ok
6163 elsif Ekind (Etype (E)) = E_Protected_Type then
6166 -- If the variable is within the package body we consider
6167 -- this safe. This is a common (if dubious) idiom.
6169 elsif S = Scope (Prot)
6170 and then Ekind_In (S, E_Package, E_Generic_Package)
6171 and then Nkind (Parent (E)) = N_Object_Declaration
6172 and then Nkind (Parent (Parent (E))) = N_Package_Body
6177 Error_Msg_N ("potentially unsynchronized barrier??", N);
6178 Error_Msg_N ("\& should be private component of type??", N);
6184 end Is_Global_Entity;
6186 procedure Check_Unprotected_Barrier is
6187 new Traverse_Proc (Is_Global_Entity);
6189 ----------------------------
6190 -- Is_Simple_Barrier_Name --
6191 ----------------------------
6193 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
6197 -- Check if the name is a component of the protected object. If
6198 -- the expander is active, the component has been transformed into a
6199 -- renaming of _object.all.component. Original_Node is needed in case
6200 -- validity checking is enabled, in which case the simple object
6201 -- reference will have been rewritten.
6203 if Expander_Active then
6205 -- The expanded name may have been constant folded in which case
6206 -- the original node is not necessarily an entity name (e.g. an
6207 -- indexed component).
6209 if not Is_Entity_Name (Original_Node (N)) then
6213 Renamed := Renamed_Object (Entity (Original_Node (N)));
6217 and then Nkind (Renamed) = N_Selected_Component
6218 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
6220 return Is_Protected_Component (Entity (N));
6222 end Is_Simple_Barrier_Name;
6224 ---------------------
6225 -- Is_Pure_Barrier --
6226 ---------------------
6228 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
6231 when N_Expanded_Name
6234 if No (Entity (N)) then
6237 elsif Is_Universal_Numeric_Type (Entity (N)) then
6241 case Ekind (Entity (N)) is
6244 | E_Enumeration_Literal
6254 if Is_Simple_Barrier_Name (N) then
6260 -- The count attribute has been transformed into run-time
6263 if Is_RTE (Entity (N), RE_Protected_Count)
6264 or else Is_RTE (Entity (N), RE_Protected_Count_Entry)
6273 when N_Function_Call =>
6275 -- Function call checks are carried out as part of the analysis
6276 -- of the function call name.
6280 when N_Character_Literal
6289 if Ekind (Entity (N)) = E_Operator then
6293 when N_Short_Circuit =>
6296 when N_Indexed_Component
6297 | N_Selected_Component
6299 if not Is_Access_Type (Etype (Prefix (N))) then
6303 when N_Type_Conversion =>
6305 -- Conversions to Universal_Integer will not raise constraint
6308 if Cannot_Raise_Constraint_Error (N)
6309 or else Etype (N) = Universal_Integer
6314 when N_Unchecked_Type_Conversion =>
6322 end Is_Pure_Barrier;
6324 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier);
6328 Cond_Id : Entity_Id;
6329 Entry_Body : Node_Id;
6330 Func_Body : Node_Id := Empty;
6332 -- Start of processing for Expand_Entry_Barrier
6335 if No_Run_Time_Mode then
6336 Error_Msg_CRT ("entry barrier", N);
6340 -- The body of the entry barrier must be analyzed in the context of the
6341 -- protected object, but its scope is external to it, just as any other
6342 -- unprotected version of a protected operation. The specification has
6343 -- been produced when the protected type declaration was elaborated. We
6344 -- build the body, insert it in the enclosing scope, but analyze it in
6345 -- the current context. A more uniform approach would be to treat the
6346 -- barrier just as a protected function, and discard the protected
6347 -- version of it because it is never called.
6349 if Expander_Active then
6350 Func_Body := Build_Barrier_Function (N, Ent, Prot);
6351 Func_Id := Barrier_Function (Ent);
6352 Set_Corresponding_Spec (Func_Body, Func_Id);
6354 Entry_Body := Parent (Corresponding_Body (Spec_Decl));
6356 if Nkind (Parent (Entry_Body)) = N_Subunit then
6357 Entry_Body := Corresponding_Stub (Parent (Entry_Body));
6360 Insert_Before_And_Analyze (Entry_Body, Func_Body);
6362 Set_Discriminals (Spec_Decl);
6363 Set_Scope (Func_Id, Scope (Prot));
6366 Analyze_And_Resolve (Cond, Any_Boolean);
6369 -- Check Pure_Barriers restriction
6371 if Check_Pure_Barriers (Cond) = Abandon then
6372 Check_Restriction (Pure_Barriers, Cond);
6375 -- The Ravenscar profile restricts barriers to simple variables declared
6376 -- within the protected object. We also allow Boolean constants, since
6377 -- these appear in several published examples and are also allowed by
6380 -- Note that after analysis variables in this context will be replaced
6381 -- by the corresponding prival, that is to say a renaming of a selected
6382 -- component of the form _Object.Var. If expansion is disabled, as
6383 -- within a generic, we check that the entity appears in the current
6386 if Is_Entity_Name (Cond) then
6387 Cond_Id := Entity (Cond);
6389 -- Perform a small optimization of simple barrier functions. If the
6390 -- scope of the condition's entity is not the barrier function, then
6391 -- the condition does not depend on any of the generated renamings.
6392 -- If this is the case, eliminate the renamings as they are useless.
6393 -- This optimization is not performed when the condition was folded
6394 -- and validity checks are in effect because the original condition
6395 -- may have produced at least one check that depends on the generated
6399 and then Scope (Cond_Id) /= Func_Id
6400 and then not Validity_Check_Operands
6402 Set_Declarations (Func_Body, Empty_List);
6405 if Cond_Id = Standard_False or else Cond_Id = Standard_True then
6408 elsif Is_Simple_Barrier_Name (Cond) then
6413 -- It is not a boolean variable or literal, so check the restriction.
6414 -- Note that it is safe to be calling Check_Restriction from here, even
6415 -- though this is part of the expander, since Expand_Entry_Barrier is
6416 -- called from Sem_Ch9 even in -gnatc mode.
6418 Check_Restriction (Simple_Barriers, Cond);
6420 -- Emit warning if barrier contains global entities and is thus
6421 -- potentially unsynchronized.
6423 Check_Unprotected_Barrier (Cond);
6424 end Expand_Entry_Barrier;
6426 ------------------------------
6427 -- Expand_N_Abort_Statement --
6428 ------------------------------
6430 -- Expand abort T1, T2, .. Tn; into:
6431 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6433 procedure Expand_N_Abort_Statement (N : Node_Id) is
6434 Loc : constant Source_Ptr := Sloc (N);
6435 Tlist : constant List_Id := Names (N);
6441 Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
6444 Tasknm := First (Tlist);
6446 while Present (Tasknm) loop
6449 -- A task interface class-wide type object is being aborted. Retrieve
6450 -- its _task_id by calling a dispatching routine.
6452 if Ada_Version >= Ada_2005
6453 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
6454 and then Is_Interface (Etype (Tasknm))
6455 and then Is_Task_Interface (Etype (Tasknm))
6457 Append_To (Component_Associations (Aggr),
6458 Make_Component_Association (Loc,
6459 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6462 -- Task_Id (Tasknm._disp_get_task_id)
6464 Make_Unchecked_Type_Conversion (Loc,
6466 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6468 Make_Selected_Component (Loc,
6469 Prefix => New_Copy_Tree (Tasknm),
6471 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
6474 Append_To (Component_Associations (Aggr),
6475 Make_Component_Association (Loc,
6476 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6477 Expression => Concurrent_Ref (Tasknm)));
6484 Make_Procedure_Call_Statement (Loc,
6485 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc),
6486 Parameter_Associations => New_List (
6487 Make_Qualified_Expression (Loc,
6488 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc),
6489 Expression => Aggr))));
6492 end Expand_N_Abort_Statement;
6494 -------------------------------
6495 -- Expand_N_Accept_Statement --
6496 -------------------------------
6498 -- This procedure handles expansion of accept statements that stand alone,
6499 -- i.e. they are not part of an accept alternative. The expansion of
6500 -- accept statement in accept alternatives is handled by the routines
6501 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6502 -- following description applies only to stand alone accept statements.
6504 -- If there is no handled statement sequence, or only null statements, then
6505 -- this is called a trivial accept, and the expansion is:
6507 -- Accept_Trivial (entry-index)
6509 -- If there is a handled statement sequence, then the expansion is:
6516 -- Accept_Call (entry-index, Ann);
6517 -- Renaming_Declarations for formals
6518 -- <statement sequence from N_Accept_Statement node>
6519 -- Complete_Rendezvous;
6524 -- <exception handler from N_Accept_Statement node>
6525 -- Complete_Rendezvous;
6527 -- <exception handler from N_Accept_Statement node>
6528 -- Complete_Rendezvous;
6533 -- when all others =>
6534 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6537 -- The first three declarations were already inserted ahead of the accept
6538 -- statement by the Expand_Accept_Declarations procedure, which was called
6539 -- directly from the semantics during analysis of the accept statement,
6540 -- before analyzing its contained statements.
6542 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6543 -- from possible expansion activity (the original source of course does
6544 -- not have any declarations associated with the accept statement, since
6545 -- an accept statement has no declarative part). In particular, if the
6546 -- expander is active, the first such declaration is the declaration of
6547 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6549 -- The two blocks are merged into a single block if the inner block has
6550 -- no exception handlers, but otherwise two blocks are required, since
6551 -- exceptions might be raised in the exception handlers of the inner
6552 -- block, and Exceptional_Complete_Rendezvous must be called.
6554 procedure Expand_N_Accept_Statement (N : Node_Id) is
6555 Loc : constant Source_Ptr := Sloc (N);
6556 Stats : constant Node_Id := Handled_Statement_Sequence (N);
6557 Ename : constant Node_Id := Entry_Direct_Name (N);
6558 Eindx : constant Node_Id := Entry_Index (N);
6559 Eent : constant Entity_Id := Entity (Ename);
6560 Acstack : constant Elist_Id := Accept_Address (Eent);
6561 Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
6562 Ttyp : constant Entity_Id := Etype (Scope (Eent));
6568 -- If the accept statement is not part of a list, then its parent must
6569 -- be an accept alternative, and, as described above, we do not do any
6570 -- expansion for such accept statements at this level.
6572 if not Is_List_Member (N) then
6573 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
6576 -- Trivial accept case (no statement sequence, or null statements).
6577 -- If the accept statement has declarations, then just insert them
6578 -- before the procedure call.
6580 elsif Trivial_Accept_OK
6581 and then (No (Stats) or else Null_Statements (Statements (Stats)))
6583 -- Remove declarations for renamings, because the parameter block
6584 -- will not be assigned.
6591 D := First (Declarations (N));
6592 while Present (D) loop
6594 if Nkind (D) = N_Object_Renaming_Declaration then
6602 if Present (Declarations (N)) then
6603 Insert_Actions (N, Declarations (N));
6607 Make_Procedure_Call_Statement (Loc,
6608 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc),
6609 Parameter_Associations => New_List (
6610 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
6614 -- Discard Entry_Address that was created for it, so it will not be
6615 -- emitted if this accept statement is in the statement part of a
6616 -- delay alternative.
6618 if Present (Stats) then
6619 Remove_Last_Elmt (Acstack);
6622 -- Case of statement sequence present
6625 -- Construct the block, using the declarations from the accept
6626 -- statement if any to initialize the declarations of the block.
6628 Blkent := Make_Temporary (Loc, 'A');
6629 Set_Ekind (Blkent, E_Block);
6630 Set_Etype (Blkent, Standard_Void_Type);
6631 Set_Scope (Blkent, Current_Scope);
6634 Make_Block_Statement (Loc,
6635 Identifier => New_Occurrence_Of (Blkent, Loc),
6636 Declarations => Declarations (N),
6637 Handled_Statement_Sequence => Build_Accept_Body (N));
6639 -- Reset the Scope of local entities associated with the accept
6640 -- statement (that currently reference the entry scope) to the
6641 -- block scope, to avoid having references to the locals treated
6642 -- as up-level references.
6644 Reset_Scopes_To (Block, Blkent);
6646 -- For the analysis of the generated declarations, the parent node
6647 -- must be properly set.
6649 Set_Parent (Block, Parent (N));
6651 -- Prepend call to Accept_Call to main statement sequence If the
6652 -- accept has exception handlers, the statement sequence is wrapped
6653 -- in a block. Insert call and renaming declarations in the
6654 -- declarations of the block, so they are elaborated before the
6658 Make_Procedure_Call_Statement (Loc,
6659 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc),
6660 Parameter_Associations => New_List (
6661 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
6662 New_Occurrence_Of (Ann, Loc)));
6664 if Parent (Stats) = N then
6665 Prepend (Call, Statements (Stats));
6667 Set_Declarations (Parent (Stats), New_List (Call));
6672 Push_Scope (Blkent);
6680 D := First (Declarations (N));
6681 while Present (D) loop
6684 if Nkind (D) = N_Object_Renaming_Declaration then
6686 -- The renaming declarations for the formals were created
6687 -- during analysis of the accept statement, and attached to
6688 -- the list of declarations. Place them now in the context
6689 -- of the accept block or subprogram.
6692 Typ := Entity (Subtype_Mark (D));
6693 Insert_After (Call, D);
6696 -- If the formal is class_wide, it does not have an actual
6697 -- subtype. The analysis of the renaming declaration creates
6698 -- one, but we need to retain the class-wide nature of the
6701 if Is_Class_Wide_Type (Typ) then
6702 Set_Etype (Defining_Identifier (D), Typ);
6713 -- Replace the accept statement by the new block
6718 -- Last step is to unstack the Accept_Address value
6720 Remove_Last_Elmt (Acstack);
6722 end Expand_N_Accept_Statement;
6724 ----------------------------------
6725 -- Expand_N_Asynchronous_Select --
6726 ----------------------------------
6728 -- This procedure assumes that the trigger statement is an entry call or
6729 -- a dispatching procedure call. A delay alternative should already have
6730 -- been expanded into an entry call to the appropriate delay object Wait
6733 -- If the trigger is a task entry call, the select is implemented with
6734 -- a Task_Entry_Call:
6739 -- P : parms := (parm, parm, parm);
6741 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6743 -- procedure _clean is
6746 -- Cancel_Task_Entry_Call (C);
6753 -- (<acceptor-task>, -- Acceptor
6754 -- <entry-index>, -- E
6755 -- P'Address, -- Uninterpreted_Data
6756 -- Asynchronous_Call, -- Mode
6757 -- B); -- Rendezvous_Successful
6764 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6767 -- when Abort_Signal => Abort_Undefer;
6774 -- <triggered-statements>
6778 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6779 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6783 -- P : parms := (parm, parm, parm);
6785 -- Call_Simple (acceptor-task, entry-index, P'Address);
6791 -- so the task at hand is to convert the latter expansion into the former
6793 -- If the trigger is a protected entry call, the select is implemented
6794 -- with Protected_Entry_Call:
6797 -- P : E1_Params := (param, param, param);
6798 -- Bnn : Communications_Block;
6803 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6805 -- procedure _clean is
6808 -- if Enqueued (Bnn) then
6809 -- Cancel_Protected_Entry_Call (Bnn);
6816 -- Protected_Entry_Call
6817 -- (po._object'Access, -- Object
6818 -- <entry index>, -- E
6819 -- P'Address, -- Uninterpreted_Data
6820 -- Asynchronous_Call, -- Mode
6823 -- if Enqueued (Bnn) then
6827 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6830 -- when Abort_Signal => Abort_Undefer;
6833 -- if not Cancelled (Bnn) then
6834 -- <triggered-statements>
6838 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6842 -- P : E1_Params := (param, param, param);
6843 -- Bnn : Communications_Block;
6846 -- Protected_Entry_Call
6847 -- (po._object'Access, -- Object
6848 -- <entry index>, -- E
6849 -- P'Address, -- Uninterpreted_Data
6850 -- Simple_Call, -- Mode
6857 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6861 -- B : Boolean := False;
6862 -- Bnn : Communication_Block;
6863 -- C : Ada.Tags.Prim_Op_Kind;
6864 -- D : System.Storage_Elements.Dummy_Communication_Block;
6865 -- K : Ada.Tags.Tagged_Kind :=
6866 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6867 -- P : Parameters := (Param1 .. ParamN);
6872 -- if K = Ada.Tags.TK_Limited_Tagged
6873 -- or else K = Ada.Tags.TK_Tagged
6875 -- <dispatching-call>;
6876 -- <triggering-statements>;
6880 -- Ada.Tags.Get_Offset_Index
6881 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6883 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6885 -- if C = POK_Protected_Entry then
6887 -- procedure _clean is
6889 -- if Enqueued (Bnn) then
6890 -- Cancel_Protected_Entry_Call (Bnn);
6896 -- _Disp_Asynchronous_Select
6897 -- (<object>, S, P'Address, D, B);
6898 -- Bnn := Communication_Block (D);
6900 -- Param1 := P.Param1;
6902 -- ParamN := P.ParamN;
6904 -- if Enqueued (Bnn) then
6905 -- <abortable-statements>
6908 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6911 -- when Abort_Signal => Abort_Undefer;
6914 -- if not Cancelled (Bnn) then
6915 -- <triggering-statements>
6918 -- elsif C = POK_Task_Entry then
6920 -- procedure _clean is
6922 -- Cancel_Task_Entry_Call (U);
6928 -- _Disp_Asynchronous_Select
6929 -- (<object>, S, P'Address, D, B);
6930 -- Bnn := Communication_Bloc (D);
6932 -- Param1 := P.Param1;
6934 -- ParamN := P.ParamN;
6939 -- <abortable-statements>
6941 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6944 -- when Abort_Signal => Abort_Undefer;
6948 -- <triggering-statements>
6953 -- <dispatching-call>;
6954 -- <triggering-statements>
6959 -- The job is to convert this to the asynchronous form
6961 -- If the trigger is a delay statement, it will have been expanded into
6962 -- a call to one of the GNARL delay procedures. This routine will convert
6963 -- this into a protected entry call on a delay object and then continue
6964 -- processing as for a protected entry call trigger. This requires
6965 -- declaring a Delay_Block object and adding a pointer to this object to
6966 -- the parameter list of the delay procedure to form the parameter list of
6967 -- the entry call. This object is used by the runtime to queue the delay
6970 -- For a description of the use of P and the assignments after the call,
6971 -- see Expand_N_Entry_Call_Statement.
6973 procedure Expand_N_Asynchronous_Select (N : Node_Id) is
6974 Loc : constant Source_Ptr := Sloc (N);
6975 Abrt : constant Node_Id := Abortable_Part (N);
6976 Trig : constant Node_Id := Triggering_Alternative (N);
6978 Abort_Block_Ent : Entity_Id;
6979 Abortable_Block : Node_Id;
6982 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A');
6983 Blk_Typ : Entity_Id;
6985 Call_Ent : Entity_Id;
6986 Cancel_Param : Entity_Id;
6987 Cleanup_Block : Node_Id;
6988 Cleanup_Block_Ent : Entity_Id;
6989 Cleanup_Stmts : List_Id;
6990 Conc_Typ_Stmts : List_Id;
6992 Dblock_Ent : Entity_Id;
6997 Enqueue_Call : Node_Id;
7000 Handler_Stmt : Node_Id;
7002 Lim_Typ_Stmts : List_Id;
7008 ProtE_Stmts : List_Id;
7009 ProtP_Stmts : List_Id;
7012 TaskE_Stmts : List_Id;
7015 B : Entity_Id; -- Call status flag
7016 Bnn : Entity_Id; -- Communication block
7017 C : Entity_Id; -- Call kind
7018 K : Entity_Id; -- Tagged kind
7019 P : Entity_Id; -- Parameter block
7020 S : Entity_Id; -- Primitive operation slot
7021 T : Entity_Id; -- Additional status flag
7023 procedure Rewrite_Abortable_Part;
7024 -- If the trigger is a dispatching call, the expansion inserts multiple
7025 -- copies of the abortable part. This is both inefficient, and may lead
7026 -- to duplicate definitions that the back-end will reject, when the
7027 -- abortable part includes loops. This procedure rewrites the abortable
7028 -- part into a call to a generated procedure.
7030 ----------------------------
7031 -- Rewrite_Abortable_Part --
7032 ----------------------------
7034 procedure Rewrite_Abortable_Part is
7035 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
7040 Make_Subprogram_Body (Loc,
7042 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
7043 Declarations => New_List,
7044 Handled_Statement_Sequence =>
7045 Make_Handled_Sequence_Of_Statements (Loc, Astats));
7046 Insert_Before (N, Decl);
7049 -- Rewrite abortable part into a call to this procedure
7053 Make_Procedure_Call_Statement (Loc,
7054 Name => New_Occurrence_Of (Proc, Loc)));
7055 end Rewrite_Abortable_Part;
7057 -- Start of processing for Expand_N_Asynchronous_Select
7060 -- Asynchronous select is not supported on restricted runtimes. Don't
7063 if Restricted_Profile then
7067 Process_Statements_For_Controlled_Objects (Trig);
7068 Process_Statements_For_Controlled_Objects (Abrt);
7070 Ecall := Triggering_Statement (Trig);
7072 Ensure_Statement_Present (Sloc (Ecall), Trig);
7074 -- Retrieve Astats and Tstats now because the finalization machinery may
7075 -- wrap them in blocks.
7077 Astats := Statements (Abrt);
7078 Tstats := Statements (Trig);
7080 -- The arguments in the call may require dynamic allocation, and the
7081 -- call statement may have been transformed into a block. The block
7082 -- may contain additional declarations for internal entities, and the
7083 -- original call is found by sequential search.
7085 if Nkind (Ecall) = N_Block_Statement then
7086 Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
7087 while not Nkind_In (Ecall, N_Procedure_Call_Statement,
7088 N_Entry_Call_Statement)
7094 -- This is either a dispatching call or a delay statement used as a
7095 -- trigger which was expanded into a procedure call.
7097 if Nkind (Ecall) = N_Procedure_Call_Statement then
7098 if Ada_Version >= Ada_2005
7100 (No (Original_Node (Ecall))
7101 or else not Nkind_In (Original_Node (Ecall),
7102 N_Delay_Relative_Statement,
7103 N_Delay_Until_Statement))
7105 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
7107 Rewrite_Abortable_Part;
7111 -- Call status flag processing, generate:
7112 -- B : Boolean := False;
7114 B := Build_B (Loc, Decls);
7116 -- Communication block processing, generate:
7117 -- Bnn : Communication_Block;
7119 Bnn := Make_Temporary (Loc, 'B');
7121 Make_Object_Declaration (Loc,
7122 Defining_Identifier => Bnn,
7123 Object_Definition =>
7124 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
7126 -- Call kind processing, generate:
7127 -- C : Ada.Tags.Prim_Op_Kind;
7129 C := Build_C (Loc, Decls);
7131 -- Tagged kind processing, generate:
7132 -- K : Ada.Tags.Tagged_Kind :=
7133 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7135 -- Dummy communication block, generate:
7136 -- D : Dummy_Communication_Block;
7139 Make_Object_Declaration (Loc,
7140 Defining_Identifier =>
7141 Make_Defining_Identifier (Loc, Name_uD),
7142 Object_Definition =>
7144 (RTE (RE_Dummy_Communication_Block), Loc)));
7146 K := Build_K (Loc, Decls, Obj);
7148 -- Parameter block processing
7150 Blk_Typ := Build_Parameter_Block
7151 (Loc, Actuals, Formals, Decls);
7152 P := Parameter_Block_Pack
7153 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
7155 -- Dispatch table slot processing, generate:
7158 S := Build_S (Loc, Decls);
7160 -- Additional status flag processing, generate:
7163 T := Make_Temporary (Loc, 'T');
7165 Make_Object_Declaration (Loc,
7166 Defining_Identifier => T,
7167 Object_Definition =>
7168 New_Occurrence_Of (Standard_Boolean, Loc)));
7170 ------------------------------
7171 -- Protected entry handling --
7172 ------------------------------
7175 -- Param1 := P.Param1;
7177 -- ParamN := P.ParamN;
7179 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7182 -- Bnn := Communication_Block (D);
7184 Prepend_To (Cleanup_Stmts,
7185 Make_Assignment_Statement (Loc,
7186 Name => New_Occurrence_Of (Bnn, Loc),
7188 Make_Unchecked_Type_Conversion (Loc,
7190 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7191 Expression => Make_Identifier (Loc, Name_uD))));
7194 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7196 Prepend_To (Cleanup_Stmts,
7197 Make_Procedure_Call_Statement (Loc,
7201 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select),
7203 Parameter_Associations =>
7205 New_Copy_Tree (Obj), -- <object>
7206 New_Occurrence_Of (S, Loc), -- S
7207 Make_Attribute_Reference (Loc, -- P'Address
7208 Prefix => New_Occurrence_Of (P, Loc),
7209 Attribute_Name => Name_Address),
7210 Make_Identifier (Loc, Name_uD), -- D
7211 New_Occurrence_Of (B, Loc)))); -- B
7214 -- if Enqueued (Bnn) then
7215 -- <abortable-statements>
7218 Append_To (Cleanup_Stmts,
7219 Make_Implicit_If_Statement (N,
7221 Make_Function_Call (Loc,
7223 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7224 Parameter_Associations =>
7225 New_List (New_Occurrence_Of (Bnn, Loc))),
7228 New_Copy_List_Tree (Astats)));
7230 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7231 -- will then generate a _clean for the communication block Bnn.
7235 -- procedure _clean is
7237 -- if Enqueued (Bnn) then
7238 -- Cancel_Protected_Entry_Call (Bnn);
7247 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7249 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
7251 -- Wrap the cleanup block in an exception handling block
7257 -- when Abort_Signal => Abort_Undefer;
7260 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7263 Make_Implicit_Label_Declaration (Loc,
7264 Defining_Identifier => Abort_Block_Ent),
7267 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7270 -- if not Cancelled (Bnn) then
7271 -- <triggering-statements>
7274 Append_To (ProtE_Stmts,
7275 Make_Implicit_If_Statement (N,
7279 Make_Function_Call (Loc,
7281 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7282 Parameter_Associations =>
7283 New_List (New_Occurrence_Of (Bnn, Loc)))),
7286 New_Copy_List_Tree (Tstats)));
7288 -------------------------
7289 -- Task entry handling --
7290 -------------------------
7293 -- Param1 := P.Param1;
7295 -- ParamN := P.ParamN;
7297 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7300 -- Bnn := Communication_Block (D);
7302 Append_To (TaskE_Stmts,
7303 Make_Assignment_Statement (Loc,
7305 New_Occurrence_Of (Bnn, Loc),
7307 Make_Unchecked_Type_Conversion (Loc,
7309 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7310 Expression => Make_Identifier (Loc, Name_uD))));
7313 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7315 Prepend_To (TaskE_Stmts,
7316 Make_Procedure_Call_Statement (Loc,
7319 Find_Prim_Op (Etype (Etype (Obj)),
7320 Name_uDisp_Asynchronous_Select),
7323 Parameter_Associations => New_List (
7324 New_Copy_Tree (Obj), -- <object>
7325 New_Occurrence_Of (S, Loc), -- S
7326 Make_Attribute_Reference (Loc, -- P'Address
7327 Prefix => New_Occurrence_Of (P, Loc),
7328 Attribute_Name => Name_Address),
7329 Make_Identifier (Loc, Name_uD), -- D
7330 New_Occurrence_Of (B, Loc)))); -- B
7335 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7339 -- <abortable-statements>
7341 Cleanup_Stmts := New_Copy_List_Tree (Astats);
7344 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7346 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7347 -- will generate a _clean for the additional status flag.
7351 -- procedure _clean is
7353 -- Cancel_Task_Entry_Call (U);
7361 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7363 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
7365 -- Wrap the cleanup block in an exception handling block
7371 -- when Abort_Signal => Abort_Undefer;
7374 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7376 Append_To (TaskE_Stmts,
7377 Make_Implicit_Label_Declaration (Loc,
7378 Defining_Identifier => Abort_Block_Ent));
7380 Append_To (TaskE_Stmts,
7382 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7386 -- <triggering-statements>
7389 Append_To (TaskE_Stmts,
7390 Make_Implicit_If_Statement (N,
7392 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)),
7395 New_Copy_List_Tree (Tstats)));
7397 ----------------------------------
7398 -- Protected procedure handling --
7399 ----------------------------------
7402 -- <dispatching-call>;
7403 -- <triggering-statements>
7405 ProtP_Stmts := New_Copy_List_Tree (Tstats);
7406 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
7409 -- S := Ada.Tags.Get_Offset_Index
7410 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7413 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
7416 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7418 Append_To (Conc_Typ_Stmts,
7419 Make_Procedure_Call_Statement (Loc,
7422 (Find_Prim_Op (Etype (Etype (Obj)),
7423 Name_uDisp_Get_Prim_Op_Kind),
7425 Parameter_Associations =>
7427 New_Copy_Tree (Obj),
7428 New_Occurrence_Of (S, Loc),
7429 New_Occurrence_Of (C, Loc))));
7432 -- if C = POK_Procedure_Entry then
7434 -- elsif C = POK_Task_Entry then
7440 Append_To (Conc_Typ_Stmts,
7441 Make_Implicit_If_Statement (N,
7445 New_Occurrence_Of (C, Loc),
7447 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
7454 Make_Elsif_Part (Loc,
7458 New_Occurrence_Of (C, Loc),
7460 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)),
7469 -- <dispatching-call>;
7470 -- <triggering-statements>
7472 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
7473 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
7476 -- if K = Ada.Tags.TK_Limited_Tagged
7477 -- or else K = Ada.Tags.TK_Tagged
7485 Make_Implicit_If_Statement (N,
7486 Condition => Build_Dispatching_Tag_Check (K, N),
7487 Then_Statements => Lim_Typ_Stmts,
7488 Else_Statements => Conc_Typ_Stmts));
7491 Make_Block_Statement (Loc,
7494 Handled_Statement_Sequence =>
7495 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7500 -- Delay triggering statement processing
7503 -- Add a Delay_Block object to the parameter list of the delay
7504 -- procedure to form the parameter list of the Wait entry call.
7506 Dblock_Ent := Make_Temporary (Loc, 'D');
7508 Pdef := Entity (Name (Ecall));
7510 if Is_RTE (Pdef, RO_CA_Delay_For) then
7512 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc);
7514 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
7516 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc);
7518 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
7519 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc);
7522 Append_To (Parameter_Associations (Ecall),
7523 Make_Attribute_Reference (Loc,
7524 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7525 Attribute_Name => Name_Unchecked_Access));
7527 -- Create the inner block to protect the abortable part
7529 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7531 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7534 Make_Block_Statement (Loc,
7535 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7536 Handled_Statement_Sequence =>
7537 Make_Handled_Sequence_Of_Statements (Loc,
7538 Statements => Astats),
7539 Has_Created_Identifier => True,
7540 Is_Asynchronous_Call_Block => True);
7542 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7545 Make_Implicit_If_Statement (N,
7547 Make_Function_Call (Loc,
7548 Name => Enqueue_Call,
7549 Parameter_Associations => Parameter_Associations (Ecall)),
7551 New_List (Make_Block_Statement (Loc,
7552 Handled_Statement_Sequence =>
7553 Make_Handled_Sequence_Of_Statements (Loc,
7554 Statements => New_List (
7555 Make_Implicit_Label_Declaration (Loc,
7556 Defining_Identifier => Blk_Ent,
7557 Label_Construct => Abortable_Block),
7559 Exception_Handlers => Hdle)))));
7561 Stmts := New_List (Ecall);
7563 -- Construct statement sequence for new block
7566 Make_Implicit_If_Statement (N,
7568 Make_Function_Call (Loc,
7569 Name => New_Occurrence_Of (
7570 RTE (RE_Timed_Out), Loc),
7571 Parameter_Associations => New_List (
7572 Make_Attribute_Reference (Loc,
7573 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7574 Attribute_Name => Name_Unchecked_Access))),
7575 Then_Statements => Tstats));
7577 -- The result is the new block
7579 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
7582 Make_Block_Statement (Loc,
7583 Declarations => New_List (
7584 Make_Object_Declaration (Loc,
7585 Defining_Identifier => Dblock_Ent,
7586 Aliased_Present => True,
7587 Object_Definition =>
7588 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))),
7590 Handled_Statement_Sequence =>
7591 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7601 Extract_Entry (Ecall, Concval, Ename, Index);
7602 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
7604 Stmts := Statements (Handled_Statement_Sequence (Ecall));
7605 Decls := Declarations (Ecall);
7607 if Is_Protected_Type (Etype (Concval)) then
7609 -- Get the declarations of the block expanded from the entry call
7611 Decl := First (Decls);
7612 while Present (Decl)
7613 and then (Nkind (Decl) /= N_Object_Declaration
7614 or else not Is_RTE (Etype (Object_Definition (Decl)),
7615 RE_Communication_Block))
7620 pragma Assert (Present (Decl));
7621 Cancel_Param := Defining_Identifier (Decl);
7623 -- Change the mode of the Protected_Entry_Call call
7625 -- Protected_Entry_Call (
7626 -- Object => po._object'Access,
7627 -- E => <entry index>;
7628 -- Uninterpreted_Data => P'Address;
7629 -- Mode => Asynchronous_Call;
7632 -- Skip assignments to temporaries created for in-out parameters
7634 -- This makes unwarranted assumptions about the shape of the expanded
7635 -- tree for the call, and should be cleaned up ???
7637 Stmt := First (Stmts);
7638 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7644 Param := First (Parameter_Associations (Call));
7645 while Present (Param)
7646 and then not Is_RTE (Etype (Param), RE_Call_Modes)
7651 pragma Assert (Present (Param));
7652 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7655 -- Append an if statement to execute the abortable part
7658 -- if Enqueued (Bnn) then
7661 Make_Implicit_If_Statement (N,
7663 Make_Function_Call (Loc,
7664 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7665 Parameter_Associations => New_List (
7666 New_Occurrence_Of (Cancel_Param, Loc))),
7667 Then_Statements => Astats));
7670 Make_Block_Statement (Loc,
7671 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7672 Handled_Statement_Sequence =>
7673 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts),
7674 Has_Created_Identifier => True,
7675 Is_Asynchronous_Call_Block => True);
7677 -- Aborts are not deferred at beginning of exception handlers in
7680 if ZCX_Exceptions then
7681 Handler_Stmt := Make_Null_Statement (Loc);
7684 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer);
7688 Make_Block_Statement (Loc,
7689 Handled_Statement_Sequence =>
7690 Make_Handled_Sequence_Of_Statements (Loc,
7691 Statements => New_List (
7692 Make_Implicit_Label_Declaration (Loc,
7693 Defining_Identifier => Blk_Ent,
7694 Label_Construct => Abortable_Block),
7699 Exception_Handlers => New_List (
7700 Make_Implicit_Exception_Handler (Loc,
7702 -- when Abort_Signal =>
7703 -- Abort_Undefer.all;
7705 Exception_Choices =>
7706 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
7707 Statements => New_List (Handler_Stmt))))),
7709 -- if not Cancelled (Bnn) then
7710 -- triggered statements
7713 Make_Implicit_If_Statement (N,
7714 Condition => Make_Op_Not (Loc,
7716 Make_Function_Call (Loc,
7717 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7718 Parameter_Associations => New_List (
7719 New_Occurrence_Of (Cancel_Param, Loc)))),
7720 Then_Statements => Tstats));
7722 -- Asynchronous task entry call
7729 B := Make_Defining_Identifier (Loc, Name_uB);
7731 -- Insert declaration of B in declarations of existing block
7734 Make_Object_Declaration (Loc,
7735 Defining_Identifier => B,
7736 Object_Definition =>
7737 New_Occurrence_Of (Standard_Boolean, Loc)));
7739 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
7741 -- Insert the declaration of C in the declarations of the existing
7742 -- block. The variable is initialized to something (True or False,
7743 -- does not matter) to prevent CodePeer from complaining about a
7744 -- possible read of an uninitialized variable.
7747 Make_Object_Declaration (Loc,
7748 Defining_Identifier => Cancel_Param,
7749 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
7750 Expression => New_Occurrence_Of (Standard_False, Loc),
7751 Has_Init_Expression => True));
7753 -- Remove and save the call to Call_Simple
7755 Stmt := First (Stmts);
7757 -- Skip assignments to temporaries created for in-out parameters.
7758 -- This makes unwarranted assumptions about the shape of the expanded
7759 -- tree for the call, and should be cleaned up ???
7761 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7767 -- Create the inner block to protect the abortable part
7769 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7771 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7774 Make_Block_Statement (Loc,
7775 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7776 Handled_Statement_Sequence =>
7777 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats),
7778 Has_Created_Identifier => True,
7779 Is_Asynchronous_Call_Block => True);
7782 Make_Block_Statement (Loc,
7783 Handled_Statement_Sequence =>
7784 Make_Handled_Sequence_Of_Statements (Loc,
7785 Statements => New_List (
7786 Make_Implicit_Label_Declaration (Loc,
7787 Defining_Identifier => Blk_Ent,
7788 Label_Construct => Abortable_Block),
7790 Exception_Handlers => Hdle)));
7792 -- Create new call statement
7794 Params := Parameter_Associations (Call);
7797 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7798 Append_To (Params, New_Occurrence_Of (B, Loc));
7801 Make_Procedure_Call_Statement (Loc,
7802 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
7803 Parameter_Associations => Params));
7805 -- Construct statement sequence for new block
7808 Make_Implicit_If_Statement (N,
7810 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)),
7811 Then_Statements => Tstats));
7813 -- Protected the call against abort
7815 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7818 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
7820 -- The result is the new block
7823 Make_Block_Statement (Loc,
7824 Declarations => Decls,
7825 Handled_Statement_Sequence =>
7826 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7829 end Expand_N_Asynchronous_Select;
7831 -------------------------------------
7832 -- Expand_N_Conditional_Entry_Call --
7833 -------------------------------------
7835 -- The conditional task entry call is converted to a call to
7840 -- P : parms := (parm, parm, parm);
7844 -- (<acceptor-task>, -- Acceptor
7845 -- <entry-index>, -- E
7846 -- P'Address, -- Uninterpreted_Data
7847 -- Conditional_Call, -- Mode
7848 -- B); -- Rendezvous_Successful
7853 -- normal-statements
7859 -- For a description of the use of P and the assignments after the call,
7860 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7861 -- conditional entry call has already been expanded (by the Expand_N_Entry
7862 -- _Call_Statement procedure) as follows:
7865 -- P : parms := (parm, parm, parm);
7867 -- ... info for in-out parameters
7868 -- Call_Simple (acceptor-task, entry-index, P'Address);
7874 -- so the task at hand is to convert the latter expansion into the former
7876 -- The conditional protected entry call is converted to a call to
7877 -- Protected_Entry_Call:
7880 -- P : parms := (parm, parm, parm);
7881 -- Bnn : Communications_Block;
7884 -- Protected_Entry_Call
7885 -- (po._object'Access, -- Object
7886 -- <entry index>, -- E
7887 -- P'Address, -- Uninterpreted_Data
7888 -- Conditional_Call, -- Mode
7893 -- if Cancelled (Bnn) then
7896 -- normal-statements
7900 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7904 -- B : Boolean := False;
7905 -- C : Ada.Tags.Prim_Op_Kind;
7906 -- K : Ada.Tags.Tagged_Kind :=
7907 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7908 -- P : Parameters := (Param1 .. ParamN);
7912 -- if K = Ada.Tags.TK_Limited_Tagged
7913 -- or else K = Ada.Tags.TK_Tagged
7915 -- <dispatching-call>;
7916 -- <triggering-statements>
7920 -- Ada.Tags.Get_Offset_Index
7921 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7923 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7925 -- if C = POK_Protected_Entry
7926 -- or else C = POK_Task_Entry
7928 -- Param1 := P.Param1;
7930 -- ParamN := P.ParamN;
7934 -- if C = POK_Procedure
7935 -- or else C = POK_Protected_Procedure
7936 -- or else C = POK_Task_Procedure
7938 -- <dispatching-call>;
7941 -- <triggering-statements>
7943 -- <else-statements>
7948 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
7949 Loc : constant Source_Ptr := Sloc (N);
7950 Alt : constant Node_Id := Entry_Call_Alternative (N);
7951 Blk : Node_Id := Entry_Call_Statement (Alt);
7954 Blk_Typ : Entity_Id;
7956 Call_Ent : Entity_Id;
7957 Conc_Typ_Stmts : List_Id;
7961 Lim_Typ_Stmts : List_Id;
7968 Transient_Blk : Node_Id;
7971 B : Entity_Id; -- Call status flag
7972 C : Entity_Id; -- Call kind
7973 K : Entity_Id; -- Tagged kind
7974 P : Entity_Id; -- Parameter block
7975 S : Entity_Id; -- Primitive operation slot
7978 Process_Statements_For_Controlled_Objects (N);
7980 if Ada_Version >= Ada_2005
7981 and then Nkind (Blk) = N_Procedure_Call_Statement
7983 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
7988 -- Call status flag processing, generate:
7989 -- B : Boolean := False;
7991 B := Build_B (Loc, Decls);
7993 -- Call kind processing, generate:
7994 -- C : Ada.Tags.Prim_Op_Kind;
7996 C := Build_C (Loc, Decls);
7998 -- Tagged kind processing, generate:
7999 -- K : Ada.Tags.Tagged_Kind :=
8000 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8002 K := Build_K (Loc, Decls, Obj);
8004 -- Parameter block processing
8006 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
8007 P := Parameter_Block_Pack
8008 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
8010 -- Dispatch table slot processing, generate:
8013 S := Build_S (Loc, Decls);
8016 -- S := Ada.Tags.Get_Offset_Index
8017 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
8020 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
8023 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8025 Append_To (Conc_Typ_Stmts,
8026 Make_Procedure_Call_Statement (Loc,
8029 Find_Prim_Op (Etype (Etype (Obj)),
8030 Name_uDisp_Conditional_Select),
8032 Parameter_Associations =>
8034 New_Copy_Tree (Obj), -- <object>
8035 New_Occurrence_Of (S, Loc), -- S
8036 Make_Attribute_Reference (Loc, -- P'Address
8037 Prefix => New_Occurrence_Of (P, Loc),
8038 Attribute_Name => Name_Address),
8039 New_Occurrence_Of (C, Loc), -- C
8040 New_Occurrence_Of (B, Loc)))); -- B
8043 -- if C = POK_Protected_Entry
8044 -- or else C = POK_Task_Entry
8046 -- Param1 := P.Param1;
8048 -- ParamN := P.ParamN;
8051 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
8053 -- Generate the if statement only when the packed parameters need
8054 -- explicit assignments to their corresponding actuals.
8056 if Present (Unpack) then
8057 Append_To (Conc_Typ_Stmts,
8058 Make_Implicit_If_Statement (N,
8064 New_Occurrence_Of (C, Loc),
8066 New_Occurrence_Of (RTE (
8067 RE_POK_Protected_Entry), Loc)),
8072 New_Occurrence_Of (C, Loc),
8074 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
8076 Then_Statements => Unpack));
8081 -- if C = POK_Procedure
8082 -- or else C = POK_Protected_Procedure
8083 -- or else C = POK_Task_Procedure
8085 -- <dispatching-call>
8087 -- <normal-statements>
8089 -- <else-statements>
8092 N_Stats := New_Copy_List_Tree (Statements (Alt));
8094 Prepend_To (N_Stats,
8095 Make_Implicit_If_Statement (N,
8101 New_Occurrence_Of (C, Loc),
8103 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
8110 New_Occurrence_Of (C, Loc),
8112 New_Occurrence_Of (RTE (
8113 RE_POK_Protected_Procedure), Loc)),
8118 New_Occurrence_Of (C, Loc),
8120 New_Occurrence_Of (RTE (
8121 RE_POK_Task_Procedure), Loc)))),
8126 Append_To (Conc_Typ_Stmts,
8127 Make_Implicit_If_Statement (N,
8128 Condition => New_Occurrence_Of (B, Loc),
8129 Then_Statements => N_Stats,
8130 Else_Statements => Else_Statements (N)));
8133 -- <dispatching-call>;
8134 -- <triggering-statements>
8136 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
8137 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
8140 -- if K = Ada.Tags.TK_Limited_Tagged
8141 -- or else K = Ada.Tags.TK_Tagged
8149 Make_Implicit_If_Statement (N,
8150 Condition => Build_Dispatching_Tag_Check (K, N),
8151 Then_Statements => Lim_Typ_Stmts,
8152 Else_Statements => Conc_Typ_Stmts));
8155 Make_Block_Statement (Loc,
8158 Handled_Statement_Sequence =>
8159 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8161 -- As described above, the entry alternative is transformed into a
8162 -- block that contains the gnulli call, and possibly assignment
8163 -- statements for in-out parameters. The gnulli call may itself be
8164 -- rewritten into a transient block if some unconstrained parameters
8165 -- require it. We need to retrieve the call to complete its parameter
8170 First_Real_Statement (Handled_Statement_Sequence (Blk));
8172 if Present (Transient_Blk)
8173 and then Nkind (Transient_Blk) = N_Block_Statement
8175 Blk := Transient_Blk;
8178 Stmts := Statements (Handled_Statement_Sequence (Blk));
8179 Stmt := First (Stmts);
8180 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
8185 Params := Parameter_Associations (Call);
8187 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
8189 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8191 Param := First (Params);
8192 while Present (Param)
8193 and then not Is_RTE (Etype (Param), RE_Call_Modes)
8198 pragma Assert (Present (Param));
8200 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8204 -- Find the Communication_Block parameter for the call to the
8205 -- Cancelled function.
8207 Decl := First (Declarations (Blk));
8208 while Present (Decl)
8209 and then not Is_RTE (Etype (Object_Definition (Decl)),
8210 RE_Communication_Block)
8215 -- Add an if statement to execute the else part if the call
8216 -- does not succeed (as indicated by the Cancelled predicate).
8219 Make_Implicit_If_Statement (N,
8220 Condition => Make_Function_Call (Loc,
8221 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
8222 Parameter_Associations => New_List (
8223 New_Occurrence_Of (Defining_Identifier (Decl), Loc))),
8224 Then_Statements => Else_Statements (N),
8225 Else_Statements => Statements (Alt)));
8228 B := Make_Defining_Identifier (Loc, Name_uB);
8230 -- Insert declaration of B in declarations of existing block
8232 if No (Declarations (Blk)) then
8233 Set_Declarations (Blk, New_List);
8236 Prepend_To (Declarations (Blk),
8237 Make_Object_Declaration (Loc,
8238 Defining_Identifier => B,
8239 Object_Definition =>
8240 New_Occurrence_Of (Standard_Boolean, Loc)));
8242 -- Create new call statement
8245 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8246 Append_To (Params, New_Occurrence_Of (B, Loc));
8249 Make_Procedure_Call_Statement (Loc,
8250 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
8251 Parameter_Associations => Params));
8253 -- Construct statement sequence for new block
8256 Make_Implicit_If_Statement (N,
8257 Condition => New_Occurrence_Of (B, Loc),
8258 Then_Statements => Statements (Alt),
8259 Else_Statements => Else_Statements (N)));
8262 -- The result is the new block
8265 Make_Block_Statement (Loc,
8266 Declarations => Declarations (Blk),
8267 Handled_Statement_Sequence =>
8268 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8273 Reset_Scopes_To (N, Entity (Identifier (N)));
8274 end Expand_N_Conditional_Entry_Call;
8276 ---------------------------------------
8277 -- Expand_N_Delay_Relative_Statement --
8278 ---------------------------------------
8280 -- Delay statement is implemented as a procedure call to Delay_For
8281 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8282 -- simple delays imposed by the use of Protected Objects.
8284 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
8285 Loc : constant Source_Ptr := Sloc (N);
8289 -- Try to use Ada.Calendar.Delays.Delay_For if available.
8291 if RTE_Available (RO_CA_Delay_For) then
8292 Proc := RTE (RO_CA_Delay_For);
8294 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error
8295 -- message if not available. This is the implementation used on
8296 -- restricted platforms when Ada.Calendar is not available.
8299 Proc := RTE (RO_RD_Delay_For);
8303 Make_Procedure_Call_Statement (Loc,
8304 Name => New_Occurrence_Of (Proc, Loc),
8305 Parameter_Associations => New_List (Expression (N))));
8307 end Expand_N_Delay_Relative_Statement;
8309 ------------------------------------
8310 -- Expand_N_Delay_Until_Statement --
8311 ------------------------------------
8313 -- Delay Until statement is implemented as a procedure call to
8314 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8316 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
8317 Loc : constant Source_Ptr := Sloc (N);
8321 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
8322 Typ := RTE (RO_CA_Delay_Until);
8324 Typ := RTE (RO_RT_Delay_Until);
8328 Make_Procedure_Call_Statement (Loc,
8329 Name => New_Occurrence_Of (Typ, Loc),
8330 Parameter_Associations => New_List (Expression (N))));
8333 end Expand_N_Delay_Until_Statement;
8335 -------------------------
8336 -- Expand_N_Entry_Body --
8337 -------------------------
8339 procedure Expand_N_Entry_Body (N : Node_Id) is
8341 -- Associate discriminals with the next protected operation body to be
8344 if Present (Next_Protected_Operation (N)) then
8345 Set_Discriminals (Parent (Current_Scope));
8347 end Expand_N_Entry_Body;
8349 -----------------------------------
8350 -- Expand_N_Entry_Call_Statement --
8351 -----------------------------------
8353 -- An entry call is expanded into GNARLI calls to implement a simple entry
8354 -- call (see Build_Simple_Entry_Call).
8356 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
8362 if No_Run_Time_Mode then
8363 Error_Msg_CRT ("entry call", N);
8367 -- If this entry call is part of an asynchronous select, don't expand it
8368 -- here; it will be expanded with the select statement. Don't expand
8369 -- timed entry calls either, as they are translated into asynchronous
8372 -- ??? This whole approach is questionable; it may be better to go back
8373 -- to allowing the expansion to take place and then attempting to fix it
8374 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8375 -- whether the expanded call is on a task or protected entry.
8377 if (Nkind (Parent (N)) /= N_Triggering_Alternative
8378 or else N /= Triggering_Statement (Parent (N)))
8379 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
8380 or else N /= Entry_Call_Statement (Parent (N))
8381 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
8383 Extract_Entry (N, Concval, Ename, Index);
8384 Build_Simple_Entry_Call (N, Concval, Ename, Index);
8386 end Expand_N_Entry_Call_Statement;
8388 --------------------------------
8389 -- Expand_N_Entry_Declaration --
8390 --------------------------------
8392 -- If there are parameters, then first, each of the formals is marked by
8393 -- setting Is_Entry_Formal. Next a record type is built which is used to
8394 -- hold the parameter values. The name of this record type is entryP where
8395 -- entry is the name of the entry, with an additional corresponding access
8396 -- type called entryPA. The record type has matching components for each
8397 -- formal (the component names are the same as the formal names). For
8398 -- elementary types, the component type matches the formal type. For
8399 -- composite types, an access type is declared (with the name formalA)
8400 -- which designates the formal type, and the type of the component is this
8401 -- access type. Finally the Entry_Component of each formal is set to
8402 -- reference the corresponding record component.
8404 procedure Expand_N_Entry_Declaration (N : Node_Id) is
8405 Loc : constant Source_Ptr := Sloc (N);
8406 Entry_Ent : constant Entity_Id := Defining_Identifier (N);
8407 Components : List_Id;
8410 Last_Decl : Node_Id;
8411 Component : Entity_Id;
8414 Rec_Ent : Entity_Id;
8415 Acc_Ent : Entity_Id;
8418 Formal := First_Formal (Entry_Ent);
8421 -- Most processing is done only if parameters are present
8423 if Present (Formal) then
8424 Components := New_List;
8426 -- Loop through formals
8428 while Present (Formal) loop
8429 Set_Is_Entry_Formal (Formal);
8431 Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
8432 Set_Entry_Component (Formal, Component);
8433 Set_Entry_Formal (Component, Formal);
8434 Ftype := Etype (Formal);
8436 -- Declare new access type and then append
8438 Ctype := Make_Temporary (Loc, 'A');
8439 Set_Is_Param_Block_Component_Type (Ctype);
8442 Make_Full_Type_Declaration (Loc,
8443 Defining_Identifier => Ctype,
8445 Make_Access_To_Object_Definition (Loc,
8446 All_Present => True,
8447 Constant_Present => Ekind (Formal) = E_In_Parameter,
8448 Subtype_Indication => New_Occurrence_Of (Ftype, Loc)));
8450 Insert_After (Last_Decl, Decl);
8453 Append_To (Components,
8454 Make_Component_Declaration (Loc,
8455 Defining_Identifier => Component,
8456 Component_Definition =>
8457 Make_Component_Definition (Loc,
8458 Aliased_Present => False,
8459 Subtype_Indication => New_Occurrence_Of (Ctype, Loc))));
8461 Next_Formal_With_Extras (Formal);
8464 -- Create the Entry_Parameter_Record declaration
8466 Rec_Ent := Make_Temporary (Loc, 'P');
8469 Make_Full_Type_Declaration (Loc,
8470 Defining_Identifier => Rec_Ent,
8472 Make_Record_Definition (Loc,
8474 Make_Component_List (Loc,
8475 Component_Items => Components)));
8477 Insert_After (Last_Decl, Decl);
8480 -- Construct and link in the corresponding access type
8482 Acc_Ent := Make_Temporary (Loc, 'A');
8484 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
8487 Make_Full_Type_Declaration (Loc,
8488 Defining_Identifier => Acc_Ent,
8490 Make_Access_To_Object_Definition (Loc,
8491 All_Present => True,
8492 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc)));
8494 Insert_After (Last_Decl, Decl);
8496 end Expand_N_Entry_Declaration;
8498 -----------------------------
8499 -- Expand_N_Protected_Body --
8500 -----------------------------
8502 -- Protected bodies are expanded to the completion of the subprograms
8503 -- created for the corresponding protected type. These are a protected and
8504 -- unprotected version of each protected subprogram in the object, a
8505 -- function to calculate each entry barrier, and a procedure to execute the
8506 -- sequence of statements of each protected entry body. For example, for
8507 -- protected type ptype:
8510 -- (O : System.Address;
8511 -- E : Protected_Entry_Index)
8514 -- <discriminant renamings>
8515 -- <private object renamings>
8517 -- return <barrier expression>;
8520 -- procedure pprocN (_object : in out poV;...) is
8521 -- <discriminant renamings>
8522 -- <private object renamings>
8524 -- <sequence of statements>
8527 -- procedure pprocP (_object : in out poV;...) is
8528 -- procedure _clean is
8531 -- ptypeS (_object, Pn);
8532 -- Unlock (_object._object'Access);
8533 -- Abort_Undefer.all;
8538 -- Lock (_object._object'Access);
8539 -- pprocN (_object;...);
8544 -- function pfuncN (_object : poV;...) return Return_Type is
8545 -- <discriminant renamings>
8546 -- <private object renamings>
8548 -- <sequence of statements>
8551 -- function pfuncP (_object : poV) return Return_Type is
8552 -- procedure _clean is
8554 -- Unlock (_object._object'Access);
8555 -- Abort_Undefer.all;
8560 -- Lock (_object._object'Access);
8561 -- return pfuncN (_object);
8568 -- (O : System.Address;
8569 -- P : System.Address;
8570 -- E : Protected_Entry_Index)
8572 -- <discriminant renamings>
8573 -- <private object renamings>
8574 -- type poVP is access poV;
8575 -- _Object : ptVP := ptVP!(O);
8579 -- <statement sequence>
8580 -- Complete_Entry_Body (_Object._Object);
8582 -- when all others =>
8583 -- Exceptional_Complete_Entry_Body (
8584 -- _Object._Object, Get_GNAT_Exception);
8588 -- The type poV is the record created for the protected type to hold
8589 -- the state of the protected object.
8591 procedure Expand_N_Protected_Body (N : Node_Id) is
8592 Loc : constant Source_Ptr := Sloc (N);
8593 Pid : constant Entity_Id := Corresponding_Spec (N);
8595 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid);
8596 -- This flag indicates whether the lock free implementation is active
8598 Current_Node : Node_Id;
8599 Disp_Op_Body : Node_Id;
8600 New_Op_Body : Node_Id;
8604 function Build_Dispatching_Subprogram_Body
8607 Prot_Bod : Node_Id) return Node_Id;
8608 -- Build a dispatching version of the protected subprogram body. The
8609 -- newly generated subprogram contains a call to the original protected
8610 -- body. The following code is generated:
8612 -- function <protected-function-name> (Param1 .. ParamN) return
8615 -- return <protected-function-name>P (Param1 .. ParamN);
8616 -- end <protected-function-name>;
8620 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8622 -- <protected-procedure-name>P (Param1 .. ParamN);
8623 -- end <protected-procedure-name>
8625 ---------------------------------------
8626 -- Build_Dispatching_Subprogram_Body --
8627 ---------------------------------------
8629 function Build_Dispatching_Subprogram_Body
8632 Prot_Bod : Node_Id) return Node_Id
8634 Loc : constant Source_Ptr := Sloc (N);
8641 -- Generate a specification without a letter suffix in order to
8642 -- override an interface function or procedure.
8644 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
8646 -- The formal parameters become the actuals of the protected function
8647 -- or procedure call.
8649 Actuals := New_List;
8650 Formal := First (Parameter_Specifications (Spec));
8651 while Present (Formal) loop
8653 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
8657 if Nkind (Spec) = N_Procedure_Specification then
8660 Make_Procedure_Call_Statement (Loc,
8662 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8663 Parameter_Associations => Actuals));
8666 pragma Assert (Nkind (Spec) = N_Function_Specification);
8670 Make_Simple_Return_Statement (Loc,
8672 Make_Function_Call (Loc,
8674 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8675 Parameter_Associations => Actuals)));
8679 Make_Subprogram_Body (Loc,
8680 Declarations => Empty_List,
8681 Specification => Spec,
8682 Handled_Statement_Sequence =>
8683 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8684 end Build_Dispatching_Subprogram_Body;
8686 -- Start of processing for Expand_N_Protected_Body
8689 if No_Run_Time_Mode then
8690 Error_Msg_CRT ("protected body", N);
8694 -- This is the proper body corresponding to a stub. The declarations
8695 -- must be inserted at the point of the stub, which in turn is in the
8696 -- declarative part of the parent unit.
8698 if Nkind (Parent (N)) = N_Subunit then
8699 Current_Node := Corresponding_Stub (Parent (N));
8704 Op_Body := First (Declarations (N));
8706 -- The protected body is replaced with the bodies of its protected
8707 -- operations, and the declarations for internal objects that may
8708 -- have been created for entry family bounds.
8710 Rewrite (N, Make_Null_Statement (Sloc (N)));
8713 while Present (Op_Body) loop
8714 case Nkind (Op_Body) is
8715 when N_Subprogram_Declaration =>
8718 when N_Subprogram_Body =>
8720 -- Do not create bodies for eliminated operations
8722 if not Is_Eliminated (Defining_Entity (Op_Body))
8723 and then not Is_Eliminated (Corresponding_Spec (Op_Body))
8725 if Lock_Free_Active then
8727 Build_Lock_Free_Unprotected_Subprogram_Body
8731 Build_Unprotected_Subprogram_Body (Op_Body, Pid);
8734 Insert_After (Current_Node, New_Op_Body);
8735 Current_Node := New_Op_Body;
8736 Analyze (New_Op_Body);
8738 -- Build the corresponding protected operation. It may
8739 -- appear that this is needed only if this is a visible
8740 -- operation of the type, or if it is an interrupt handler,
8741 -- and this was the strategy used previously in GNAT.
8743 -- However, the operation may be exported through a 'Access
8744 -- to an external caller. This is the common idiom in code
8745 -- that uses the Ada 2005 Timing_Events package. As a result
8746 -- we need to produce the protected body for both visible
8747 -- and private operations, as well as operations that only
8748 -- have a body in the source, and for which we create a
8749 -- declaration in the protected body itself.
8751 if Present (Corresponding_Spec (Op_Body)) then
8752 if Lock_Free_Active then
8754 Build_Lock_Free_Protected_Subprogram_Body
8755 (Op_Body, Pid, Specification (New_Op_Body));
8758 Build_Protected_Subprogram_Body
8759 (Op_Body, Pid, Specification (New_Op_Body));
8762 Insert_After (Current_Node, New_Op_Body);
8763 Analyze (New_Op_Body);
8765 Current_Node := New_Op_Body;
8767 -- Generate an overriding primitive operation body for
8768 -- this subprogram if the protected type implements an
8771 if Ada_Version >= Ada_2005
8773 Present (Interfaces (Corresponding_Record_Type (Pid)))
8776 Build_Dispatching_Subprogram_Body
8777 (Op_Body, Pid, New_Op_Body);
8779 Insert_After (Current_Node, Disp_Op_Body);
8780 Analyze (Disp_Op_Body);
8782 Current_Node := Disp_Op_Body;
8787 when N_Entry_Body =>
8788 Op_Id := Defining_Identifier (Op_Body);
8789 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
8791 Insert_After (Current_Node, New_Op_Body);
8792 Current_Node := New_Op_Body;
8793 Analyze (New_Op_Body);
8795 when N_Implicit_Label_Declaration =>
8801 New_Op_Body := New_Copy (Op_Body);
8802 Insert_After (Current_Node, New_Op_Body);
8803 Current_Node := New_Op_Body;
8805 when N_Freeze_Entity =>
8806 New_Op_Body := New_Copy (Op_Body);
8808 if Present (Entity (Op_Body))
8809 and then Freeze_Node (Entity (Op_Body)) = Op_Body
8811 Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
8814 Insert_After (Current_Node, New_Op_Body);
8815 Current_Node := New_Op_Body;
8816 Analyze (New_Op_Body);
8819 New_Op_Body := New_Copy (Op_Body);
8820 Insert_After (Current_Node, New_Op_Body);
8821 Current_Node := New_Op_Body;
8822 Analyze (New_Op_Body);
8824 when N_Object_Declaration =>
8825 pragma Assert (not Comes_From_Source (Op_Body));
8826 New_Op_Body := New_Copy (Op_Body);
8827 Insert_After (Current_Node, New_Op_Body);
8828 Current_Node := New_Op_Body;
8829 Analyze (New_Op_Body);
8832 raise Program_Error;
8838 -- Finally, create the body of the function that maps an entry index
8839 -- into the corresponding body index, except when there is no entry, or
8840 -- in a Ravenscar-like profile.
8842 if Corresponding_Runtime_Package (Pid) =
8843 System_Tasking_Protected_Objects_Entries
8845 New_Op_Body := Build_Find_Body_Index (Pid);
8846 Insert_After (Current_Node, New_Op_Body);
8847 Current_Node := New_Op_Body;
8848 Analyze (New_Op_Body);
8851 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8852 -- protected body. At this point all wrapper specs have been created,
8853 -- frozen and included in the dispatch table for the protected type.
8855 if Ada_Version >= Ada_2005 then
8856 Build_Wrapper_Bodies (Loc, Pid, Current_Node);
8858 end Expand_N_Protected_Body;
8860 -----------------------------------------
8861 -- Expand_N_Protected_Type_Declaration --
8862 -----------------------------------------
8864 -- First we create a corresponding record type declaration used to
8865 -- represent values of this protected type.
8866 -- The general form of this type declaration is
8868 -- type poV (discriminants) is record
8869 -- _Object : aliased <kind>Protection
8870 -- [(<entry count> [, <handler count>])];
8871 -- [entry_family : array (bounds) of Void;]
8872 -- <private data fields>
8875 -- The discriminants are present only if the corresponding protected type
8876 -- has discriminants, and they exactly mirror the protected type
8877 -- discriminants. The private data fields similarly mirror the private
8878 -- declarations of the protected type.
8880 -- The Object field is always present. It contains RTS specific data used
8881 -- to control the protected object. It is declared as Aliased so that it
8882 -- can be passed as a pointer to the RTS. This allows the protected record
8883 -- to be referenced within RTS data structures. An appropriate Protection
8884 -- type and discriminant are generated.
8886 -- The Service field is present for protected objects with entries. It
8887 -- contains sufficient information to allow the entry service procedure for
8888 -- this object to be called when the object is not known till runtime.
8890 -- One entry_family component is present for each entry family in the
8891 -- task definition (see Expand_N_Task_Type_Declaration).
8893 -- When a protected object is declared, an instance of the protected type
8894 -- value record is created. The elaboration of this declaration creates the
8895 -- correct bounds for the entry families, and also evaluates the priority
8896 -- expression if needed. The initialization routine for the protected type
8897 -- itself then calls Initialize_Protection with appropriate parameters to
8898 -- initialize the value of the Task_Id field. Install_Handlers may be also
8899 -- called if a pragma Attach_Handler applies.
8901 -- Note: this record is passed to the subprograms created by the expansion
8902 -- of protected subprograms and entries. It is an in parameter to protected
8903 -- functions and an in out parameter to procedures and entry bodies. The
8904 -- Entity_Id for this created record type is placed in the
8905 -- Corresponding_Record_Type field of the associated protected type entity.
8907 -- Next we create a procedure specifications for protected subprograms and
8908 -- entry bodies. For each protected subprograms two subprograms are
8909 -- created, an unprotected and a protected version. The unprotected version
8910 -- is called from within other operations of the same protected object.
8912 -- We also build the call to register the procedure if a pragma
8913 -- Interrupt_Handler applies.
8915 -- A single subprogram is created to service all entry bodies; it has an
8916 -- additional boolean out parameter indicating that the previous entry call
8917 -- made by the current task was serviced immediately, i.e. not by proxy.
8918 -- The O parameter contains a pointer to a record object of the type
8919 -- described above. An untyped interface is used here to allow this
8920 -- procedure to be called in places where the type of the object to be
8921 -- serviced is not known. This must be done, for example, when a call that
8922 -- may have been requeued is cancelled; the corresponding object must be
8923 -- serviced, but which object that is not known till runtime.
8926 -- (O : System.Address; P : out Boolean);
8927 -- procedure pprocN (_object : in out poV);
8928 -- procedure pproc (_object : in out poV);
8929 -- function pfuncN (_object : poV);
8930 -- function pfunc (_object : poV);
8933 -- Note that this must come after the record type declaration, since
8934 -- the specs refer to this type.
8936 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
8937 Discr_Map : constant Elist_Id := New_Elmt_List;
8938 Loc : constant Source_Ptr := Sloc (N);
8939 Prot_Typ : constant Entity_Id := Defining_Identifier (N);
8941 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ);
8942 -- This flag indicates whether the lock free implementation is active
8944 Pdef : constant Node_Id := Protected_Definition (N);
8945 -- This contains two lists; one for visible and one for private decls
8947 Current_Node : Node_Id := N;
8949 Entries_Aggr : Node_Id;
8953 procedure Check_Inlining (Subp : Entity_Id);
8954 -- If the original operation has a pragma Inline, propagate the flag
8955 -- to the internal body, for possible inlining later on. The source
8956 -- operation is invisible to the back-end and is never actually called.
8958 procedure Expand_Entry_Declaration (Decl : Node_Id);
8959 -- Create the entry barrier and the procedure body for entry declaration
8960 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
8962 function Static_Component_Size (Comp : Entity_Id) return Boolean;
8963 -- When compiling under the Ravenscar profile, private components must
8964 -- have a static size, or else a protected object will require heap
8965 -- allocation, violating the corresponding restriction. It is preferable
8966 -- to make this check here, because it provides a better error message
8967 -- than the back-end, which refers to the object as a whole.
8969 procedure Register_Handler;
8970 -- For a protected operation that is an interrupt handler, add the
8971 -- freeze action that will register it as such.
8973 procedure Replace_Access_Definition (Comp : Node_Id);
8974 -- If a private component of the type is an access to itself, this
8975 -- is not a reference to the current instance, but an access type out
8976 -- of which one might construct a list. If such a component exists, we
8977 -- create an incomplete type for the equivalent record type, and
8978 -- a named access type for it, that replaces the access definition
8979 -- of the original component. This is similar to what is done for
8980 -- records in Check_Anonymous_Access_Components, but simpler, because
8981 -- the corresponding record type has no previous declaration.
8982 -- This needs to be done only once, even if there are several such
8983 -- access components. The following entity stores the constructed
8986 Acc_T : Entity_Id := Empty;
8988 --------------------
8989 -- Check_Inlining --
8990 --------------------
8992 procedure Check_Inlining (Subp : Entity_Id) is
8994 if Is_Inlined (Subp) then
8995 Set_Is_Inlined (Protected_Body_Subprogram (Subp));
8996 Set_Is_Inlined (Subp, False);
8999 if Has_Pragma_No_Inline (Subp) then
9000 Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp));
9004 ---------------------------
9005 -- Static_Component_Size --
9006 ---------------------------
9008 function Static_Component_Size (Comp : Entity_Id) return Boolean is
9009 Typ : constant Entity_Id := Etype (Comp);
9013 if Is_Scalar_Type (Typ) then
9016 elsif Is_Array_Type (Typ) then
9017 return Compile_Time_Known_Bounds (Typ);
9019 elsif Is_Record_Type (Typ) then
9020 C := First_Component (Typ);
9021 while Present (C) loop
9022 if not Static_Component_Size (C) then
9031 -- Any other type will be checked by the back-end
9036 end Static_Component_Size;
9038 ------------------------------
9039 -- Expand_Entry_Declaration --
9040 ------------------------------
9042 procedure Expand_Entry_Declaration (Decl : Node_Id) is
9043 Ent_Id : constant Entity_Id := Defining_Entity (Decl);
9049 E_Count := E_Count + 1;
9051 -- Create the protected body subprogram
9054 Make_Defining_Identifier (Loc,
9055 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E'));
9056 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id);
9059 Make_Subprogram_Declaration (Loc,
9061 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id));
9063 Insert_After (Current_Node, Subp);
9064 Current_Node := Subp;
9068 -- Build a wrapper procedure to handle contract cases, preconditions,
9069 -- and postconditions.
9071 Build_Contract_Wrapper (Ent_Id, N);
9073 -- Create the barrier function
9076 Make_Defining_Identifier (Loc,
9077 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B'));
9078 Set_Barrier_Function (Ent_Id, Bar_Id);
9081 Make_Subprogram_Declaration (Loc,
9083 Build_Barrier_Function_Specification (Loc, Bar_Id));
9084 Set_Is_Entry_Barrier_Function (Subp);
9086 Insert_After (Current_Node, Subp);
9087 Current_Node := Subp;
9091 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id);
9092 Set_Scope (Bar_Id, Scope (Ent_Id));
9094 -- Collect pointers to the protected subprogram and the barrier
9095 -- of the current entry, for insertion into Entry_Bodies_Array.
9097 Append_To (Expressions (Entries_Aggr),
9098 Make_Aggregate (Loc,
9099 Expressions => New_List (
9100 Make_Attribute_Reference (Loc,
9101 Prefix => New_Occurrence_Of (Bar_Id, Loc),
9102 Attribute_Name => Name_Unrestricted_Access),
9103 Make_Attribute_Reference (Loc,
9104 Prefix => New_Occurrence_Of (Bod_Id, Loc),
9105 Attribute_Name => Name_Unrestricted_Access))));
9106 end Expand_Entry_Declaration;
9108 ----------------------
9109 -- Register_Handler --
9110 ----------------------
9112 procedure Register_Handler is
9114 -- All semantic checks already done in Sem_Prag
9116 Prot_Proc : constant Entity_Id :=
9117 Defining_Unit_Name (Specification (Current_Node));
9119 Proc_Address : constant Node_Id :=
9120 Make_Attribute_Reference (Loc,
9122 New_Occurrence_Of (Prot_Proc, Loc),
9123 Attribute_Name => Name_Address);
9125 RTS_Call : constant Entity_Id :=
9126 Make_Procedure_Call_Statement (Loc,
9129 (RTE (RE_Register_Interrupt_Handler), Loc),
9130 Parameter_Associations => New_List (Proc_Address));
9132 Append_Freeze_Action (Prot_Proc, RTS_Call);
9133 end Register_Handler;
9135 -------------------------------
9136 -- Replace_Access_Definition --
9137 -------------------------------
9139 procedure Replace_Access_Definition (Comp : Node_Id) is
9140 Loc : constant Source_Ptr := Sloc (Comp);
9148 Inc_T := Make_Defining_Identifier (Loc, Chars (Rec_Id));
9149 Inc_D := Make_Incomplete_Type_Declaration (Loc, Inc_T);
9150 Acc_T := Make_Temporary (Loc, 'S');
9152 Make_Access_To_Object_Definition (Loc,
9153 Subtype_Indication => New_Occurrence_Of (Inc_T, Loc));
9155 Make_Full_Type_Declaration (Loc,
9156 Defining_Identifier => Acc_T,
9157 Type_Definition => Acc_Def);
9159 Insert_Before (Rec_Decl, Inc_D);
9162 Insert_Before (Rec_Decl, Acc_D);
9166 Set_Access_Definition (Comp, Empty);
9167 Set_Subtype_Indication (Comp, New_Occurrence_Of (Acc_T, Loc));
9168 end Replace_Access_Definition;
9173 Body_Id : Entity_Id;
9179 Object_Comp : Node_Id;
9183 -- Start of processing for Expand_N_Protected_Type_Declaration
9186 if Present (Corresponding_Record_Type (Prot_Typ)) then
9189 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
9190 Rec_Id := Defining_Identifier (Rec_Decl);
9193 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
9195 Qualify_Entity_Names (N);
9197 -- If the type has discriminants, their occurrences in the declaration
9198 -- have been replaced by the corresponding discriminals. For components
9199 -- that are constrained by discriminants, their homologues in the
9200 -- corresponding record type must refer to the discriminants of that
9201 -- record, so we must apply a new renaming to subtypes_indications:
9203 -- protected discriminant => discriminal => record discriminant
9205 -- This replacement is not applied to default expressions, for which
9206 -- the discriminal is correct.
9208 if Has_Discriminants (Prot_Typ) then
9214 Disc := First_Discriminant (Prot_Typ);
9215 Decl := First (Discriminant_Specifications (Rec_Decl));
9216 while Present (Disc) loop
9217 Append_Elmt (Discriminal (Disc), Discr_Map);
9218 Append_Elmt (Defining_Identifier (Decl), Discr_Map);
9219 Next_Discriminant (Disc);
9225 -- Fill in the component declarations
9227 -- Add components for entry families. For each entry family, create an
9228 -- anonymous type declaration with the same size, and analyze the type.
9230 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
9232 pragma Assert (Present (Pdef));
9234 Insert_After (Current_Node, Rec_Decl);
9235 Current_Node := Rec_Decl;
9237 -- Add private field components
9239 if Present (Private_Declarations (Pdef)) then
9240 Priv := First (Private_Declarations (Pdef));
9241 while Present (Priv) loop
9242 if Nkind (Priv) = N_Component_Declaration then
9243 if not Static_Component_Size (Defining_Identifier (Priv)) then
9245 -- When compiling for a restricted profile, the private
9246 -- components must have a static size. If not, this is an
9247 -- error for a single protected declaration, and rates a
9248 -- warning on a protected type declaration.
9250 if not Comes_From_Source (Prot_Typ) then
9252 -- It's ok to be checking this restriction at expansion
9253 -- time, because this is only for the restricted profile,
9254 -- which is not subject to strict RM conformance, so it
9255 -- is OK to miss this check in -gnatc mode.
9257 Check_Restriction (No_Implicit_Heap_Allocations, Priv);
9259 (No_Implicit_Protected_Object_Allocations, Priv);
9261 elsif Restriction_Active (No_Implicit_Heap_Allocations) then
9262 if not Discriminated_Size (Defining_Identifier (Priv))
9264 -- Any object of the type will be non-static
9266 Error_Msg_N ("component has non-static size??", Priv);
9268 ("\creation of protected object of type& will "
9269 & "violate restriction "
9270 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
9272 -- Object will be non-static if discriminants are
9275 ("creation of protected object of type& with "
9276 & "non-static discriminants will violate "
9277 & "restriction No_Implicit_Heap_Allocations??",
9281 -- Likewise for No_Implicit_Protected_Object_Allocations
9283 elsif Restriction_Active
9284 (No_Implicit_Protected_Object_Allocations)
9286 if not Discriminated_Size (Defining_Identifier (Priv))
9288 -- Any object of the type will be non-static
9290 Error_Msg_N ("component has non-static size??", Priv);
9292 ("\creation of protected object of type& will "
9293 & "violate restriction "
9294 & "No_Implicit_Protected_Object_Allocations??",
9297 -- Object will be non-static if discriminants are
9300 ("creation of protected object of type& with "
9301 & "non-static discriminants will violate "
9303 & "No_Implicit_Protected_Object_Allocations??",
9309 -- The component definition consists of a subtype indication,
9310 -- or (in Ada 2005) an access definition. Make a copy of the
9311 -- proper definition.
9314 Old_Comp : constant Node_Id := Component_Definition (Priv);
9315 Oent : constant Entity_Id := Defining_Identifier (Priv);
9316 Nent : constant Entity_Id :=
9317 Make_Defining_Identifier (Sloc (Oent),
9318 Chars => Chars (Oent));
9322 if Present (Subtype_Indication (Old_Comp)) then
9324 Make_Component_Definition (Sloc (Oent),
9325 Aliased_Present => False,
9326 Subtype_Indication =>
9328 (Subtype_Indication (Old_Comp), Discr_Map));
9331 Make_Component_Definition (Sloc (Oent),
9332 Aliased_Present => False,
9333 Access_Definition =>
9335 (Access_Definition (Old_Comp), Discr_Map));
9337 -- A self-reference in the private part becomes a
9338 -- self-reference to the corresponding record.
9340 if Entity (Subtype_Mark (Access_Definition (New_Comp)))
9343 Replace_Access_Definition (New_Comp);
9348 Make_Component_Declaration (Loc,
9349 Defining_Identifier => Nent,
9350 Component_Definition => New_Comp,
9351 Expression => Expression (Priv));
9353 Set_Has_Per_Object_Constraint (Nent,
9354 Has_Per_Object_Constraint (Oent));
9356 Append_To (Cdecls, New_Priv);
9359 elsif Nkind (Priv) = N_Subprogram_Declaration then
9361 -- Make the unprotected version of the subprogram available
9362 -- for expansion of intra object calls. There is need for
9363 -- a protected version only if the subprogram is an interrupt
9364 -- handler, otherwise this operation can only be called from
9368 Make_Subprogram_Declaration (Loc,
9370 Build_Protected_Sub_Specification
9371 (Priv, Prot_Typ, Unprotected_Mode));
9373 Insert_After (Current_Node, Sub);
9376 Set_Protected_Body_Subprogram
9377 (Defining_Unit_Name (Specification (Priv)),
9378 Defining_Unit_Name (Specification (Sub)));
9379 Check_Inlining (Defining_Unit_Name (Specification (Priv)));
9380 Current_Node := Sub;
9383 Make_Subprogram_Declaration (Loc,
9385 Build_Protected_Sub_Specification
9386 (Priv, Prot_Typ, Protected_Mode));
9388 Insert_After (Current_Node, Sub);
9390 Current_Node := Sub;
9392 if Is_Interrupt_Handler
9393 (Defining_Unit_Name (Specification (Priv)))
9395 if not Restricted_Profile then
9405 -- Except for the lock-free implementation, append the _Object field
9406 -- with the right type to the component list. We need to compute the
9407 -- number of entries, and in some cases the number of Attach_Handler
9410 if not Lock_Free_Active then
9412 Entry_Count_Expr : constant Node_Id :=
9413 Build_Entry_Count_Expression
9414 (Prot_Typ, Cdecls, Loc);
9415 Num_Attach_Handler : Nat := 0;
9416 Protection_Subtype : Node_Id;
9420 if Has_Attach_Handler (Prot_Typ) then
9421 Ritem := First_Rep_Item (Prot_Typ);
9422 while Present (Ritem) loop
9423 if Nkind (Ritem) = N_Pragma
9424 and then Pragma_Name (Ritem) = Name_Attach_Handler
9426 Num_Attach_Handler := Num_Attach_Handler + 1;
9429 Next_Rep_Item (Ritem);
9433 -- Determine the proper protection type. There are two special
9434 -- cases: 1) when the protected type has dynamic interrupt
9435 -- handlers, and 2) when it has static handlers and we use a
9436 -- restricted profile.
9438 if Has_Attach_Handler (Prot_Typ)
9439 and then not Restricted_Profile
9441 Protection_Subtype :=
9442 Make_Subtype_Indication (Loc,
9445 (RTE (RE_Static_Interrupt_Protection), Loc),
9447 Make_Index_Or_Discriminant_Constraint (Loc,
9448 Constraints => New_List (
9450 Make_Integer_Literal (Loc, Num_Attach_Handler))));
9452 elsif Has_Interrupt_Handler (Prot_Typ)
9453 and then not Restriction_Active (No_Dynamic_Attachment)
9455 Protection_Subtype :=
9456 Make_Subtype_Indication (Loc,
9459 (RTE (RE_Dynamic_Interrupt_Protection), Loc),
9461 Make_Index_Or_Discriminant_Constraint (Loc,
9462 Constraints => New_List (Entry_Count_Expr)));
9465 case Corresponding_Runtime_Package (Prot_Typ) is
9466 when System_Tasking_Protected_Objects_Entries =>
9467 Protection_Subtype :=
9468 Make_Subtype_Indication (Loc,
9471 (RTE (RE_Protection_Entries), Loc),
9473 Make_Index_Or_Discriminant_Constraint (Loc,
9474 Constraints => New_List (Entry_Count_Expr)));
9476 when System_Tasking_Protected_Objects_Single_Entry =>
9477 Protection_Subtype :=
9478 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc);
9480 when System_Tasking_Protected_Objects =>
9481 Protection_Subtype :=
9482 New_Occurrence_Of (RTE (RE_Protection), Loc);
9485 raise Program_Error;
9490 Make_Component_Declaration (Loc,
9491 Defining_Identifier =>
9492 Make_Defining_Identifier (Loc, Name_uObject),
9493 Component_Definition =>
9494 Make_Component_Definition (Loc,
9495 Aliased_Present => True,
9496 Subtype_Indication => Protection_Subtype));
9499 -- Put the _Object component after the private component so that it
9500 -- be finalized early as required by 9.4 (20)
9502 Append_To (Cdecls, Object_Comp);
9505 -- Analyze the record declaration immediately after construction,
9506 -- because the initialization procedure is needed for single object
9507 -- declarations before the next entity is analyzed (the freeze call
9508 -- that generates this initialization procedure is found below).
9510 Analyze (Rec_Decl, Suppress => All_Checks);
9512 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9513 -- the corresponding record is frozen. If any wrappers are generated,
9514 -- Current_Node is updated accordingly.
9516 if Ada_Version >= Ada_2005 then
9517 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
9520 -- Collect pointers to entry bodies and their barriers, to be placed
9521 -- in the Entry_Bodies_Array for the type. For each entry/family we
9522 -- add an expression to the aggregate which is the initial value of
9523 -- this array. The array is declared after all protected subprograms.
9525 if Has_Entries (Prot_Typ) then
9526 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
9528 Entries_Aggr := Empty;
9531 -- Build two new procedure specifications for each protected subprogram;
9532 -- one to call from outside the object and one to call from inside.
9533 -- Build a barrier function and an entry body action procedure
9534 -- specification for each protected entry. Initialize the entry body
9535 -- array. If subprogram is flagged as eliminated, do not generate any
9536 -- internal operations.
9539 Comp := First (Visible_Declarations (Pdef));
9540 while Present (Comp) loop
9541 if Nkind (Comp) = N_Subprogram_Declaration then
9543 Make_Subprogram_Declaration (Loc,
9545 Build_Protected_Sub_Specification
9546 (Comp, Prot_Typ, Unprotected_Mode));
9548 Insert_After (Current_Node, Sub);
9551 Set_Protected_Body_Subprogram
9552 (Defining_Unit_Name (Specification (Comp)),
9553 Defining_Unit_Name (Specification (Sub)));
9554 Check_Inlining (Defining_Unit_Name (Specification (Comp)));
9556 -- Make the protected version of the subprogram available for
9557 -- expansion of external calls.
9559 Current_Node := Sub;
9562 Make_Subprogram_Declaration (Loc,
9564 Build_Protected_Sub_Specification
9565 (Comp, Prot_Typ, Protected_Mode));
9567 Insert_After (Current_Node, Sub);
9570 Current_Node := Sub;
9572 -- Generate an overriding primitive operation specification for
9573 -- this subprogram if the protected type implements an interface
9574 -- and Build_Wrapper_Spec did not generate its wrapper.
9576 if Ada_Version >= Ada_2005
9578 Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
9581 Found : Boolean := False;
9582 Prim_Elmt : Elmt_Id;
9588 (Primitive_Operations
9589 (Corresponding_Record_Type (Prot_Typ)));
9591 while Present (Prim_Elmt) loop
9592 Prim_Op := Node (Prim_Elmt);
9594 if Is_Primitive_Wrapper (Prim_Op)
9595 and then Wrapped_Entity (Prim_Op) =
9596 Defining_Entity (Specification (Comp))
9602 Next_Elmt (Prim_Elmt);
9607 Make_Subprogram_Declaration (Loc,
9609 Build_Protected_Sub_Specification
9610 (Comp, Prot_Typ, Dispatching_Mode));
9612 Insert_After (Current_Node, Sub);
9615 Current_Node := Sub;
9620 -- If a pragma Interrupt_Handler applies, build and add a call to
9621 -- Register_Interrupt_Handler to the freezing actions of the
9622 -- protected version (Current_Node) of the subprogram:
9624 -- system.interrupts.register_interrupt_handler
9625 -- (prot_procP'address);
9627 if not Restricted_Profile
9628 and then Is_Interrupt_Handler
9629 (Defining_Unit_Name (Specification (Comp)))
9634 elsif Nkind (Comp) = N_Entry_Declaration then
9635 Expand_Entry_Declaration (Comp);
9641 -- If there are some private entry declarations, expand it as if they
9642 -- were visible entries.
9644 if Present (Private_Declarations (Pdef)) then
9645 Comp := First (Private_Declarations (Pdef));
9646 while Present (Comp) loop
9647 if Nkind (Comp) = N_Entry_Declaration then
9648 Expand_Entry_Declaration (Comp);
9655 -- Create the declaration of an array object which contains the values
9656 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9657 -- type. This object is later passed to the appropriate protected object
9658 -- initialization routine.
9660 if Has_Entries (Prot_Typ)
9661 and then Corresponding_Runtime_Package (Prot_Typ) =
9662 System_Tasking_Protected_Objects_Entries
9669 Maxes_Id : Entity_Id;
9670 Need_Array : Boolean := False;
9673 -- First check if there is any Max_Queue_Length pragma
9675 Item := First_Entity (Prot_Typ);
9676 while Present (Item) loop
9677 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then
9685 -- Gather the Max_Queue_Length values of all entries in a list. A
9686 -- value of zero indicates that the entry has no limitation on its
9691 Item := First_Entity (Prot_Typ);
9693 while Present (Item) loop
9694 if Is_Entry (Item) then
9697 Make_Integer_Literal
9698 (Loc, Get_Max_Queue_Length (Item)));
9704 -- Create the declaration of the array object. Generate:
9706 -- Maxes_Id : aliased constant
9707 -- Protected_Entry_Queue_Max_Array
9708 -- (1 .. Count) := (..., ...);
9711 Make_Defining_Identifier (Loc,
9712 Chars => New_External_Name (Chars (Prot_Typ), 'B'));
9715 Make_Object_Declaration (Loc,
9716 Defining_Identifier => Maxes_Id,
9717 Aliased_Present => True,
9718 Constant_Present => True,
9719 Object_Definition =>
9720 Make_Subtype_Indication (Loc,
9723 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
9725 Make_Index_Or_Discriminant_Constraint (Loc,
9726 Constraints => New_List (
9728 Make_Integer_Literal (Loc, 1),
9729 Make_Integer_Literal (Loc, Count))))),
9730 Expression => Make_Aggregate (Loc, Maxes));
9732 -- A pointer to this array will be placed in the corresponding
9733 -- record by its initialization procedure so this needs to be
9736 Insert_After (Current_Node, Max_Vals);
9737 Current_Node := Max_Vals;
9740 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id);
9745 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9746 -- all protected subprograms have been collected.
9748 if Has_Entries (Prot_Typ) then
9750 Make_Defining_Identifier (Sloc (Prot_Typ),
9751 Chars => New_External_Name (Chars (Prot_Typ), 'A'));
9753 case Corresponding_Runtime_Package (Prot_Typ) is
9754 when System_Tasking_Protected_Objects_Entries =>
9755 Expr := Entries_Aggr;
9757 Make_Subtype_Indication (Loc,
9760 (RTE (RE_Protected_Entry_Body_Array), Loc),
9762 Make_Index_Or_Discriminant_Constraint (Loc,
9763 Constraints => New_List (
9765 Make_Integer_Literal (Loc, 1),
9766 Make_Integer_Literal (Loc, E_Count)))));
9768 when System_Tasking_Protected_Objects_Single_Entry =>
9769 Expr := Remove_Head (Expressions (Entries_Aggr));
9770 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc);
9773 raise Program_Error;
9777 Make_Object_Declaration (Loc,
9778 Defining_Identifier => Body_Id,
9779 Aliased_Present => True,
9780 Constant_Present => True,
9781 Object_Definition => Obj_Def,
9782 Expression => Expr);
9784 -- A pointer to this array will be placed in the corresponding record
9785 -- by its initialization procedure so this needs to be analyzed here.
9787 Insert_After (Current_Node, Body_Arr);
9788 Current_Node := Body_Arr;
9791 Set_Entry_Bodies_Array (Prot_Typ, Body_Id);
9793 -- Finally, build the function that maps an entry index into the
9794 -- corresponding body. A pointer to this function is placed in each
9795 -- object of the type. Except for a ravenscar-like profile (no abort,
9796 -- no entry queue, 1 entry)
9798 if Corresponding_Runtime_Package (Prot_Typ) =
9799 System_Tasking_Protected_Objects_Entries
9802 Make_Subprogram_Declaration (Loc,
9803 Specification => Build_Find_Body_Index_Spec (Prot_Typ));
9805 Insert_After (Current_Node, Sub);
9809 end Expand_N_Protected_Type_Declaration;
9811 --------------------------------
9812 -- Expand_N_Requeue_Statement --
9813 --------------------------------
9815 -- A nondispatching requeue statement is expanded into one of four GNARLI
9816 -- operations, depending on the source and destination (task or protected
9817 -- object). A dispatching requeue statement is expanded into a call to the
9818 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9819 -- jump around the remainder of processing for the original entry and, if
9820 -- the destination is (different) protected object, to attempt to service
9821 -- it. The following illustrates the various cases:
9824 -- (O : System.Address;
9825 -- P : System.Address;
9826 -- E : Protected_Entry_Index)
9828 -- <discriminant renamings>
9829 -- <private object renamings>
9830 -- type poVP is access poV;
9831 -- _object : ptVP := ptVP!(O);
9835 -- <start of statement sequence for entry>
9837 -- -- Requeue from one protected entry body to another protected
9840 -- Requeue_Protected_Entry (
9841 -- _object._object'Access,
9842 -- new._object'Access,
9847 -- <some more of the statement sequence for entry>
9849 -- -- Requeue from an entry body to a task entry
9851 -- Requeue_Protected_To_Task_Entry (
9857 -- <rest of statement sequence for entry>
9858 -- Complete_Entry_Body (_object._object);
9861 -- when all others =>
9862 -- Exceptional_Complete_Entry_Body (
9863 -- _object._object, Get_GNAT_Exception);
9867 -- Requeue of a task entry call to a task entry
9869 -- Accept_Call (E, Ann);
9870 -- <start of statement sequence for accept statement>
9871 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9873 -- <rest of statement sequence for accept statement>
9875 -- Complete_Rendezvous;
9878 -- when all others =>
9879 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9881 -- Requeue of a task entry call to a protected entry
9883 -- Accept_Call (E, Ann);
9884 -- <start of statement sequence for accept statement>
9885 -- Requeue_Task_To_Protected_Entry (
9886 -- new._object'Access,
9891 -- <rest of statement sequence for accept statement>
9893 -- Complete_Rendezvous;
9896 -- when all others =>
9897 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9899 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9900 -- marked by pragma Implemented (XXX, By_Entry).
9902 -- The requeue is inside a protected entry:
9905 -- (O : System.Address;
9906 -- P : System.Address;
9907 -- E : Protected_Entry_Index)
9909 -- <discriminant renamings>
9910 -- <private object renamings>
9911 -- type poVP is access poV;
9912 -- _object : ptVP := ptVP!(O);
9916 -- <start of statement sequence for entry>
9919 -- (<interface class-wide object>,
9922 -- Ada.Tags.Get_Offset_Index
9924 -- <interface dispatch table index of target entry>),
9928 -- <rest of statement sequence for entry>
9929 -- Complete_Entry_Body (_object._object);
9932 -- when all others =>
9933 -- Exceptional_Complete_Entry_Body (
9934 -- _object._object, Get_GNAT_Exception);
9938 -- The requeue is inside a task entry:
9940 -- Accept_Call (E, Ann);
9941 -- <start of statement sequence for accept statement>
9943 -- (<interface class-wide object>,
9946 -- Ada.Tags.Get_Offset_Index
9948 -- <interface dispatch table index of target entrt>),
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_Protected_Procedure). The requeue
9962 -- statement is replaced by a dispatching call with actual parameters taken
9963 -- from the inner-most accept statement or entry body.
9965 -- Target.Primitive (Param1, ..., ParamN);
9967 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9968 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9972 -- S : constant Offset_Index :=
9973 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9974 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9977 -- if C = POK_Protected_Entry
9978 -- or else C = POK_Task_Entry
9980 -- <statements for dispatching requeue>
9982 -- elsif C = POK_Protected_Procedure then
9983 -- <dispatching call equivalent>
9986 -- raise Program_Error;
9990 procedure Expand_N_Requeue_Statement (N : Node_Id) is
9991 Loc : constant Source_Ptr := Sloc (N);
9992 Conc_Typ : Entity_Id;
9996 Old_Typ : Entity_Id;
9998 function Build_Dispatching_Call_Equivalent return Node_Id;
9999 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10000 -- the form Concval.Ename. It is statically known that Ename is allowed
10001 -- to be implemented by a protected procedure. Create a dispatching call
10002 -- equivalent of Concval.Ename taking the actual parameters from the
10003 -- inner-most accept statement or entry body.
10005 function Build_Dispatching_Requeue return Node_Id;
10006 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10007 -- the form Concval.Ename. It is statically known that Ename is allowed
10008 -- to be implemented by a protected or a task entry. Create a call to
10009 -- primitive _Disp_Requeue which handles the low-level actions.
10011 function Build_Dispatching_Requeue_To_Any return Node_Id;
10012 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10013 -- the form Concval.Ename. Ename is either marked by pragma Implemented
10014 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
10015 -- determines at runtime whether Ename denotes an entry or a procedure
10016 -- and perform the appropriate kind of dispatching select.
10018 function Build_Normal_Requeue return Node_Id;
10019 -- N denotes a nondispatching requeue statement to either a task or a
10020 -- protected entry. Build the appropriate runtime call to perform the
10023 function Build_Skip_Statement (Search : Node_Id) return Node_Id;
10024 -- For a protected entry, create a return statement to skip the rest of
10025 -- the entry body. Otherwise, create a goto statement to skip the rest
10026 -- of a task accept statement. The lookup for the enclosing entry body
10027 -- or accept statement starts from Search.
10029 ---------------------------------------
10030 -- Build_Dispatching_Call_Equivalent --
10031 ---------------------------------------
10033 function Build_Dispatching_Call_Equivalent return Node_Id is
10034 Call_Ent : constant Entity_Id := Entity (Ename);
10035 Obj : constant Node_Id := Original_Node (Concval);
10042 -- Climb the parent chain looking for the inner-most entry body or
10043 -- accept statement.
10046 while Present (Acc_Ent)
10047 and then not Nkind_In (Acc_Ent, N_Accept_Statement,
10050 Acc_Ent := Parent (Acc_Ent);
10053 -- A requeue statement should be housed inside an entry body or an
10054 -- accept statement at some level. If this is not the case, then the
10055 -- tree is malformed.
10057 pragma Assert (Present (Acc_Ent));
10059 -- Recover the list of formal parameters
10061 if Nkind (Acc_Ent) = N_Entry_Body then
10062 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
10065 Formals := Parameter_Specifications (Acc_Ent);
10067 -- Create the actual parameters for the dispatching call. These are
10068 -- simply copies of the entry body or accept statement formals in the
10069 -- same order as they appear.
10071 Actuals := No_List;
10073 if Present (Formals) then
10074 Actuals := New_List;
10075 Formal := First (Formals);
10076 while Present (Formal) loop
10077 Append_To (Actuals,
10078 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
10084 -- Obj.Call_Ent (Actuals);
10087 Make_Procedure_Call_Statement (Loc,
10089 Make_Selected_Component (Loc,
10090 Prefix => Make_Identifier (Loc, Chars (Obj)),
10091 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))),
10093 Parameter_Associations => Actuals);
10094 end Build_Dispatching_Call_Equivalent;
10096 -------------------------------
10097 -- Build_Dispatching_Requeue --
10098 -------------------------------
10100 function Build_Dispatching_Requeue return Node_Id is
10101 Params : constant List_Id := New_List;
10104 -- Process the "with abort" parameter
10106 Prepend_To (Params,
10107 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10109 -- Process the entry wrapper's position in the primary dispatch
10110 -- table parameter. Generate:
10112 -- Ada.Tags.Get_Entry_Index
10113 -- (T => To_Tag_Ptr (Obj'Address).all,
10115 -- Ada.Tags.Get_Offset_Index
10116 -- (Ada.Tags.Tag (Concval),
10117 -- <interface dispatch table position of Ename>));
10119 -- Note that Obj'Address is recursively expanded into a call to
10120 -- Base_Address (Obj).
10122 if Tagged_Type_Expansion then
10123 Prepend_To (Params,
10124 Make_Function_Call (Loc,
10125 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10126 Parameter_Associations => New_List (
10128 Make_Explicit_Dereference (Loc,
10129 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
10130 Make_Attribute_Reference (Loc,
10131 Prefix => New_Copy_Tree (Concval),
10132 Attribute_Name => Name_Address))),
10134 Make_Function_Call (Loc,
10135 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10136 Parameter_Associations => New_List (
10137 Unchecked_Convert_To (RTE (RE_Tag), Concval),
10138 Make_Integer_Literal (Loc,
10139 DT_Position (Entity (Ename))))))));
10144 Prepend_To (Params,
10145 Make_Function_Call (Loc,
10146 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10147 Parameter_Associations => New_List (
10149 Make_Attribute_Reference (Loc,
10151 Attribute_Name => Name_Tag),
10153 Make_Function_Call (Loc,
10154 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10156 Parameter_Associations => New_List (
10160 Make_Attribute_Reference (Loc,
10162 Attribute_Name => Name_Tag),
10166 Make_Attribute_Reference (Loc,
10167 Prefix => New_Occurrence_Of (Etype (Concval), Loc),
10168 Attribute_Name => Name_Tag),
10172 Make_Integer_Literal (Loc,
10173 DT_Position (Entity (Ename))))))));
10176 -- Specific actuals for protected to XXX requeue
10178 if Is_Protected_Type (Old_Typ) then
10179 Prepend_To (Params,
10180 Make_Attribute_Reference (Loc, -- _object'Address
10182 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10183 Attribute_Name => Name_Address));
10185 Prepend_To (Params, -- True
10186 New_Occurrence_Of (Standard_True, Loc));
10188 -- Specific actuals for task to XXX requeue
10191 pragma Assert (Is_Task_Type (Old_Typ));
10193 Prepend_To (Params, -- null
10194 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
10196 Prepend_To (Params, -- False
10197 New_Occurrence_Of (Standard_False, Loc));
10200 -- Add the object parameter
10202 Prepend_To (Params, New_Copy_Tree (Concval));
10205 -- _Disp_Requeue (<Params>);
10207 -- Find entity for Disp_Requeue operation, which belongs to
10208 -- the type and may not be directly visible.
10213 pragma Warnings (Off, Op);
10216 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
10217 while Present (Elmt) loop
10219 exit when Chars (Op) = Name_uDisp_Requeue;
10224 Make_Procedure_Call_Statement (Loc,
10225 Name => New_Occurrence_Of (Op, Loc),
10226 Parameter_Associations => Params);
10228 end Build_Dispatching_Requeue;
10230 --------------------------------------
10231 -- Build_Dispatching_Requeue_To_Any --
10232 --------------------------------------
10234 function Build_Dispatching_Requeue_To_Any return Node_Id is
10235 Call_Ent : constant Entity_Id := Entity (Ename);
10236 Obj : constant Node_Id := Original_Node (Concval);
10237 Skip : constant Node_Id := Build_Skip_Statement (N);
10247 -- Dispatch table slot processing, generate:
10250 S := Build_S (Loc, Decls);
10252 -- Call kind processing, generate:
10253 -- C : Ada.Tags.Prim_Op_Kind;
10255 C := Build_C (Loc, Decls);
10258 -- S := Ada.Tags.Get_Offset_Index
10259 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10261 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
10264 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10267 Make_Procedure_Call_Statement (Loc,
10269 New_Occurrence_Of (
10270 Find_Prim_Op (Etype (Etype (Obj)),
10271 Name_uDisp_Get_Prim_Op_Kind),
10273 Parameter_Associations => New_List (
10274 New_Copy_Tree (Obj),
10275 New_Occurrence_Of (S, Loc),
10276 New_Occurrence_Of (C, Loc))));
10280 -- if C = POK_Protected_Entry
10281 -- or else C = POK_Task_Entry
10284 Make_Implicit_If_Statement (N,
10290 New_Occurrence_Of (C, Loc),
10292 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
10297 New_Occurrence_Of (C, Loc),
10299 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
10301 -- Dispatching requeue equivalent
10303 Then_Statements => New_List (
10304 Build_Dispatching_Requeue,
10307 -- elsif C = POK_Protected_Procedure then
10309 Elsif_Parts => New_List (
10310 Make_Elsif_Part (Loc,
10314 New_Occurrence_Of (C, Loc),
10316 New_Occurrence_Of (
10317 RTE (RE_POK_Protected_Procedure), Loc)),
10319 -- Dispatching call equivalent
10321 Then_Statements => New_List (
10322 Build_Dispatching_Call_Equivalent))),
10325 -- raise Program_Error;
10328 Else_Statements => New_List (
10329 Make_Raise_Program_Error (Loc,
10330 Reason => PE_Explicit_Raise))));
10332 -- Wrap everything into a block
10335 Make_Block_Statement (Loc,
10336 Declarations => Decls,
10337 Handled_Statement_Sequence =>
10338 Make_Handled_Sequence_Of_Statements (Loc,
10339 Statements => Stmts));
10340 end Build_Dispatching_Requeue_To_Any;
10342 --------------------------
10343 -- Build_Normal_Requeue --
10344 --------------------------
10346 function Build_Normal_Requeue return Node_Id is
10347 Params : constant List_Id := New_List;
10352 -- Process the "with abort" parameter
10354 Prepend_To (Params,
10355 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10357 -- Add the index expression to the parameters. It is common among all
10360 Prepend_To (Params,
10361 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
10363 if Is_Protected_Type (Old_Typ) then
10365 Self_Param : Node_Id;
10369 Make_Attribute_Reference (Loc,
10371 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10373 Name_Unchecked_Access);
10375 -- Protected to protected requeue
10377 if Is_Protected_Type (Conc_Typ) then
10379 New_Occurrence_Of (
10380 RTE (RE_Requeue_Protected_Entry), Loc);
10383 Make_Attribute_Reference (Loc,
10385 Concurrent_Ref (Concval),
10387 Name_Unchecked_Access);
10389 -- Protected to task requeue
10391 else pragma Assert (Is_Task_Type (Conc_Typ));
10393 New_Occurrence_Of (
10394 RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
10396 Param := Concurrent_Ref (Concval);
10399 Prepend_To (Params, Param);
10400 Prepend_To (Params, Self_Param);
10403 else pragma Assert (Is_Task_Type (Old_Typ));
10405 -- Task to protected requeue
10407 if Is_Protected_Type (Conc_Typ) then
10409 New_Occurrence_Of (
10410 RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
10413 Make_Attribute_Reference (Loc,
10415 Concurrent_Ref (Concval),
10417 Name_Unchecked_Access);
10419 -- Task to task requeue
10421 else pragma Assert (Is_Task_Type (Conc_Typ));
10423 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc);
10425 Param := Concurrent_Ref (Concval);
10428 Prepend_To (Params, Param);
10432 Make_Procedure_Call_Statement (Loc,
10434 Parameter_Associations => Params);
10435 end Build_Normal_Requeue;
10437 --------------------------
10438 -- Build_Skip_Statement --
10439 --------------------------
10441 function Build_Skip_Statement (Search : Node_Id) return Node_Id is
10442 Skip_Stmt : Node_Id;
10445 -- Build a return statement to skip the rest of the entire body
10447 if Is_Protected_Type (Old_Typ) then
10448 Skip_Stmt := Make_Simple_Return_Statement (Loc);
10450 -- If the requeue is within a task, find the end label of the
10451 -- enclosing accept statement and create a goto statement to it.
10459 -- Climb the parent chain looking for the enclosing accept
10462 Acc := Parent (Search);
10463 while Present (Acc)
10464 and then Nkind (Acc) /= N_Accept_Statement
10466 Acc := Parent (Acc);
10469 -- The last statement is the second label used for completing
10470 -- the rendezvous the usual way. The label we are looking for
10471 -- is right before it.
10474 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
10476 pragma Assert (Nkind (Label) = N_Label);
10478 -- Generate a goto statement to skip the rest of the accept
10481 Make_Goto_Statement (Loc,
10483 New_Occurrence_Of (Entity (Identifier (Label)), Loc));
10487 Set_Analyzed (Skip_Stmt);
10490 end Build_Skip_Statement;
10492 -- Start of processing for Expand_N_Requeue_Statement
10495 -- Extract the components of the entry call
10497 Extract_Entry (N, Concval, Ename, Index);
10498 Conc_Typ := Etype (Concval);
10500 -- If the prefix is an access to class-wide type, dereference to get
10501 -- object and entry type.
10503 if Is_Access_Type (Conc_Typ) then
10504 Conc_Typ := Designated_Type (Conc_Typ);
10506 Make_Explicit_Dereference (Loc, Relocate_Node (Concval)));
10507 Analyze_And_Resolve (Concval, Conc_Typ);
10510 -- Examine the scope stack in order to find nearest enclosing protected
10511 -- or task type. This will constitute our invocation source.
10513 Old_Typ := Current_Scope;
10514 while Present (Old_Typ)
10515 and then not Is_Protected_Type (Old_Typ)
10516 and then not Is_Task_Type (Old_Typ)
10518 Old_Typ := Scope (Old_Typ);
10521 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10522 -- Concval.Ename where the type of Concval is class-wide concurrent
10525 if Ada_Version >= Ada_2012
10526 and then Present (Concval)
10527 and then Is_Class_Wide_Type (Conc_Typ)
10528 and then Is_Concurrent_Interface (Conc_Typ)
10531 Has_Impl : Boolean := False;
10532 Impl_Kind : Name_Id := No_Name;
10535 -- Check whether the Ename is flagged by pragma Implemented
10537 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
10539 Impl_Kind := Implementation_Kind (Entity (Ename));
10542 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10543 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10545 if Has_Impl and then Impl_Kind = Name_By_Entry then
10546 Rewrite (N, Build_Dispatching_Requeue);
10548 Insert_After (N, Build_Skip_Statement (N));
10550 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10551 -- a protected procedure. In this case the requeue is transformed
10552 -- into a dispatching call.
10555 and then Impl_Kind = Name_By_Protected_Procedure
10557 Rewrite (N, Build_Dispatching_Call_Equivalent);
10560 -- The procedure_or_entry_NAME's implementation kind is either
10561 -- By_Any, Optional, or pragma Implemented was not applied at all.
10562 -- In this case a runtime test determines whether Ename denotes an
10563 -- entry or a protected procedure and performs the appropriate
10567 Rewrite (N, Build_Dispatching_Requeue_To_Any);
10572 -- Processing for regular (nondispatching) requeues
10575 Rewrite (N, Build_Normal_Requeue);
10577 Insert_After (N, Build_Skip_Statement (N));
10579 end Expand_N_Requeue_Statement;
10581 -------------------------------
10582 -- Expand_N_Selective_Accept --
10583 -------------------------------
10585 procedure Expand_N_Selective_Accept (N : Node_Id) is
10586 Loc : constant Source_Ptr := Sloc (N);
10587 Alts : constant List_Id := Select_Alternatives (N);
10589 -- Note: in the below declarations a lot of new lists are allocated
10590 -- unconditionally which may well not end up being used. That's not
10591 -- a good idea since it wastes space gratuitously ???
10593 Accept_Case : List_Id;
10594 Accept_List : constant List_Id := New_List;
10597 Alt_List : constant List_Id := New_List;
10598 Alt_Stats : List_Id;
10599 Ann : Entity_Id := Empty;
10601 Check_Guard : Boolean := True;
10603 Decls : constant List_Id := New_List;
10604 Stats : constant List_Id := New_List;
10605 Body_List : constant List_Id := New_List;
10606 Trailing_List : constant List_Id := New_List;
10609 Else_Present : Boolean := False;
10610 Terminate_Alt : Node_Id := Empty;
10611 Select_Mode : Node_Id;
10613 Delay_Case : List_Id;
10614 Delay_Count : Integer := 0;
10615 Delay_Val : Entity_Id;
10616 Delay_Index : Entity_Id;
10617 Delay_Min : Entity_Id;
10618 Delay_Num : Pos := 1;
10619 Delay_Alt_List : List_Id := New_List;
10620 Delay_List : constant List_Id := New_List;
10624 First_Delay : Boolean := True;
10625 Guard_Open : Entity_Id;
10631 Num_Accept : Nat := 0;
10633 Time_Type : Entity_Id;
10634 Select_Call : Node_Id;
10636 Qnam : constant Entity_Id :=
10637 Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
10639 Xnam : constant Entity_Id :=
10640 Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
10642 -----------------------
10643 -- Local subprograms --
10644 -----------------------
10646 function Accept_Or_Raise return List_Id;
10647 -- For the rare case where delay alternatives all have guards, and
10648 -- all of them are closed, it is still possible that there were open
10649 -- accept alternatives with no callers. We must reexamine the
10650 -- Accept_List, and execute a selective wait with no else if some
10651 -- accept is open. If none, we raise program_error.
10653 procedure Add_Accept (Alt : Node_Id);
10654 -- Process a single accept statement in a select alternative. Build
10655 -- procedure for body of accept, and add entry to dispatch table with
10656 -- expression for guard, in preparation for call to run time select.
10658 function Make_And_Declare_Label (Num : Int) return Node_Id;
10659 -- Manufacture a label using Num as a serial number and declare it.
10660 -- The declaration is appended to Decls. The label marks the trailing
10661 -- statements of an accept or delay alternative.
10663 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
10664 -- Build call to Selective_Wait runtime routine
10666 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
10667 -- Add code to compare value of delay with previous values, and
10668 -- generate case entry for trailing statements.
10670 procedure Process_Accept_Alternative
10674 -- Add code to call corresponding procedure, and branch to
10675 -- trailing statements, if any.
10677 ---------------------
10678 -- Accept_Or_Raise --
10679 ---------------------
10681 function Accept_Or_Raise return List_Id is
10684 J : constant Entity_Id := Make_Temporary (Loc, 'J');
10687 -- We generate the following:
10689 -- for J in q'range loop
10690 -- if q(J).S /=null_task_entry then
10691 -- selective_wait (simple_mode,...);
10697 -- if no rendez_vous then
10698 -- raise program_error;
10701 -- Note that the code needs to know that the selector name
10702 -- in an Accept_Alternative is named S.
10704 Cond := Make_Op_Ne (Loc,
10706 Make_Selected_Component (Loc,
10708 Make_Indexed_Component (Loc,
10709 Prefix => New_Occurrence_Of (Qnam, Loc),
10710 Expressions => New_List (New_Occurrence_Of (J, Loc))),
10711 Selector_Name => Make_Identifier (Loc, Name_S)),
10713 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc));
10715 Stats := New_List (
10716 Make_Implicit_Loop_Statement (N,
10717 Iteration_Scheme =>
10718 Make_Iteration_Scheme (Loc,
10719 Loop_Parameter_Specification =>
10720 Make_Loop_Parameter_Specification (Loc,
10721 Defining_Identifier => J,
10722 Discrete_Subtype_Definition =>
10723 Make_Attribute_Reference (Loc,
10724 Prefix => New_Occurrence_Of (Qnam, Loc),
10725 Attribute_Name => Name_Range,
10726 Expressions => New_List (
10727 Make_Integer_Literal (Loc, 1))))),
10729 Statements => New_List (
10730 Make_Implicit_If_Statement (N,
10732 Then_Statements => New_List (
10734 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)),
10735 Make_Exit_Statement (Loc))))));
10738 Make_Raise_Program_Error (Loc,
10739 Condition => Make_Op_Eq (Loc,
10740 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
10742 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
10743 Reason => PE_All_Guards_Closed));
10746 end Accept_Or_Raise;
10752 procedure Add_Accept (Alt : Node_Id) is
10753 Acc_Stm : constant Node_Id := Accept_Statement (Alt);
10754 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm);
10755 Eloc : constant Source_Ptr := Sloc (Ename);
10756 Eent : constant Entity_Id := Entity (Ename);
10757 Index : constant Node_Id := Entry_Index (Acc_Stm);
10761 Null_Body : Node_Id;
10762 PB_Ent : Entity_Id;
10763 Proc_Body : Node_Id;
10765 -- Start of processing for Add_Accept
10769 Ann := Node (Last_Elmt (Accept_Address (Eent)));
10772 if Present (Condition (Alt)) then
10774 Make_If_Expression (Eloc, New_List (
10776 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
10777 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc)));
10779 Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent));
10782 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
10783 Null_Body := New_Occurrence_Of (Standard_False, Eloc);
10785 -- Always add call to Abort_Undefer when generating code, since
10786 -- this is what the runtime expects (abort deferred in
10787 -- Selective_Wait). In CodePeer mode this only confuses the
10788 -- analysis with unknown calls, so don't do it.
10790 if not CodePeer_Mode then
10791 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
10793 (First (Statements (Handled_Statement_Sequence
10794 (Accept_Statement (Alt)))),
10800 Make_Defining_Identifier (Eloc,
10801 New_External_Name (Chars (Ename), 'A', Num_Accept));
10803 -- Link the acceptor to the original receiving entry
10805 Set_Ekind (PB_Ent, E_Procedure);
10806 Set_Receiving_Entry (PB_Ent, Eent);
10808 if Comes_From_Source (Alt) then
10809 Set_Debug_Info_Needed (PB_Ent);
10813 Make_Subprogram_Body (Eloc,
10815 Make_Procedure_Specification (Eloc,
10816 Defining_Unit_Name => PB_Ent),
10817 Declarations => Declarations (Acc_Stm),
10818 Handled_Statement_Sequence =>
10819 Build_Accept_Body (Accept_Statement (Alt)));
10821 Reset_Scopes_To (Proc_Body, PB_Ent);
10823 -- During the analysis of the body of the accept statement, any
10824 -- zero cost exception handler records were collected in the
10825 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10826 -- This is where we move them to where they belong, namely the
10827 -- newly created procedure.
10829 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
10830 Append (Proc_Body, Body_List);
10833 Null_Body := New_Occurrence_Of (Standard_True, Eloc);
10835 -- if accept statement has declarations, insert above, given that
10836 -- we are not creating a body for the accept.
10838 if Present (Declarations (Acc_Stm)) then
10839 Insert_Actions (N, Declarations (Acc_Stm));
10843 Append_To (Accept_List,
10844 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr)));
10846 Num_Accept := Num_Accept + 1;
10849 ----------------------------
10850 -- Make_And_Declare_Label --
10851 ----------------------------
10853 function Make_And_Declare_Label (Num : Int) return Node_Id is
10857 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
10859 Make_Label (Loc, Lab_Id);
10862 Make_Implicit_Label_Declaration (Loc,
10863 Defining_Identifier =>
10864 Make_Defining_Identifier (Loc, Chars (Lab_Id)),
10865 Label_Construct => Lab));
10868 end Make_And_Declare_Label;
10870 ----------------------
10871 -- Make_Select_Call --
10872 ----------------------
10874 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
10875 Params : constant List_Id := New_List;
10879 Make_Attribute_Reference (Loc,
10880 Prefix => New_Occurrence_Of (Qnam, Loc),
10881 Attribute_Name => Name_Unchecked_Access));
10882 Append_To (Params, Select_Mode);
10883 Append_To (Params, New_Occurrence_Of (Ann, Loc));
10884 Append_To (Params, New_Occurrence_Of (Xnam, Loc));
10887 Make_Procedure_Call_Statement (Loc,
10888 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc),
10889 Parameter_Associations => Params);
10890 end Make_Select_Call;
10892 --------------------------------
10893 -- Process_Accept_Alternative --
10894 --------------------------------
10896 procedure Process_Accept_Alternative
10901 Astmt : constant Node_Id := Accept_Statement (Alt);
10902 Alt_Stats : List_Id;
10905 Adjust_Condition (Condition (Alt));
10907 -- Accept with body
10909 if Present (Handled_Statement_Sequence (Astmt)) then
10912 Make_Procedure_Call_Statement (Sloc (Proc),
10915 (Defining_Unit_Name (Specification (Proc)),
10918 -- Accept with no body (followed by trailing statements)
10921 Alt_Stats := Empty_List;
10924 Ensure_Statement_Present (Sloc (Astmt), Alt);
10926 -- After the call, if any, branch to trailing statements, if any.
10927 -- We create a label for each, as well as the corresponding label
10930 if not Is_Empty_List (Statements (Alt)) then
10931 Lab := Make_And_Declare_Label (Index);
10932 Append (Lab, Trailing_List);
10933 Append_List (Statements (Alt), Trailing_List);
10934 Append_To (Trailing_List,
10935 Make_Goto_Statement (Loc,
10936 Name => New_Copy (Identifier (End_Lab))));
10942 Append_To (Alt_Stats,
10943 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab))));
10945 Append_To (Alt_List,
10946 Make_Case_Statement_Alternative (Loc,
10947 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)),
10948 Statements => Alt_Stats));
10949 end Process_Accept_Alternative;
10951 -------------------------------
10952 -- Process_Delay_Alternative --
10953 -------------------------------
10955 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
10956 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt));
10958 Delay_Alt : List_Id;
10961 -- Deal with C/Fortran boolean as delay condition
10963 Adjust_Condition (Condition (Alt));
10965 -- Determine the smallest specified delay
10967 -- for each delay alternative generate:
10969 -- if guard-expression then
10970 -- Delay_Val := delay-expression;
10971 -- Guard_Open := True;
10972 -- if Delay_Val < Delay_Min then
10973 -- Delay_Min := Delay_Val;
10974 -- Delay_Index := Index;
10978 -- The enclosing if-statement is omitted if there is no guard
10980 if Delay_Count = 1 or else First_Delay then
10981 First_Delay := False;
10983 Delay_Alt := New_List (
10984 Make_Assignment_Statement (Loc,
10985 Name => New_Occurrence_Of (Delay_Min, Loc),
10986 Expression => Expression (Delay_Statement (Alt))));
10988 if Delay_Count > 1 then
10989 Append_To (Delay_Alt,
10990 Make_Assignment_Statement (Loc,
10991 Name => New_Occurrence_Of (Delay_Index, Loc),
10992 Expression => Make_Integer_Literal (Loc, Index)));
10996 Delay_Alt := New_List (
10997 Make_Assignment_Statement (Loc,
10998 Name => New_Occurrence_Of (Delay_Val, Loc),
10999 Expression => Expression (Delay_Statement (Alt))));
11001 if Time_Type = Standard_Duration then
11004 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc),
11005 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc));
11008 -- The scope of the time type must define a comparison
11009 -- operator. The scope itself may not be visible, so we
11010 -- construct a node with entity information to insure that
11011 -- semantic analysis can find the proper operator.
11014 Make_Function_Call (Loc,
11015 Name => Make_Selected_Component (Loc,
11017 New_Occurrence_Of (Scope (Time_Type), Loc),
11019 Make_Operator_Symbol (Loc,
11020 Chars => Name_Op_Lt,
11021 Strval => No_String)),
11022 Parameter_Associations =>
11024 New_Occurrence_Of (Delay_Val, Loc),
11025 New_Occurrence_Of (Delay_Min, Loc)));
11027 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
11030 Append_To (Delay_Alt,
11031 Make_Implicit_If_Statement (N,
11033 Then_Statements => New_List (
11034 Make_Assignment_Statement (Loc,
11035 Name => New_Occurrence_Of (Delay_Min, Loc),
11036 Expression => New_Occurrence_Of (Delay_Val, Loc)),
11038 Make_Assignment_Statement (Loc,
11039 Name => New_Occurrence_Of (Delay_Index, Loc),
11040 Expression => Make_Integer_Literal (Loc, Index)))));
11043 if Check_Guard then
11044 Append_To (Delay_Alt,
11045 Make_Assignment_Statement (Loc,
11046 Name => New_Occurrence_Of (Guard_Open, Loc),
11047 Expression => New_Occurrence_Of (Standard_True, Loc)));
11050 if Present (Condition (Alt)) then
11051 Delay_Alt := New_List (
11052 Make_Implicit_If_Statement (N,
11053 Condition => Condition (Alt),
11054 Then_Statements => Delay_Alt));
11057 Append_List (Delay_Alt, Delay_List);
11059 Ensure_Statement_Present (Dloc, Alt);
11061 -- If the delay alternative has a statement part, add choice to the
11062 -- case statements for delays.
11064 if not Is_Empty_List (Statements (Alt)) then
11066 if Delay_Count = 1 then
11067 Append_List (Statements (Alt), Delay_Alt_List);
11070 Append_To (Delay_Alt_List,
11071 Make_Case_Statement_Alternative (Loc,
11072 Discrete_Choices => New_List (
11073 Make_Integer_Literal (Loc, Index)),
11074 Statements => Statements (Alt)));
11077 elsif Delay_Count = 1 then
11079 -- If the single delay has no trailing statements, add a branch
11080 -- to the exit label to the selective wait.
11082 Delay_Alt_List := New_List (
11083 Make_Goto_Statement (Loc,
11084 Name => New_Copy (Identifier (End_Lab))));
11087 end Process_Delay_Alternative;
11089 -- Start of processing for Expand_N_Selective_Accept
11092 Process_Statements_For_Controlled_Objects (N);
11094 -- First insert some declarations before the select. The first is:
11098 -- This variable holds the parameters passed to the accept body. This
11099 -- declaration has already been inserted by the time we get here by
11100 -- a call to Expand_Accept_Declarations made from the semantics when
11101 -- processing the first accept statement contained in the select. We
11102 -- can find this entity as Accept_Address (E), where E is any of the
11103 -- entries references by contained accept statements.
11105 -- The first step is to scan the list of Selective_Accept_Statements
11106 -- to find this entity, and also count the number of accepts, and
11107 -- determine if terminated, delay or else is present:
11111 Alt := First (Alts);
11112 while Present (Alt) loop
11113 Process_Statements_For_Controlled_Objects (Alt);
11115 if Nkind (Alt) = N_Accept_Alternative then
11118 elsif Nkind (Alt) = N_Delay_Alternative then
11119 Delay_Count := Delay_Count + 1;
11121 -- If the delays are relative delays, the delay expressions have
11122 -- type Standard_Duration. Otherwise they must have some time type
11123 -- recognized by GNAT.
11125 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
11126 Time_Type := Standard_Duration;
11128 Time_Type := Etype (Expression (Delay_Statement (Alt)));
11130 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
11131 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
11136 "& is not a time type (RM 9.6(6))",
11137 Expression (Delay_Statement (Alt)), Time_Type);
11138 Time_Type := Standard_Duration;
11139 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
11143 if No (Condition (Alt)) then
11145 -- This guard will always be open
11147 Check_Guard := False;
11150 elsif Nkind (Alt) = N_Terminate_Alternative then
11151 Adjust_Condition (Condition (Alt));
11152 Terminate_Alt := Alt;
11155 Num_Alts := Num_Alts + 1;
11159 Else_Present := Present (Else_Statements (N));
11161 -- At the same time (see procedure Add_Accept) we build the accept list:
11163 -- Qnn : Accept_List (1 .. num-select) := (
11164 -- (null-body, entry-index),
11165 -- (null-body, entry-index),
11167 -- (null_body, entry-index));
11169 -- In the above declaration, null-body is True if the corresponding
11170 -- accept has no body, and false otherwise. The entry is either the
11171 -- entry index expression if there is no guard, or if a guard is
11172 -- present, then an if expression of the form:
11174 -- (if guard then entry-index else Null_Task_Entry)
11176 -- If a guard is statically known to be false, the entry can simply
11177 -- be omitted from the accept list.
11180 Make_Object_Declaration (Loc,
11181 Defining_Identifier => Qnam,
11182 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11183 Aliased_Present => True,
11185 Make_Qualified_Expression (Loc,
11187 New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11189 Make_Aggregate (Loc, Expressions => Accept_List))));
11191 -- Then we declare the variable that holds the index for the accept
11192 -- that will be selected for service:
11194 -- Xnn : Select_Index;
11197 Make_Object_Declaration (Loc,
11198 Defining_Identifier => Xnam,
11199 Object_Definition =>
11200 New_Occurrence_Of (RTE (RE_Select_Index), Loc),
11202 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)));
11204 -- After this follow procedure declarations for each accept body
11206 -- procedure Pnn is
11211 -- where the ... are statements from the corresponding procedure body.
11212 -- No parameters are involved, since the parameters are passed via Ann
11213 -- and the parameter references have already been expanded to be direct
11214 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11215 -- any embedded tasking statements (which would normally be illegal in
11216 -- procedures), have been converted to calls to the tasking runtime so
11217 -- there is no problem in putting them into procedures.
11219 -- The original accept statement has been expanded into a block in
11220 -- the same fashion as for simple accepts (see Build_Accept_Body).
11222 -- Note: we don't really need to build these procedures for the case
11223 -- where no delay statement is present, but it is just as easy to
11224 -- build them unconditionally, and not significantly inefficient,
11225 -- since if they are short they will be inlined anyway.
11227 -- The procedure declarations have been assembled in Body_List
11229 -- If delays are present, we must compute the required delay.
11230 -- We first generate the declarations:
11232 -- Delay_Index : Boolean := 0;
11233 -- Delay_Min : Some_Time_Type.Time;
11234 -- Delay_Val : Some_Time_Type.Time;
11236 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11237 -- active delay that is actually chosen as the basis for the possible
11238 -- delay if an immediate rendez-vous is not possible.
11240 -- In the most common case there is a single delay statement, and this
11241 -- is handled specially.
11243 if Delay_Count > 0 then
11245 -- Generate the required declarations
11248 Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
11250 Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
11252 Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
11255 Make_Object_Declaration (Loc,
11256 Defining_Identifier => Delay_Val,
11257 Object_Definition => New_Occurrence_Of (Time_Type, Loc)));
11260 Make_Object_Declaration (Loc,
11261 Defining_Identifier => Delay_Index,
11262 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
11263 Expression => Make_Integer_Literal (Loc, 0)));
11266 Make_Object_Declaration (Loc,
11267 Defining_Identifier => Delay_Min,
11268 Object_Definition => New_Occurrence_Of (Time_Type, Loc),
11270 Unchecked_Convert_To (Time_Type,
11271 Make_Attribute_Reference (Loc,
11273 New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
11274 Attribute_Name => Name_Last))));
11276 -- Create Duration and Delay_Mode objects used for passing a delay
11279 D := Make_Temporary (Loc, 'D');
11280 M := Make_Temporary (Loc, 'M');
11286 -- Note that these values are defined in s-osprim.ads and must
11287 -- be kept in sync:
11289 -- Relative : constant := 0;
11290 -- Absolute_Calendar : constant := 1;
11291 -- Absolute_RT : constant := 2;
11293 if Time_Type = Standard_Duration then
11294 Discr := Make_Integer_Literal (Loc, 0);
11296 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11297 Discr := Make_Integer_Literal (Loc, 1);
11301 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11302 Discr := Make_Integer_Literal (Loc, 2);
11306 Make_Object_Declaration (Loc,
11307 Defining_Identifier => D,
11308 Object_Definition =>
11309 New_Occurrence_Of (Standard_Duration, Loc)));
11312 Make_Object_Declaration (Loc,
11313 Defining_Identifier => M,
11314 Object_Definition =>
11315 New_Occurrence_Of (Standard_Integer, Loc),
11316 Expression => Discr));
11319 if Check_Guard then
11321 Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
11324 Make_Object_Declaration (Loc,
11325 Defining_Identifier => Guard_Open,
11326 Object_Definition =>
11327 New_Occurrence_Of (Standard_Boolean, Loc),
11329 New_Occurrence_Of (Standard_False, Loc)));
11332 -- Delay_Count is zero, don't need M and D set (suppress warning)
11339 if Present (Terminate_Alt) then
11341 -- If the terminate alternative guard is False, use
11342 -- Simple_Mode; otherwise use Terminate_Mode.
11344 if Present (Condition (Terminate_Alt)) then
11345 Select_Mode := Make_If_Expression (Loc,
11346 New_List (Condition (Terminate_Alt),
11347 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc),
11348 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)));
11350 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc);
11353 elsif Else_Present or Delay_Count > 0 then
11354 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc);
11357 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc);
11360 Select_Call := Make_Select_Call (Select_Mode);
11361 Append (Select_Call, Stats);
11363 -- Now generate code to act on the result. There is an entry
11364 -- in this case for each accept statement with a non-null body,
11365 -- followed by a branch to the statements that follow the Accept.
11366 -- In the absence of delay alternatives, we generate:
11369 -- when No_Rendezvous => -- omitted if simple mode
11384 -- Lab0: Else_Statements;
11387 -- Lab1: Trailing_Statements1;
11390 -- Lab2: Trailing_Statements2;
11395 -- Generate label for common exit
11397 End_Lab := Make_And_Declare_Label (Num_Alts + 1);
11399 -- First entry is the default case, when no rendezvous is possible
11401 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc));
11403 if Else_Present then
11405 -- If no rendezvous is possible, the else part is executed
11407 Lab := Make_And_Declare_Label (0);
11408 Alt_Stats := New_List (
11409 Make_Goto_Statement (Loc,
11410 Name => New_Copy (Identifier (Lab))));
11412 Append (Lab, Trailing_List);
11413 Append_List (Else_Statements (N), Trailing_List);
11414 Append_To (Trailing_List,
11415 Make_Goto_Statement (Loc,
11416 Name => New_Copy (Identifier (End_Lab))));
11418 Alt_Stats := New_List (
11419 Make_Goto_Statement (Loc,
11420 Name => New_Copy (Identifier (End_Lab))));
11423 Append_To (Alt_List,
11424 Make_Case_Statement_Alternative (Loc,
11425 Discrete_Choices => Choices,
11426 Statements => Alt_Stats));
11428 -- We make use of the fact that Accept_Index is an integer type, and
11429 -- generate successive literals for entries for each accept. Only those
11430 -- for which there is a body or trailing statements get a case entry.
11432 Alt := First (Select_Alternatives (N));
11433 Proc := First (Body_List);
11434 while Present (Alt) loop
11436 if Nkind (Alt) = N_Accept_Alternative then
11437 Process_Accept_Alternative (Alt, Index, Proc);
11438 Index := Index + 1;
11441 (Handled_Statement_Sequence (Accept_Statement (Alt)))
11446 elsif Nkind (Alt) = N_Delay_Alternative then
11447 Process_Delay_Alternative (Alt, Delay_Num);
11448 Delay_Num := Delay_Num + 1;
11454 -- An others choice is always added to the main case, as well
11455 -- as the delay case (to satisfy the compiler).
11457 Append_To (Alt_List,
11458 Make_Case_Statement_Alternative (Loc,
11459 Discrete_Choices =>
11460 New_List (Make_Others_Choice (Loc)),
11462 New_List (Make_Goto_Statement (Loc,
11463 Name => New_Copy (Identifier (End_Lab))))));
11465 Accept_Case := New_List (
11466 Make_Case_Statement (Loc,
11467 Expression => New_Occurrence_Of (Xnam, Loc),
11468 Alternatives => Alt_List));
11470 Append_List (Trailing_List, Accept_Case);
11471 Append_List (Body_List, Decls);
11473 -- Construct case statement for trailing statements of delay
11474 -- alternatives, if there are several of them.
11476 if Delay_Count > 1 then
11477 Append_To (Delay_Alt_List,
11478 Make_Case_Statement_Alternative (Loc,
11479 Discrete_Choices =>
11480 New_List (Make_Others_Choice (Loc)),
11482 New_List (Make_Null_Statement (Loc))));
11484 Delay_Case := New_List (
11485 Make_Case_Statement (Loc,
11486 Expression => New_Occurrence_Of (Delay_Index, Loc),
11487 Alternatives => Delay_Alt_List));
11489 Delay_Case := Delay_Alt_List;
11492 -- If there are no delay alternatives, we append the case statement
11493 -- to the statement list.
11495 if Delay_Count = 0 then
11496 Append_List (Accept_Case, Stats);
11498 -- Delay alternatives present
11501 -- If delay alternatives are present we generate:
11503 -- find minimum delay.
11504 -- DX := minimum delay;
11505 -- M := <delay mode>;
11506 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11509 -- if X = No_Rendezvous then
11510 -- case statement for delay statements.
11512 -- case statement for accept alternatives.
11523 -- The type of the delay expression is known to be legal
11525 if Time_Type = Standard_Duration then
11526 Conv := New_Occurrence_Of (Delay_Min, Loc);
11528 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11529 Conv := Make_Function_Call (Loc,
11530 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
11531 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11535 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11537 Conv := Make_Function_Call (Loc,
11538 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
11539 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11542 Stmt := Make_Assignment_Statement (Loc,
11543 Name => New_Occurrence_Of (D, Loc),
11544 Expression => Conv);
11546 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11548 Parms := Parameter_Associations (Select_Call);
11550 Parm := First (Parms);
11551 while Present (Parm) and then Parm /= Select_Mode loop
11555 pragma Assert (Present (Parm));
11556 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc));
11559 -- Prepare two new parameters of Duration and Delay_Mode type
11560 -- which represent the value and the mode of the minimum delay.
11563 Insert_After (Parm, New_Occurrence_Of (M, Loc));
11564 Insert_After (Parm, New_Occurrence_Of (D, Loc));
11566 -- Create a call to RTS
11568 Rewrite (Select_Call,
11569 Make_Procedure_Call_Statement (Loc,
11570 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc),
11571 Parameter_Associations => Parms));
11573 -- This new call should follow the calculation of the minimum
11576 Insert_List_Before (Select_Call, Delay_List);
11578 if Check_Guard then
11580 Make_Implicit_If_Statement (N,
11581 Condition => New_Occurrence_Of (Guard_Open, Loc),
11582 Then_Statements => New_List (
11583 New_Copy_Tree (Stmt),
11584 New_Copy_Tree (Select_Call)),
11585 Else_Statements => Accept_Or_Raise);
11586 Rewrite (Select_Call, Stmt);
11588 Insert_Before (Select_Call, Stmt);
11592 Make_Implicit_If_Statement (N,
11593 Condition => Make_Op_Eq (Loc,
11594 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
11596 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
11598 Then_Statements => Delay_Case,
11599 Else_Statements => Accept_Case);
11601 Append (Cases, Stats);
11605 Append (End_Lab, Stats);
11607 -- Replace accept statement with appropriate block
11610 Make_Block_Statement (Loc,
11611 Declarations => Decls,
11612 Handled_Statement_Sequence =>
11613 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)));
11616 -- Note: have to worry more about abort deferral in above code ???
11618 -- Final step is to unstack the Accept_Address entries for all accept
11619 -- statements appearing in accept alternatives in the select statement
11621 Alt := First (Alts);
11622 while Present (Alt) loop
11623 if Nkind (Alt) = N_Accept_Alternative then
11624 Remove_Last_Elmt (Accept_Address
11625 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
11630 end Expand_N_Selective_Accept;
11632 -------------------------------------------
11633 -- Expand_N_Single_Protected_Declaration --
11634 -------------------------------------------
11636 -- A single protected declaration should never be present after semantic
11637 -- analysis because it is transformed into a protected type declaration
11638 -- and an accompanying anonymous object. This routine ensures that the
11639 -- transformation takes place.
11641 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is
11643 raise Program_Error;
11644 end Expand_N_Single_Protected_Declaration;
11646 --------------------------------------
11647 -- Expand_N_Single_Task_Declaration --
11648 --------------------------------------
11650 -- A single task declaration should never be present after semantic
11651 -- analysis because it is transformed into a task type declaration and
11652 -- an accompanying anonymous object. This routine ensures that the
11653 -- transformation takes place.
11655 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
11657 raise Program_Error;
11658 end Expand_N_Single_Task_Declaration;
11660 ------------------------
11661 -- Expand_N_Task_Body --
11662 ------------------------
11664 -- Given a task body
11666 -- task body tname is
11672 -- This expansion routine converts it into a procedure and sets the
11673 -- elaboration flag for the procedure to true, to represent the fact
11674 -- that the task body is now elaborated:
11676 -- procedure tnameB (_Task : access tnameV) is
11677 -- discriminal : dtype renames _Task.discriminant;
11679 -- procedure _clean is
11681 -- Abort_Defer.all;
11683 -- Abort_Undefer.all;
11688 -- Abort_Undefer.all;
11690 -- System.Task_Stages.Complete_Activation;
11698 -- In addition, if the task body is an activator, then a call to activate
11699 -- tasks is added at the start of the statements, before the call to
11700 -- Complete_Activation, and if in addition the task is a master then it
11701 -- must be established as a master. These calls are inserted and analyzed
11702 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11705 -- There is one discriminal declaration line generated for each
11706 -- discriminant that is present to provide an easy reference point for
11707 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11709 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11710 -- task body procedures have a profile (Arg : System.Address). That is
11711 -- needed because GNARLI has to use the same access-to-subprogram type
11712 -- for all task types. We depend here on knowing that in GNAT, passing
11713 -- an address argument by value is identical to passing a record value
11714 -- by access (in either case a single pointer is passed), so even though
11715 -- this procedure has the wrong profile. In fact it's all OK, since the
11716 -- callings sequence is identical.
11718 procedure Expand_N_Task_Body (N : Node_Id) is
11719 Loc : constant Source_Ptr := Sloc (N);
11720 Ttyp : constant Entity_Id := Corresponding_Spec (N);
11724 Insert_Nod : Node_Id;
11725 -- Used to determine the proper location of wrapper body insertions
11728 -- if no task body procedure, means we had an error in configurable
11729 -- run-time mode, and there is no point in proceeding further.
11731 if No (Task_Body_Procedure (Ttyp)) then
11735 -- Add renaming declarations for discriminals and a declaration for the
11736 -- entry family index (if applicable).
11738 Install_Private_Data_Declarations
11739 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N));
11741 -- Add a call to Abort_Undefer at the very beginning of the task
11742 -- body since this body is called with abort still deferred.
11744 if Abort_Allowed then
11745 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
11747 (First (Statements (Handled_Statement_Sequence (N))), Call);
11751 -- The statement part has already been protected with an at_end and
11752 -- cleanup actions. The call to Complete_Activation must be placed
11753 -- at the head of the sequence of statements of that block. The
11754 -- declarations have been merged in this sequence of statements but
11755 -- the first real statement is accessible from the First_Real_Statement
11756 -- field (which was set for exactly this purpose).
11758 if Restricted_Profile then
11759 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
11761 Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
11765 (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
11769 Make_Subprogram_Body (Loc,
11770 Specification => Build_Task_Proc_Specification (Ttyp),
11771 Declarations => Declarations (N),
11772 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
11773 Set_Is_Task_Body_Procedure (New_N);
11775 -- If the task contains generic instantiations, cleanup actions are
11776 -- delayed until after instantiation. Transfer the activation chain to
11777 -- the subprogram, to insure that the activation call is properly
11778 -- generated. It the task body contains inner tasks, indicate that the
11779 -- subprogram is a task master.
11781 if Delay_Cleanups (Ttyp) then
11782 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
11783 Set_Is_Task_Master (New_N, Is_Task_Master (N));
11786 Rewrite (N, New_N);
11789 -- Set elaboration flag immediately after task body. If the body is a
11790 -- subunit, the flag is set in the declarative part containing the stub.
11792 if Nkind (Parent (N)) /= N_Subunit then
11794 Make_Assignment_Statement (Loc,
11796 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
11797 Expression => New_Occurrence_Of (Standard_True, Loc)));
11800 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11801 -- the task body. At this point all wrapper specs have been created,
11802 -- frozen and included in the dispatch table for the task type.
11804 if Ada_Version >= Ada_2005 then
11805 if Nkind (Parent (N)) = N_Subunit then
11806 Insert_Nod := Corresponding_Stub (Parent (N));
11811 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
11813 end Expand_N_Task_Body;
11815 ------------------------------------
11816 -- Expand_N_Task_Type_Declaration --
11817 ------------------------------------
11819 -- We have several things to do. First we must create a Boolean flag used
11820 -- to mark if the body is elaborated yet. This variable gets set to True
11821 -- when the body of the task is elaborated (we can't rely on the normal
11822 -- ABE mechanism for the task body, since we need to pass an access to
11823 -- this elaboration boolean to the runtime routines).
11825 -- taskE : aliased Boolean := False;
11827 -- Next a variable is declared to hold the task stack size (either the
11828 -- default : Unspecified_Size, or a value that is set by a pragma
11829 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11830 -- the variable is initialized with this value:
11832 -- taskZ : Size_Type := Unspecified_Size;
11834 -- taskZ : Size_Type := Size_Type (size_expression);
11836 -- Note: No variable is needed to hold the task relative deadline since
11837 -- its value would never be static because the parameter is of a private
11838 -- type (Ada.Real_Time.Time_Span).
11840 -- Next we create a corresponding record type declaration used to represent
11841 -- values of this task. The general form of this type declaration is
11843 -- type taskV (discriminants) is record
11844 -- _Task_Id : Task_Id;
11845 -- entry_family : array (bounds) of Void;
11846 -- _Priority : Integer := priority_expression;
11847 -- _Size : Size_Type := size_expression;
11848 -- _Secondary_Stack_Size : Size_Type := size_expression;
11849 -- _Task_Info : Task_Info_Type := task_info_expression;
11850 -- _CPU : Integer := cpu_range_expression;
11851 -- _Relative_Deadline : Time_Span := time_span_expression;
11852 -- _Domain : Dispatching_Domain := dd_expression;
11855 -- The discriminants are present only if the corresponding task type has
11856 -- discriminants, and they exactly mirror the task type discriminants.
11858 -- The Id field is always present. It contains the Task_Id value, as set by
11859 -- the call to Create_Task. Note that although the task is limited, the
11860 -- task value record type is not limited, so there is no problem in passing
11861 -- this field as an out parameter to Create_Task.
11863 -- One entry_family component is present for each entry family in the task
11864 -- definition. The bounds correspond to the bounds of the entry family
11865 -- (which may depend on discriminants). The element type is void, since we
11866 -- only need the bounds information for determining the entry index. Note
11867 -- that the use of an anonymous array would normally be illegal in this
11868 -- context, but this is a parser check, and the semantics is quite prepared
11869 -- to handle such a case.
11871 -- The _Size field is present only if a Storage_Size pragma appears in the
11872 -- task definition. The expression captures the argument that was present
11873 -- in the pragma, and is used to override the task stack size otherwise
11874 -- associated with the task type.
11876 -- The _Secondary_Stack_Size field is present only the task entity has a
11877 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11878 -- when the record init proc is built, to capture the expression of the
11879 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11880 -- be filled here since aspect evaluations are delayed till the freeze
11883 -- The _Priority field is present only if the task entity has a Priority or
11884 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11885 -- definition clause). It will be filled at the freeze point, when the
11886 -- record init proc is built, to capture the expression of the rep item
11887 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11888 -- here since aspect evaluations are delayed till the freeze point.
11890 -- The _Task_Info field is present only if a Task_Info pragma appears in
11891 -- the task definition. The expression captures the argument that was
11892 -- present in the pragma, and is used to provide the Task_Image parameter
11893 -- to the call to Create_Task.
11895 -- The _CPU field is present only if the task entity has a CPU rep item
11896 -- (pragma, aspect specification or attribute definition clause). It will
11897 -- be filled at the freeze point, when the record init proc is built, to
11898 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11899 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11900 -- are delayed till the freeze point.
11902 -- The _Relative_Deadline field is present only if a Relative_Deadline
11903 -- pragma appears in the task definition. The expression captures the
11904 -- argument that was present in the pragma, and is used to provide the
11905 -- Relative_Deadline parameter to the call to Create_Task.
11907 -- The _Domain field is present only if the task entity has a
11908 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11909 -- definition clause). It will be filled at the freeze point, when the
11910 -- record init proc is built, to capture the expression of the rep item
11911 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11912 -- here since aspect evaluations are delayed till the freeze point.
11914 -- When a task is declared, an instance of the task value record is
11915 -- created. The elaboration of this declaration creates the correct bounds
11916 -- for the entry families, and also evaluates the size, priority, and
11917 -- task_Info expressions if needed. The initialization routine for the task
11918 -- type itself then calls Create_Task with appropriate parameters to
11919 -- initialize the value of the Task_Id field.
11921 -- Note: the address of this record is passed as the "Discriminants"
11922 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11923 -- body procedure, it does not matter that it does not quite match the
11924 -- GNARLI model of what is being passed (the record contains more than just
11925 -- the discriminants, but the discriminants can be found from the record
11928 -- The Entity_Id for this created record type is placed in the
11929 -- Corresponding_Record_Type field of the associated task type entity.
11931 -- Next we create a procedure specification for the task body procedure:
11933 -- procedure taskB (_Task : access taskV);
11935 -- Note that this must come after the record type declaration, since
11936 -- the spec refers to this type. It turns out that the initialization
11937 -- procedure for the value type references the task body spec, but that's
11938 -- fine, since it won't be generated till the freeze point for the type,
11939 -- which is certainly after the task body spec declaration.
11941 -- Finally, we set the task index value field of the entry attribute in
11942 -- the case of a simple entry.
11944 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
11945 Loc : constant Source_Ptr := Sloc (N);
11946 TaskId : constant Entity_Id := Defining_Identifier (N);
11947 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
11948 Tasknm : constant Name_Id := Chars (Tasktyp);
11949 Taskdef : constant Node_Id := Task_Definition (N);
11951 Body_Decl : Node_Id;
11953 Decl_Stack : Node_Id;
11955 Elab_Decl : Node_Id;
11956 Ent_Stack : Entity_Id;
11957 Proc_Spec : Node_Id;
11958 Rec_Decl : Node_Id;
11959 Rec_Ent : Entity_Id;
11960 Size_Decl : Entity_Id;
11961 Task_Size : Node_Id;
11963 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id;
11964 -- Searches the task definition T for the first occurrence of the pragma
11965 -- Relative Deadline. The caller has ensured that the pragma is present
11966 -- in the task definition. Note that this routine cannot be implemented
11967 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11968 -- not chained because their expansion into a procedure call statement
11969 -- would cause a break in the chain.
11971 ----------------------------------
11972 -- Get_Relative_Deadline_Pragma --
11973 ----------------------------------
11975 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is
11979 N := First (Visible_Declarations (T));
11980 while Present (N) loop
11981 if Nkind (N) = N_Pragma
11982 and then Pragma_Name (N) = Name_Relative_Deadline
11990 N := First (Private_Declarations (T));
11991 while Present (N) loop
11992 if Nkind (N) = N_Pragma
11993 and then Pragma_Name (N) = Name_Relative_Deadline
12001 raise Program_Error;
12002 end Get_Relative_Deadline_Pragma;
12004 -- Start of processing for Expand_N_Task_Type_Declaration
12007 -- If already expanded, nothing to do
12009 if Present (Corresponding_Record_Type (Tasktyp)) then
12013 -- Here we will do the expansion
12015 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
12017 Rec_Ent := Defining_Identifier (Rec_Decl);
12018 Cdecls := Component_Items (Component_List
12019 (Type_Definition (Rec_Decl)));
12021 Qualify_Entity_Names (N);
12023 -- First create the elaboration variable
12026 Make_Object_Declaration (Loc,
12027 Defining_Identifier =>
12028 Make_Defining_Identifier (Sloc (Tasktyp),
12029 Chars => New_External_Name (Tasknm, 'E')),
12030 Aliased_Present => True,
12031 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
12032 Expression => New_Occurrence_Of (Standard_False, Loc));
12034 Insert_After (N, Elab_Decl);
12036 -- Next create the declaration of the size variable (tasknmZ)
12038 Set_Storage_Size_Variable (Tasktyp,
12039 Make_Defining_Identifier (Sloc (Tasktyp),
12040 Chars => New_External_Name (Tasknm, 'Z')));
12042 if Present (Taskdef)
12043 and then Has_Storage_Size_Pragma (Taskdef)
12045 Is_OK_Static_Expression
12047 (First (Pragma_Argument_Associations
12048 (Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
12051 Make_Object_Declaration (Loc,
12052 Defining_Identifier => Storage_Size_Variable (Tasktyp),
12053 Object_Definition =>
12054 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
12056 Convert_To (RTE (RE_Size_Type),
12058 (Expression (First (Pragma_Argument_Associations
12060 (TaskId, Name_Storage_Size)))))));
12064 Make_Object_Declaration (Loc,
12065 Defining_Identifier => Storage_Size_Variable (Tasktyp),
12066 Object_Definition =>
12067 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
12069 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
12072 Insert_After (Elab_Decl, Size_Decl);
12074 -- Next build the rest of the corresponding record declaration. This is
12075 -- done last, since the corresponding record initialization procedure
12076 -- will reference the previously created entities.
12078 -- Fill in the component declarations -- first the _Task_Id field
12081 Make_Component_Declaration (Loc,
12082 Defining_Identifier =>
12083 Make_Defining_Identifier (Loc, Name_uTask_Id),
12084 Component_Definition =>
12085 Make_Component_Definition (Loc,
12086 Aliased_Present => False,
12087 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id),
12090 -- Declare static ATCB (that is, created by the expander) if we are
12091 -- using the Restricted run time.
12093 if Restricted_Profile then
12095 Make_Component_Declaration (Loc,
12096 Defining_Identifier =>
12097 Make_Defining_Identifier (Loc, Name_uATCB),
12099 Component_Definition =>
12100 Make_Component_Definition (Loc,
12101 Aliased_Present => True,
12102 Subtype_Indication => Make_Subtype_Indication (Loc,
12104 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc),
12107 Make_Index_Or_Discriminant_Constraint (Loc,
12109 New_List (Make_Integer_Literal (Loc, 0)))))));
12113 -- Declare static stack (that is, created by the expander) if we are
12114 -- using the Restricted run time on a bare board configuration.
12116 if Restricted_Profile and then Preallocated_Stacks_On_Target then
12118 -- First we need to extract the appropriate stack size
12120 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
12122 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12124 Expr_N : constant Node_Id :=
12125 Expression (First (
12126 Pragma_Argument_Associations (
12127 Get_Rep_Pragma (TaskId, Name_Storage_Size))));
12128 Etyp : constant Entity_Id := Etype (Expr_N);
12129 P : constant Node_Id := Parent (Expr_N);
12132 -- The stack is defined inside the corresponding record.
12133 -- Therefore if the size of the stack is set by means of
12134 -- a discriminant, we must reference the discriminant of the
12135 -- corresponding record type.
12137 if Nkind (Expr_N) in N_Has_Entity
12138 and then Present (Discriminal_Link (Entity (Expr_N)))
12142 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
12144 Set_Parent (Task_Size, P);
12145 Set_Etype (Task_Size, Etyp);
12146 Set_Analyzed (Task_Size);
12149 Task_Size := New_Copy_Tree (Expr_N);
12155 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc);
12158 Decl_Stack := Make_Component_Declaration (Loc,
12159 Defining_Identifier => Ent_Stack,
12161 Component_Definition =>
12162 Make_Component_Definition (Loc,
12163 Aliased_Present => True,
12164 Subtype_Indication => Make_Subtype_Indication (Loc,
12166 New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
12169 Make_Index_Or_Discriminant_Constraint (Loc,
12170 Constraints => New_List (Make_Range (Loc,
12171 Low_Bound => Make_Integer_Literal (Loc, 1),
12172 High_Bound => Convert_To (RTE (RE_Storage_Offset),
12175 Append_To (Cdecls, Decl_Stack);
12177 -- The appropriate alignment for the stack is ensured by the run-time
12178 -- code in charge of task creation.
12182 -- Declare a static secondary stack if the conditions for a statically
12183 -- generated stack are met.
12185 if Create_Secondary_Stack_For_Task (TaskId) then
12187 Size_Expr : constant Node_Id :=
12188 Expression (First (
12189 Pragma_Argument_Associations (
12190 Get_Rep_Pragma (TaskId,
12191 Name_Secondary_Stack_Size))));
12193 Stack_Size : Node_Id;
12196 -- The secondary stack is defined inside the corresponding
12197 -- record. Therefore if the size of the stack is set by means
12198 -- of a discriminant, we must reference the discriminant of the
12199 -- corresponding record type.
12201 if Nkind (Size_Expr) in N_Has_Entity
12202 and then Present (Discriminal_Link (Entity (Size_Expr)))
12206 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))),
12208 Set_Parent (Stack_Size, Parent (Size_Expr));
12209 Set_Etype (Stack_Size, Etype (Size_Expr));
12210 Set_Analyzed (Stack_Size);
12213 Stack_Size := New_Copy_Tree (Size_Expr);
12216 -- Create the secondary stack for the task
12219 Make_Component_Declaration (Loc,
12220 Defining_Identifier =>
12221 Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
12222 Component_Definition =>
12223 Make_Component_Definition (Loc,
12224 Aliased_Present => True,
12225 Subtype_Indication =>
12226 Make_Subtype_Indication (Loc,
12228 New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
12230 Make_Index_Or_Discriminant_Constraint (Loc,
12231 Constraints => New_List (
12232 Convert_To (RTE (RE_Size_Type),
12235 Append_To (Cdecls, Decl_SS);
12239 -- Add components for entry families
12241 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
12243 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12244 -- item is present.
12246 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then
12248 Make_Component_Declaration (Loc,
12249 Defining_Identifier =>
12250 Make_Defining_Identifier (Loc, Name_uPriority),
12251 Component_Definition =>
12252 Make_Component_Definition (Loc,
12253 Aliased_Present => False,
12254 Subtype_Indication =>
12255 New_Occurrence_Of (Standard_Integer, Loc))));
12258 -- Add the _Size component if a Storage_Size pragma is present
12260 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12262 Make_Component_Declaration (Loc,
12263 Defining_Identifier =>
12264 Make_Defining_Identifier (Loc, Name_uSize),
12266 Component_Definition =>
12267 Make_Component_Definition (Loc,
12268 Aliased_Present => False,
12269 Subtype_Indication =>
12270 New_Occurrence_Of (RTE (RE_Size_Type), Loc)),
12273 Convert_To (RTE (RE_Size_Type),
12275 Expression (First (
12276 Pragma_Argument_Associations (
12277 Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
12280 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
12281 -- pragma is present.
12284 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False)
12287 Make_Component_Declaration (Loc,
12288 Defining_Identifier =>
12289 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size),
12291 Component_Definition =>
12292 Make_Component_Definition (Loc,
12293 Aliased_Present => False,
12294 Subtype_Indication =>
12295 New_Occurrence_Of (RTE (RE_Size_Type), Loc))));
12298 -- Add the _Task_Info component if a Task_Info pragma is present
12300 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then
12302 Make_Component_Declaration (Loc,
12303 Defining_Identifier =>
12304 Make_Defining_Identifier (Loc, Name_uTask_Info),
12306 Component_Definition =>
12307 Make_Component_Definition (Loc,
12308 Aliased_Present => False,
12309 Subtype_Indication =>
12310 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)),
12312 Expression => New_Copy (
12313 Expression (First (
12314 Pragma_Argument_Associations (
12316 (TaskId, Name_Task_Info, Check_Parents => False)))))));
12319 -- Add the _CPU component if a CPU rep item is present
12321 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then
12323 Make_Component_Declaration (Loc,
12324 Defining_Identifier =>
12325 Make_Defining_Identifier (Loc, Name_uCPU),
12327 Component_Definition =>
12328 Make_Component_Definition (Loc,
12329 Aliased_Present => False,
12330 Subtype_Indication =>
12331 New_Occurrence_Of (RTE (RE_CPU_Range), Loc))));
12334 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12335 -- present. If we are using a restricted run time this component will
12336 -- not be added (deadlines are not allowed by the Ravenscar profile),
12337 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
12340 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E')
12341 and then Present (Taskdef)
12342 and then Has_Relative_Deadline_Pragma (Taskdef)
12345 Make_Component_Declaration (Loc,
12346 Defining_Identifier =>
12347 Make_Defining_Identifier (Loc, Name_uRelative_Deadline),
12349 Component_Definition =>
12350 Make_Component_Definition (Loc,
12351 Aliased_Present => False,
12352 Subtype_Indication =>
12353 New_Occurrence_Of (RTE (RE_Time_Span), Loc)),
12356 Convert_To (RTE (RE_Time_Span),
12358 Expression (First (
12359 Pragma_Argument_Associations (
12360 Get_Relative_Deadline_Pragma (Taskdef))))))));
12363 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12364 -- item is present. If we are using a restricted run time this component
12365 -- will not be added (dispatching domains are not allowed by the
12366 -- Ravenscar profile).
12368 if not Restricted_Profile
12371 (TaskId, Name_Dispatching_Domain, Check_Parents => False)
12374 Make_Component_Declaration (Loc,
12375 Defining_Identifier =>
12376 Make_Defining_Identifier (Loc, Name_uDispatching_Domain),
12378 Component_Definition =>
12379 Make_Component_Definition (Loc,
12380 Aliased_Present => False,
12381 Subtype_Indication =>
12383 (RTE (RE_Dispatching_Domain_Access), Loc))));
12386 Insert_After (Size_Decl, Rec_Decl);
12388 -- Analyze the record declaration immediately after construction,
12389 -- because the initialization procedure is needed for single task
12390 -- declarations before the next entity is analyzed.
12392 Analyze (Rec_Decl);
12394 -- Create the declaration of the task body procedure
12396 Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
12398 Make_Subprogram_Declaration (Loc,
12399 Specification => Proc_Spec);
12400 Set_Is_Task_Body_Procedure (Body_Decl);
12402 Insert_After (Rec_Decl, Body_Decl);
12404 -- The subprogram does not comes from source, so we have to indicate the
12405 -- need for debugging information explicitly.
12407 if Comes_From_Source (Original_Node (N)) then
12408 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec));
12411 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12412 -- the corresponding record has been frozen.
12414 if Ada_Version >= Ada_2005 then
12415 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
12418 -- Ada 2005 (AI-345): We must defer freezing to allow further
12419 -- declaration of primitive subprograms covering task interfaces
12421 if Ada_Version <= Ada_95 then
12423 -- Now we can freeze the corresponding record. This needs manually
12424 -- freezing, since it is really part of the task type, and the task
12425 -- type is frozen at this stage. We of course need the initialization
12426 -- procedure for this corresponding record type and we won't get it
12427 -- in time if we don't freeze now.
12430 L : constant List_Id := Freeze_Entity (Rec_Ent, N);
12432 if Is_Non_Empty_List (L) then
12433 Insert_List_After (Body_Decl, L);
12438 -- Complete the expansion of access types to the current task type, if
12439 -- any were declared.
12441 Expand_Previous_Access_Type (Tasktyp);
12443 -- Create wrappers for entries that have contract cases, preconditions
12444 -- and postconditions.
12450 Ent := First_Entity (Tasktyp);
12451 while Present (Ent) loop
12452 if Ekind_In (Ent, E_Entry, E_Entry_Family) then
12453 Build_Contract_Wrapper (Ent, N);
12459 end Expand_N_Task_Type_Declaration;
12461 -------------------------------
12462 -- Expand_N_Timed_Entry_Call --
12463 -------------------------------
12465 -- A timed entry call in normal case is not implemented using ATC mechanism
12466 -- anymore for efficiency reason.
12476 -- is expanded as follows:
12478 -- 1) When T.E is a task entry_call;
12482 -- X : Task_Entry_Index := <entry index>;
12483 -- DX : Duration := To_Duration (D);
12484 -- M : Delay_Mode := <discriminant>;
12485 -- P : parms := (parm, parm, parm);
12488 -- Timed_Protected_Entry_Call
12489 -- (<acceptor-task>, X, P'Address, DX, M, B);
12497 -- 2) When T.E is a protected entry_call;
12501 -- X : Protected_Entry_Index := <entry index>;
12502 -- DX : Duration := To_Duration (D);
12503 -- M : Delay_Mode := <discriminant>;
12504 -- P : parms := (parm, parm, parm);
12507 -- Timed_Protected_Entry_Call
12508 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12516 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12517 -- is no delay and the triggering statements are executed. We first
12518 -- determine the kind of the triggering call and then execute a
12519 -- synchronized operation or a direct call.
12522 -- B : Boolean := False;
12523 -- C : Ada.Tags.Prim_Op_Kind;
12524 -- DX : Duration := To_Duration (D)
12525 -- K : Ada.Tags.Tagged_Kind :=
12526 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12527 -- M : Integer :=...;
12528 -- P : Parameters := (Param1 .. ParamN);
12532 -- if K = Ada.Tags.TK_Limited_Tagged
12533 -- or else K = Ada.Tags.TK_Tagged
12535 -- <dispatching-call>;
12540 -- Ada.Tags.Get_Offset_Index
12541 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12543 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12545 -- if C = POK_Protected_Entry
12546 -- or else C = POK_Task_Entry
12548 -- Param1 := P.Param1;
12550 -- ParamN := P.ParamN;
12554 -- if C = POK_Procedure
12555 -- or else C = POK_Protected_Procedure
12556 -- or else C = POK_Task_Procedure
12558 -- <dispatching-call>;
12564 -- <triggering-statements>
12566 -- <timed-statements>
12570 -- The triggering statement and the sequence of timed statements have not
12571 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12572 -- global references if within an instantiation.
12574 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
12575 Loc : constant Source_Ptr := Sloc (N);
12578 Blk_Typ : Entity_Id;
12580 Call_Ent : Entity_Id;
12581 Conc_Typ_Stmts : List_Id;
12582 Concval : Node_Id := Empty; -- init to avoid warning
12583 D_Alt : constant Node_Id := Delay_Alternative (N);
12586 D_Stat : Node_Id := Delay_Statement (D_Alt);
12588 D_Type : Entity_Id;
12591 E_Alt : constant Node_Id := Entry_Call_Alternative (N);
12592 E_Call : Node_Id := Entry_Call_Statement (E_Alt);
12597 Is_Disp_Select : Boolean;
12598 Lim_Typ_Stmts : List_Id;
12607 B : Entity_Id; -- Call status flag
12608 C : Entity_Id; -- Call kind
12609 D : Entity_Id; -- Delay
12610 K : Entity_Id; -- Tagged kind
12611 M : Entity_Id; -- Delay mode
12612 P : Entity_Id; -- Parameter block
12613 S : Entity_Id; -- Primitive operation slot
12615 -- Start of processing for Expand_N_Timed_Entry_Call
12618 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12619 -- was already reported on spec, so do not attempt to expand the call.
12621 if Restriction_Active (No_Select_Statements) then
12625 Process_Statements_For_Controlled_Objects (E_Alt);
12626 Process_Statements_For_Controlled_Objects (D_Alt);
12628 Ensure_Statement_Present (Sloc (D_Stat), D_Alt);
12630 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12631 -- may wrap them in blocks.
12633 E_Stats := Statements (E_Alt);
12634 D_Stats := Statements (D_Alt);
12636 -- The arguments in the call may require dynamic allocation, and the
12637 -- call statement may have been transformed into a block. The block
12638 -- may contain additional declarations for internal entities, and the
12639 -- original call is found by sequential search.
12641 if Nkind (E_Call) = N_Block_Statement then
12642 E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
12643 while not Nkind_In (E_Call, N_Procedure_Call_Statement,
12644 N_Entry_Call_Statement)
12651 Ada_Version >= Ada_2005
12652 and then Nkind (E_Call) = N_Procedure_Call_Statement;
12654 if Is_Disp_Select then
12655 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
12661 -- B : Boolean := False;
12663 B := Build_B (Loc, Decls);
12666 -- C : Ada.Tags.Prim_Op_Kind;
12668 C := Build_C (Loc, Decls);
12670 -- Because the analysis of all statements was disabled, manually
12671 -- analyze the delay statement.
12674 D_Stat := Original_Node (D_Stat);
12677 -- Build an entry call using Simple_Entry_Call
12679 Extract_Entry (E_Call, Concval, Ename, Index);
12680 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
12682 Decls := Declarations (E_Call);
12683 Stmts := Statements (Handled_Statement_Sequence (E_Call));
12692 B := Make_Defining_Identifier (Loc, Name_uB);
12695 Make_Object_Declaration (Loc,
12696 Defining_Identifier => B,
12697 Object_Definition =>
12698 New_Occurrence_Of (Standard_Boolean, Loc)));
12701 -- Duration and mode processing
12703 D_Type := Base_Type (Etype (Expression (D_Stat)));
12705 -- Use the type of the delay expression (Calendar or Real_Time) to
12706 -- generate the appropriate conversion.
12708 if Nkind (D_Stat) = N_Delay_Relative_Statement then
12709 D_Disc := Make_Integer_Literal (Loc, 0);
12710 D_Conv := Relocate_Node (Expression (D_Stat));
12712 elsif Is_RTE (D_Type, RO_CA_Time) then
12713 D_Disc := Make_Integer_Literal (Loc, 1);
12715 Make_Function_Call (Loc,
12716 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
12717 Parameter_Associations =>
12718 New_List (New_Copy (Expression (D_Stat))));
12720 else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
12721 D_Disc := Make_Integer_Literal (Loc, 2);
12723 Make_Function_Call (Loc,
12724 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
12725 Parameter_Associations =>
12726 New_List (New_Copy (Expression (D_Stat))));
12729 D := Make_Temporary (Loc, 'D');
12735 Make_Object_Declaration (Loc,
12736 Defining_Identifier => D,
12737 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc)));
12739 M := Make_Temporary (Loc, 'M');
12742 -- M : Integer := (0 | 1 | 2);
12745 Make_Object_Declaration (Loc,
12746 Defining_Identifier => M,
12747 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
12748 Expression => D_Disc));
12750 -- Parameter block processing
12752 -- Manually create the parameter block for dispatching calls. In the
12753 -- case of entries, the block has already been created during the call
12754 -- to Build_Simple_Entry_Call.
12756 if Is_Disp_Select then
12758 -- Compute the delay at this stage because the evaluation of its
12759 -- expression must not occur earlier (see ACVC C97302A).
12762 Make_Assignment_Statement (Loc,
12763 Name => New_Occurrence_Of (D, Loc),
12764 Expression => D_Conv));
12766 -- Tagged kind processing, generate:
12767 -- K : Ada.Tags.Tagged_Kind :=
12768 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12770 K := Build_K (Loc, Decls, Obj);
12772 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
12774 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
12776 -- Dispatch table slot processing, generate:
12779 S := Build_S (Loc, Decls);
12782 -- S := Ada.Tags.Get_Offset_Index
12783 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12786 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
12789 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12791 -- where Obj is the controlling formal parameter, S is the dispatch
12792 -- table slot number of the dispatching operation, P is the wrapped
12793 -- parameter block, D is the duration, M is the duration mode, C is
12794 -- the call kind and B is the call status.
12796 Params := New_List;
12798 Append_To (Params, New_Copy_Tree (Obj));
12799 Append_To (Params, New_Occurrence_Of (S, Loc));
12801 Make_Attribute_Reference (Loc,
12802 Prefix => New_Occurrence_Of (P, Loc),
12803 Attribute_Name => Name_Address));
12804 Append_To (Params, New_Occurrence_Of (D, Loc));
12805 Append_To (Params, New_Occurrence_Of (M, Loc));
12806 Append_To (Params, New_Occurrence_Of (C, Loc));
12807 Append_To (Params, New_Occurrence_Of (B, Loc));
12809 Append_To (Conc_Typ_Stmts,
12810 Make_Procedure_Call_Statement (Loc,
12814 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc),
12815 Parameter_Associations => Params));
12818 -- if C = POK_Protected_Entry
12819 -- or else C = POK_Task_Entry
12821 -- Param1 := P.Param1;
12823 -- ParamN := P.ParamN;
12826 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
12828 -- Generate the if statement only when the packed parameters need
12829 -- explicit assignments to their corresponding actuals.
12831 if Present (Unpack) then
12832 Append_To (Conc_Typ_Stmts,
12833 Make_Implicit_If_Statement (N,
12839 Left_Opnd => New_Occurrence_Of (C, Loc),
12842 (RTE (RE_POK_Protected_Entry), Loc)),
12846 Left_Opnd => New_Occurrence_Of (C, Loc),
12848 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
12850 Then_Statements => Unpack));
12856 -- if C = POK_Procedure
12857 -- or else C = POK_Protected_Procedure
12858 -- or else C = POK_Task_Procedure
12860 -- <dispatching-call>
12864 N_Stats := New_List (
12865 Make_Implicit_If_Statement (N,
12870 Left_Opnd => New_Occurrence_Of (C, Loc),
12872 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
12878 Left_Opnd => New_Occurrence_Of (C, Loc),
12880 New_Occurrence_Of (RTE (
12881 RE_POK_Protected_Procedure), Loc)),
12884 Left_Opnd => New_Occurrence_Of (C, Loc),
12887 (RTE (RE_POK_Task_Procedure), Loc)))),
12889 Then_Statements => New_List (E_Call)));
12891 Append_To (Conc_Typ_Stmts,
12892 Make_Implicit_If_Statement (N,
12893 Condition => New_Occurrence_Of (B, Loc),
12894 Then_Statements => N_Stats));
12897 -- <dispatching-call>;
12901 New_List (New_Copy_Tree (E_Call),
12902 Make_Assignment_Statement (Loc,
12903 Name => New_Occurrence_Of (B, Loc),
12904 Expression => New_Occurrence_Of (Standard_True, Loc)));
12907 -- if K = Ada.Tags.TK_Limited_Tagged
12908 -- or else K = Ada.Tags.TK_Tagged
12916 Make_Implicit_If_Statement (N,
12917 Condition => Build_Dispatching_Tag_Check (K, N),
12918 Then_Statements => Lim_Typ_Stmts,
12919 Else_Statements => Conc_Typ_Stmts));
12924 -- <triggering-statements>
12926 -- <timed-statements>
12930 Make_Implicit_If_Statement (N,
12931 Condition => New_Occurrence_Of (B, Loc),
12932 Then_Statements => E_Stats,
12933 Else_Statements => D_Stats));
12936 -- Simple case of a nondispatching trigger. Skip assignments to
12937 -- temporaries created for in-out parameters.
12939 -- This makes unwarranted assumptions about the shape of the expanded
12940 -- tree for the call, and should be cleaned up ???
12942 Stmt := First (Stmts);
12943 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
12947 -- Compute the delay at this stage because the evaluation of
12948 -- its expression must not occur earlier (see ACVC C97302A).
12950 Insert_Before (Stmt,
12951 Make_Assignment_Statement (Loc,
12952 Name => New_Occurrence_Of (D, Loc),
12953 Expression => D_Conv));
12956 Params := Parameter_Associations (Call);
12958 -- For a protected type, we build a Timed_Protected_Entry_Call
12960 if Is_Protected_Type (Etype (Concval)) then
12962 -- Create a new call statement
12964 Param := First (Params);
12965 while Present (Param)
12966 and then not Is_RTE (Etype (Param), RE_Call_Modes)
12971 Dummy := Remove_Next (Next (Param));
12973 -- Remove garbage is following the Cancel_Param if present
12975 Dummy := Next (Param);
12977 -- Remove the mode of the Protected_Entry_Call call, then remove
12978 -- the Communication_Block of the Protected_Entry_Call call, and
12979 -- finally add Duration and a Delay_Mode parameter
12981 pragma Assert (Present (Param));
12982 Rewrite (Param, New_Occurrence_Of (D, Loc));
12984 Rewrite (Dummy, New_Occurrence_Of (M, Loc));
12986 -- Add a Boolean flag for successful entry call
12988 Append_To (Params, New_Occurrence_Of (B, Loc));
12990 case Corresponding_Runtime_Package (Etype (Concval)) is
12991 when System_Tasking_Protected_Objects_Entries =>
12993 Make_Procedure_Call_Statement (Loc,
12996 (RTE (RE_Timed_Protected_Entry_Call), Loc),
12997 Parameter_Associations => Params));
13000 raise Program_Error;
13003 -- For the task case, build a Timed_Task_Entry_Call
13006 -- Create a new call statement
13008 Append_To (Params, New_Occurrence_Of (D, Loc));
13009 Append_To (Params, New_Occurrence_Of (M, Loc));
13010 Append_To (Params, New_Occurrence_Of (B, Loc));
13013 Make_Procedure_Call_Statement (Loc,
13015 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
13016 Parameter_Associations => Params));
13020 Make_Implicit_If_Statement (N,
13021 Condition => New_Occurrence_Of (B, Loc),
13022 Then_Statements => E_Stats,
13023 Else_Statements => D_Stats));
13027 Make_Block_Statement (Loc,
13028 Declarations => Decls,
13029 Handled_Statement_Sequence =>
13030 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
13034 -- Some items in Decls used to be in the N_Block in E_Call that is
13035 -- constructed in Expand_Entry_Call, and are now in the new Block
13036 -- into which N has been rewritten. Adjust their scopes to reflect that.
13038 if Nkind (E_Call) = N_Block_Statement then
13039 Obj := First_Entity (Entity (Identifier (E_Call)));
13040 while Present (Obj) loop
13041 Set_Scope (Obj, Entity (Identifier (N)));
13046 Reset_Scopes_To (N, Entity (Identifier (N)));
13047 end Expand_N_Timed_Entry_Call;
13049 ----------------------------------------
13050 -- Expand_Protected_Body_Declarations --
13051 ----------------------------------------
13053 procedure Expand_Protected_Body_Declarations
13055 Spec_Id : Entity_Id)
13058 if No_Run_Time_Mode then
13059 Error_Msg_CRT ("protected body", N);
13062 elsif Expander_Active then
13064 -- Associate discriminals with the first subprogram or entry body to
13067 if Present (First_Protected_Operation (Declarations (N))) then
13068 Set_Discriminals (Parent (Spec_Id));
13071 end Expand_Protected_Body_Declarations;
13073 -------------------------
13074 -- External_Subprogram --
13075 -------------------------
13077 function External_Subprogram (E : Entity_Id) return Entity_Id is
13078 Subp : constant Entity_Id := Protected_Body_Subprogram (E);
13081 -- The internal and external subprograms follow each other on the entity
13082 -- chain. Note that previously private operations had no separate
13083 -- external subprogram. We now create one in all cases, because a
13084 -- private operation may actually appear in an external call, through
13085 -- a 'Access reference used for a callback.
13087 -- If the operation is a function that returns an anonymous access type,
13088 -- the corresponding itype appears before the operation, and must be
13091 -- This mechanism is fragile, there should be a real link between the
13092 -- two versions of the operation, but there is no place to put it ???
13094 if Is_Access_Type (Next_Entity (Subp)) then
13095 return Next_Entity (Next_Entity (Subp));
13097 return Next_Entity (Subp);
13099 end External_Subprogram;
13101 ------------------------------
13102 -- Extract_Dispatching_Call --
13103 ------------------------------
13105 procedure Extract_Dispatching_Call
13107 Call_Ent : out Entity_Id;
13108 Object : out Entity_Id;
13109 Actuals : out List_Id;
13110 Formals : out List_Id)
13112 Call_Nam : Node_Id;
13115 pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
13117 if Present (Original_Node (N)) then
13118 Call_Nam := Name (Original_Node (N));
13120 Call_Nam := Name (N);
13123 -- Retrieve the name of the dispatching procedure. It contains the
13124 -- dispatch table slot number.
13127 case Nkind (Call_Nam) is
13128 when N_Identifier =>
13131 when N_Selected_Component =>
13132 Call_Nam := Selector_Name (Call_Nam);
13135 raise Program_Error;
13139 Actuals := Parameter_Associations (N);
13140 Call_Ent := Entity (Call_Nam);
13141 Formals := Parameter_Specifications (Parent (Call_Ent));
13142 Object := First (Actuals);
13144 if Present (Original_Node (Object)) then
13145 Object := Original_Node (Object);
13148 -- If the type of the dispatching object is an access type then return
13149 -- an explicit dereference of a copy of the object, and note that this
13150 -- is the controlling actual of the call.
13152 if Is_Access_Type (Etype (Object)) then
13154 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object));
13156 Set_Is_Controlling_Actual (Object);
13158 end Extract_Dispatching_Call;
13160 -------------------
13161 -- Extract_Entry --
13162 -------------------
13164 procedure Extract_Entry
13166 Concval : out Node_Id;
13167 Ename : out Node_Id;
13168 Index : out Node_Id)
13170 Nam : constant Node_Id := Name (N);
13173 -- For a simple entry, the name is a selected component, with the
13174 -- prefix being the task value, and the selector being the entry.
13176 if Nkind (Nam) = N_Selected_Component then
13177 Concval := Prefix (Nam);
13178 Ename := Selector_Name (Nam);
13181 -- For a member of an entry family, the name is an indexed component
13182 -- where the prefix is a selected component, whose prefix in turn is
13183 -- the task value, and whose selector is the entry family. The single
13184 -- expression in the expressions list of the indexed component is the
13185 -- subscript for the family.
13187 else pragma Assert (Nkind (Nam) = N_Indexed_Component);
13188 Concval := Prefix (Prefix (Nam));
13189 Ename := Selector_Name (Prefix (Nam));
13190 Index := First (Expressions (Nam));
13193 -- Through indirection, the type may actually be a limited view of a
13194 -- concurrent type. When compiling a call, the non-limited view of the
13195 -- type is visible.
13197 if From_Limited_With (Etype (Concval)) then
13198 Set_Etype (Concval, Non_Limited_View (Etype (Concval)));
13202 -------------------
13203 -- Family_Offset --
13204 -------------------
13206 function Family_Offset
13211 Cap : Boolean) return Node_Id
13217 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
13218 -- If one of the bounds is a reference to a discriminant, replace with
13219 -- corresponding discriminal of type. Within the body of a task retrieve
13220 -- the renamed discriminant by simple visibility, using its generated
13221 -- name. Within a protected object, find the original discriminant and
13222 -- replace it with the discriminal of the current protected operation.
13224 ------------------------------
13225 -- Convert_Discriminant_Ref --
13226 ------------------------------
13228 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
13229 Loc : constant Source_Ptr := Sloc (Bound);
13234 if Is_Entity_Name (Bound)
13235 and then Ekind (Entity (Bound)) = E_Discriminant
13237 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then
13238 B := Make_Identifier (Loc, Chars (Entity (Bound)));
13239 Find_Direct_Name (B);
13241 elsif Is_Protected_Type (Ttyp) then
13242 D := First_Discriminant (Ttyp);
13243 while Chars (D) /= Chars (Entity (Bound)) loop
13244 Next_Discriminant (D);
13247 B := New_Occurrence_Of (Discriminal (D), Loc);
13250 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
13253 elsif Nkind (Bound) = N_Attribute_Reference then
13257 B := New_Copy_Tree (Bound);
13261 Make_Attribute_Reference (Loc,
13262 Attribute_Name => Name_Pos,
13263 Prefix => New_Occurrence_Of (Etype (Bound), Loc),
13264 Expressions => New_List (B));
13265 end Convert_Discriminant_Ref;
13267 -- Start of processing for Family_Offset
13270 Real_Hi := Convert_Discriminant_Ref (Hi);
13271 Real_Lo := Convert_Discriminant_Ref (Lo);
13274 if Is_Task_Type (Ttyp) then
13275 Ityp := RTE (RE_Task_Entry_Index);
13277 Ityp := RTE (RE_Protected_Entry_Index);
13281 Make_Attribute_Reference (Loc,
13282 Prefix => New_Occurrence_Of (Ityp, Loc),
13283 Attribute_Name => Name_Min,
13284 Expressions => New_List (
13286 Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
13289 Make_Attribute_Reference (Loc,
13290 Prefix => New_Occurrence_Of (Ityp, Loc),
13291 Attribute_Name => Name_Max,
13292 Expressions => New_List (
13294 Make_Integer_Literal (Loc, -Entry_Family_Bound)));
13297 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
13304 function Family_Size
13309 Cap : Boolean) return Node_Id
13314 if Is_Task_Type (Ttyp) then
13315 Ityp := RTE (RE_Task_Entry_Index);
13317 Ityp := RTE (RE_Protected_Entry_Index);
13321 Make_Attribute_Reference (Loc,
13322 Prefix => New_Occurrence_Of (Ityp, Loc),
13323 Attribute_Name => Name_Max,
13324 Expressions => New_List (
13326 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
13327 Right_Opnd => Make_Integer_Literal (Loc, 1)),
13328 Make_Integer_Literal (Loc, 0)));
13331 ----------------------------
13332 -- Find_Enclosing_Context --
13333 ----------------------------
13335 procedure Find_Enclosing_Context
13337 Context : out Node_Id;
13338 Context_Id : out Entity_Id;
13339 Context_Decls : out List_Id)
13342 -- Traverse the parent chain looking for an enclosing body, block,
13343 -- package or return statement.
13345 Context := Parent (N);
13346 while Present (Context) loop
13347 if Nkind_In (Context, N_Entry_Body,
13348 N_Extended_Return_Statement,
13350 N_Package_Declaration,
13356 -- Do not consider block created to protect a list of statements with
13357 -- an Abort_Defer / Abort_Undefer_Direct pair.
13359 elsif Nkind (Context) = N_Block_Statement
13360 and then not Is_Abort_Block (Context)
13365 Context := Parent (Context);
13368 pragma Assert (Present (Context));
13370 -- Extract the constituents of the context
13372 if Nkind (Context) = N_Extended_Return_Statement then
13373 Context_Decls := Return_Object_Declarations (Context);
13374 Context_Id := Return_Statement_Entity (Context);
13376 -- Package declarations and bodies use a common library-level activation
13377 -- chain or task master, therefore return the package declaration as the
13378 -- proper carrier for the appropriate flag.
13380 elsif Nkind (Context) = N_Package_Body then
13381 Context_Decls := Declarations (Context);
13382 Context_Id := Corresponding_Spec (Context);
13383 Context := Parent (Context_Id);
13385 if Nkind (Context) = N_Defining_Program_Unit_Name then
13386 Context := Parent (Parent (Context));
13388 Context := Parent (Context);
13391 elsif Nkind (Context) = N_Package_Declaration then
13392 Context_Decls := Visible_Declarations (Specification (Context));
13393 Context_Id := Defining_Unit_Name (Specification (Context));
13395 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13396 Context_Id := Defining_Identifier (Context_Id);
13400 if Nkind (Context) = N_Block_Statement then
13401 Context_Id := Entity (Identifier (Context));
13403 elsif Nkind (Context) = N_Entry_Body then
13404 Context_Id := Defining_Identifier (Context);
13406 elsif Nkind (Context) = N_Subprogram_Body then
13407 if Present (Corresponding_Spec (Context)) then
13408 Context_Id := Corresponding_Spec (Context);
13410 Context_Id := Defining_Unit_Name (Specification (Context));
13412 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13413 Context_Id := Defining_Identifier (Context_Id);
13417 elsif Nkind (Context) = N_Task_Body then
13418 Context_Id := Corresponding_Spec (Context);
13421 raise Program_Error;
13424 Context_Decls := Declarations (Context);
13427 pragma Assert (Present (Context_Id));
13428 pragma Assert (Present (Context_Decls));
13429 end Find_Enclosing_Context;
13431 -----------------------
13432 -- Find_Master_Scope --
13433 -----------------------
13435 function Find_Master_Scope (E : Entity_Id) return Entity_Id is
13439 -- In Ada 2005, the master is the innermost enclosing scope that is not
13440 -- transient. If the enclosing block is the rewriting of a call or the
13441 -- scope is an extended return statement this is valid master. The
13442 -- master in an extended return is only used within the return, and is
13443 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13444 -- now before that overwriting occurs.
13448 if Ada_Version >= Ada_2005 then
13449 while Is_Internal (S) loop
13450 if Nkind (Parent (S)) = N_Block_Statement
13452 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
13456 elsif Ekind (S) = E_Return_Statement then
13466 end Find_Master_Scope;
13468 -------------------------------
13469 -- First_Protected_Operation --
13470 -------------------------------
13472 function First_Protected_Operation (D : List_Id) return Node_Id is
13473 First_Op : Node_Id;
13476 First_Op := First (D);
13477 while Present (First_Op)
13478 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body)
13484 end First_Protected_Operation;
13486 ---------------------------------------
13487 -- Install_Private_Data_Declarations --
13488 ---------------------------------------
13490 procedure Install_Private_Data_Declarations
13492 Spec_Id : Entity_Id;
13493 Conc_Typ : Entity_Id;
13494 Body_Nod : Node_Id;
13496 Barrier : Boolean := False;
13497 Family : Boolean := False)
13499 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ);
13502 Insert_Node : Node_Id := Empty;
13503 Obj_Ent : Entity_Id;
13505 procedure Add (Decl : Node_Id);
13506 -- Add a single declaration after Insert_Node. If this is the first
13507 -- addition, Decl is added to the front of Decls and it becomes the
13510 function Replace_Bound (Bound : Node_Id) return Node_Id;
13511 -- The bounds of an entry index may depend on discriminants, create a
13512 -- reference to the corresponding prival. Otherwise return a duplicate
13513 -- of the original bound.
13519 procedure Add (Decl : Node_Id) is
13521 if No (Insert_Node) then
13522 Prepend_To (Decls, Decl);
13524 Insert_After (Insert_Node, Decl);
13527 Insert_Node := Decl;
13530 -------------------
13531 -- Replace_Bound --
13532 -------------------
13534 function Replace_Bound (Bound : Node_Id) return Node_Id is
13536 if Nkind (Bound) = N_Identifier
13537 and then Is_Discriminal (Entity (Bound))
13539 return Make_Identifier (Loc, Chars (Entity (Bound)));
13541 return Duplicate_Subexpr (Bound);
13545 -- Start of processing for Install_Private_Data_Declarations
13548 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13549 -- formal parameter _O, _object or _task depending on the context.
13551 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ);
13553 -- Special processing of _O for barrier functions, protected entries
13560 (Ekind (Spec_Id) = E_Entry
13561 or else Ekind (Spec_Id) = E_Entry_Family))
13564 Conc_Rec : constant Entity_Id :=
13565 Corresponding_Record_Type (Conc_Typ);
13566 Typ_Id : constant Entity_Id :=
13567 Make_Defining_Identifier (Loc,
13568 New_External_Name (Chars (Conc_Rec), 'P'));
13571 -- type prot_typVP is access prot_typV;
13574 Make_Full_Type_Declaration (Loc,
13575 Defining_Identifier => Typ_Id,
13577 Make_Access_To_Object_Definition (Loc,
13578 Subtype_Indication =>
13579 New_Occurrence_Of (Conc_Rec, Loc)));
13583 -- _object : prot_typVP := prot_typV (_O);
13586 Make_Object_Declaration (Loc,
13587 Defining_Identifier =>
13588 Make_Defining_Identifier (Loc, Name_uObject),
13589 Object_Definition => New_Occurrence_Of (Typ_Id, Loc),
13591 Unchecked_Convert_To (Typ_Id,
13592 New_Occurrence_Of (Obj_Ent, Loc)));
13595 -- Set the reference to the concurrent object
13597 Obj_Ent := Defining_Identifier (Decl);
13601 -- Step 2: Create the Protection object and build its declaration for
13602 -- any protected entry (family) of subprogram. Note for the lock-free
13603 -- implementation, the Protection object is not needed anymore.
13605 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then
13607 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
13611 Set_Protection_Object (Spec_Id, Prot_Ent);
13613 -- Determine the proper protection type
13615 if Has_Attach_Handler (Conc_Typ)
13616 and then not Restricted_Profile
13618 Prot_Typ := RE_Static_Interrupt_Protection;
13620 elsif Has_Interrupt_Handler (Conc_Typ)
13621 and then not Restriction_Active (No_Dynamic_Attachment)
13623 Prot_Typ := RE_Dynamic_Interrupt_Protection;
13626 case Corresponding_Runtime_Package (Conc_Typ) is
13627 when System_Tasking_Protected_Objects_Entries =>
13628 Prot_Typ := RE_Protection_Entries;
13630 when System_Tasking_Protected_Objects_Single_Entry =>
13631 Prot_Typ := RE_Protection_Entry;
13633 when System_Tasking_Protected_Objects =>
13634 Prot_Typ := RE_Protection;
13637 raise Program_Error;
13642 -- conc_typR : protection_typ renames _object._object;
13645 Make_Object_Renaming_Declaration (Loc,
13646 Defining_Identifier => Prot_Ent,
13648 New_Occurrence_Of (RTE (Prot_Typ), Loc),
13650 Make_Selected_Component (Loc,
13651 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13652 Selector_Name => Make_Identifier (Loc, Name_uObject)));
13657 -- Step 3: Add discriminant renamings (if any)
13659 if Has_Discriminants (Conc_Typ) then
13664 D := First_Discriminant (Conc_Typ);
13665 while Present (D) loop
13667 -- Adjust the source location
13669 Set_Sloc (Discriminal (D), Loc);
13672 -- discr_name : discr_typ renames _object.discr_name;
13674 -- discr_name : discr_typ renames _task.discr_name;
13677 Make_Object_Renaming_Declaration (Loc,
13678 Defining_Identifier => Discriminal (D),
13679 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
13681 Make_Selected_Component (Loc,
13682 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13683 Selector_Name => Make_Identifier (Loc, Chars (D))));
13686 -- Set debug info needed on this renaming declaration even
13687 -- though it does not come from source, so that the debugger
13688 -- will get the right information for these generated names.
13690 Set_Debug_Info_Needed (Discriminal (D));
13692 Next_Discriminant (D);
13697 -- Step 4: Add private component renamings (if any)
13699 if Is_Protected then
13700 Def := Protected_Definition (Parent (Conc_Typ));
13702 if Present (Private_Declarations (Def)) then
13705 Comp_Id : Entity_Id;
13706 Decl_Id : Entity_Id;
13709 Comp := First (Private_Declarations (Def));
13710 while Present (Comp) loop
13711 if Nkind (Comp) = N_Component_Declaration then
13712 Comp_Id := Defining_Identifier (Comp);
13714 Make_Defining_Identifier (Loc, Chars (Comp_Id));
13716 -- Minimal decoration
13718 if Ekind (Spec_Id) = E_Function then
13719 Set_Ekind (Decl_Id, E_Constant);
13721 Set_Ekind (Decl_Id, E_Variable);
13724 Set_Prival (Comp_Id, Decl_Id);
13725 Set_Prival_Link (Decl_Id, Comp_Id);
13726 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
13727 Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id));
13730 -- comp_name : comp_typ renames _object.comp_name;
13733 Make_Object_Renaming_Declaration (Loc,
13734 Defining_Identifier => Decl_Id,
13736 New_Occurrence_Of (Etype (Comp_Id), Loc),
13738 Make_Selected_Component (Loc,
13740 New_Occurrence_Of (Obj_Ent, Loc),
13742 Make_Identifier (Loc, Chars (Comp_Id))));
13752 -- Step 5: Add the declaration of the entry index and the associated
13753 -- type for barrier functions and entry families.
13755 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then
13757 E : constant Entity_Id := Index_Object (Spec_Id);
13758 Index : constant Entity_Id :=
13759 Defining_Identifier
13760 (Entry_Index_Specification
13761 (Entry_Body_Formal_Part (Body_Nod)));
13762 Index_Con : constant Entity_Id :=
13763 Make_Defining_Identifier (Loc, Chars (Index));
13765 Index_Typ : Entity_Id;
13769 -- Minimal decoration
13771 Set_Ekind (Index_Con, E_Constant);
13772 Set_Entry_Index_Constant (Index, Index_Con);
13773 Set_Discriminal_Link (Index_Con, Index);
13775 -- Retrieve the bounds of the entry family
13777 High := Type_High_Bound (Etype (Index));
13778 Low := Type_Low_Bound (Etype (Index));
13780 -- In the simple case the entry family is given by a subtype mark
13781 -- and the index constant has the same type.
13783 if Is_Entity_Name (Original_Node (
13784 Discrete_Subtype_Definition (Parent (Index))))
13786 Index_Typ := Etype (Index);
13788 -- Otherwise a new subtype declaration is required
13791 High := Replace_Bound (High);
13792 Low := Replace_Bound (Low);
13794 Index_Typ := Make_Temporary (Loc, 'J');
13797 -- subtype Jnn is <Etype of Index> range Low .. High;
13800 Make_Subtype_Declaration (Loc,
13801 Defining_Identifier => Index_Typ,
13802 Subtype_Indication =>
13803 Make_Subtype_Indication (Loc,
13805 New_Occurrence_Of (Base_Type (Etype (Index)), Loc),
13807 Make_Range_Constraint (Loc,
13808 Range_Expression =>
13809 Make_Range (Loc, Low, High))));
13813 Set_Etype (Index_Con, Index_Typ);
13815 -- Create the object which designates the index:
13816 -- J : constant Jnn :=
13817 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13819 -- where Jnn is the subtype created above or the original type of
13820 -- the index, _E is a formal of the protected body subprogram and
13821 -- <index expr> is the index of the first family member.
13824 Make_Object_Declaration (Loc,
13825 Defining_Identifier => Index_Con,
13826 Constant_Present => True,
13827 Object_Definition =>
13828 New_Occurrence_Of (Index_Typ, Loc),
13831 Make_Attribute_Reference (Loc,
13833 New_Occurrence_Of (Index_Typ, Loc),
13834 Attribute_Name => Name_Val,
13836 Expressions => New_List (
13840 Make_Op_Subtract (Loc,
13841 Left_Opnd => New_Occurrence_Of (E, Loc),
13843 Entry_Index_Expression (Loc,
13844 Defining_Identifier (Body_Nod),
13848 Make_Attribute_Reference (Loc,
13850 New_Occurrence_Of (Index_Typ, Loc),
13851 Attribute_Name => Name_Pos,
13852 Expressions => New_List (
13853 Make_Attribute_Reference (Loc,
13855 New_Occurrence_Of (Index_Typ, Loc),
13856 Attribute_Name => Name_First)))))));
13860 end Install_Private_Data_Declarations;
13862 ---------------------------------
13863 -- Is_Potentially_Large_Family --
13864 ---------------------------------
13866 function Is_Potentially_Large_Family
13867 (Base_Index : Entity_Id;
13868 Conctyp : Entity_Id;
13870 Hi : Node_Id) return Boolean
13873 return Scope (Base_Index) = Standard_Standard
13874 and then Base_Index = Base_Type (Standard_Integer)
13875 and then Has_Discriminants (Conctyp)
13877 Present (Discriminant_Default_Value (First_Discriminant (Conctyp)))
13879 (Denotes_Discriminant (Lo, True)
13881 Denotes_Discriminant (Hi, True));
13882 end Is_Potentially_Large_Family;
13884 -------------------------------------
13885 -- Is_Private_Primitive_Subprogram --
13886 -------------------------------------
13888 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
13891 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
13892 and then Is_Private_Primitive (Id);
13893 end Is_Private_Primitive_Subprogram;
13899 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is
13900 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id);
13901 Formal : Entity_Id;
13904 Formal := First_Formal (Bod_Subp);
13905 while Present (Formal) loop
13907 -- Look for formal parameter _E
13909 if Chars (Formal) = Name_uE then
13913 Next_Formal (Formal);
13916 -- A protected body subprogram should always have the parameter in
13919 raise Program_Error;
13922 --------------------------------
13923 -- Make_Initialize_Protection --
13924 --------------------------------
13926 function Make_Initialize_Protection
13927 (Protect_Rec : Entity_Id) return List_Id
13929 Loc : constant Source_Ptr := Sloc (Protect_Rec);
13932 Ptyp : constant Node_Id :=
13933 Corresponding_Concurrent_Type (Protect_Rec);
13935 L : constant List_Id := New_List;
13936 Has_Entry : constant Boolean := Has_Entries (Ptyp);
13937 Prio_Type : Entity_Id;
13938 Prio_Var : Entity_Id := Empty;
13939 Restricted : constant Boolean := Restricted_Profile;
13942 -- We may need two calls to properly initialize the object, one to
13943 -- Initialize_Protection, and possibly one to Install_Handlers if we
13944 -- have a pragma Attach_Handler.
13946 -- Get protected declaration. In the case of a task type declaration,
13947 -- this is simply the parent of the protected type entity. In the single
13948 -- protected object declaration, this parent will be the implicit type,
13949 -- and we can find the corresponding single protected object declaration
13950 -- by searching forward in the declaration list in the tree.
13952 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13953 -- of this type should have been removed during semantic analysis.
13955 Pdec := Parent (Ptyp);
13956 while not Nkind_In (Pdec, N_Protected_Type_Declaration,
13957 N_Single_Protected_Declaration)
13962 -- Build the parameter list for the call. Note that _Init is the name
13963 -- of the formal for the object to be initialized, which is the task
13964 -- value record itself.
13968 -- For lock-free implementation, skip initializations of the Protection
13971 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
13973 -- Object parameter. This is a pointer to the object of type
13974 -- Protection used by the GNARL to control the protected object.
13977 Make_Attribute_Reference (Loc,
13979 Make_Selected_Component (Loc,
13980 Prefix => Make_Identifier (Loc, Name_uInit),
13981 Selector_Name => Make_Identifier (Loc, Name_uObject)),
13982 Attribute_Name => Name_Unchecked_Access));
13984 -- Priority parameter. Set to Unspecified_Priority unless there is a
13985 -- Priority rep item, in which case we take the value from the pragma
13986 -- or attribute definition clause, or there is an Interrupt_Priority
13987 -- rep item and no Priority rep item, and we set the ceiling to
13988 -- Interrupt_Priority'Last, an implementation-defined value, see
13991 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then
13993 Prio_Clause : constant Node_Id :=
13995 (Ptyp, Name_Priority, Check_Parents => False);
14002 if Nkind (Prio_Clause) = N_Pragma then
14005 (First (Pragma_Argument_Associations (Prio_Clause)));
14007 -- Get_Rep_Item returns either priority pragma
14009 if Pragma_Name (Prio_Clause) = Name_Priority then
14010 Prio_Type := RTE (RE_Any_Priority);
14012 Prio_Type := RTE (RE_Interrupt_Priority);
14015 -- Attribute definition clause Priority
14018 if Chars (Prio_Clause) = Name_Priority then
14019 Prio_Type := RTE (RE_Any_Priority);
14021 Prio_Type := RTE (RE_Interrupt_Priority);
14024 Prio := Expression (Prio_Clause);
14027 -- Always create a locale variable to capture the priority.
14028 -- The priority is also passed to Install_Restriced_Handlers.
14029 -- Note that it is really necessary to create this variable
14030 -- explicitly. It might be thought that removing side effects
14031 -- would the appropriate approach, but that could generate
14032 -- declarations improperly placed in the enclosing scope.
14034 Prio_Var := Make_Temporary (Loc, 'R', Prio);
14036 Make_Object_Declaration (Loc,
14037 Defining_Identifier => Prio_Var,
14038 Object_Definition => New_Occurrence_Of (Prio_Type, Loc),
14039 Expression => Relocate_Node (Prio)));
14041 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
14044 -- When no priority is specified but an xx_Handler pragma is, we
14045 -- default to System.Interrupts.Default_Interrupt_Priority, see
14048 elsif Has_Attach_Handler (Ptyp)
14049 or else Has_Interrupt_Handler (Ptyp)
14052 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc));
14054 -- Normal case, no priority or xx_Handler specified, default priority
14058 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14061 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
14063 if Restricted_Profile and Task_Dispatching_Policy = 'E' then
14064 Deadline_Floor : declare
14065 Item : constant Node_Id :=
14067 (Ptyp, Name_Deadline_Floor, Check_Parents => False);
14069 Deadline : Node_Id;
14072 if Present (Item) then
14074 -- Pragma Deadline_Floor
14076 if Nkind (Item) = N_Pragma then
14079 (First (Pragma_Argument_Associations (Item)));
14081 -- Attribute definition clause Deadline_Floor
14085 (Nkind (Item) = N_Attribute_Definition_Clause);
14087 Deadline := Expression (Item);
14090 Append_To (Args, Deadline);
14092 -- Unusual case: default deadline
14096 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14098 end Deadline_Floor;
14101 -- Test for Compiler_Info parameter. This parameter allows entry body
14102 -- procedures and barrier functions to be called from the runtime. It
14103 -- is a pointer to the record generated by the compiler to represent
14104 -- the protected object.
14106 -- A protected type without entries that covers an interface and
14107 -- overrides the abstract routines with protected procedures is
14108 -- considered equivalent to a protected type with entries in the
14109 -- context of dispatching select statements.
14111 -- Protected types with interrupt handlers (when not using a
14112 -- restricted profile) are also considered equivalent to protected
14113 -- types with entries.
14115 -- The types which are used (Static_Interrupt_Protection and
14116 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14119 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
14121 Called_Subp : RE_Id;
14125 when System_Tasking_Protected_Objects_Entries =>
14126 Called_Subp := RE_Initialize_Protection_Entries;
14128 -- Argument Compiler_Info
14131 Make_Attribute_Reference (Loc,
14132 Prefix => Make_Identifier (Loc, Name_uInit),
14133 Attribute_Name => Name_Address));
14135 when System_Tasking_Protected_Objects_Single_Entry =>
14136 Called_Subp := RE_Initialize_Protection_Entry;
14138 -- Argument Compiler_Info
14141 Make_Attribute_Reference (Loc,
14142 Prefix => Make_Identifier (Loc, Name_uInit),
14143 Attribute_Name => Name_Address));
14145 when System_Tasking_Protected_Objects =>
14146 Called_Subp := RE_Initialize_Protection;
14149 raise Program_Error;
14152 -- Entry_Queue_Maxes parameter. This is an access to an array of
14153 -- naturals representing the entry queue maximums for each entry
14154 -- in the protected type. Zero represents no max. The access is
14155 -- null if there is no limit for all entries (usual case).
14158 and then Pkg_Id = System_Tasking_Protected_Objects_Entries
14160 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then
14162 Make_Attribute_Reference (Loc,
14165 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
14166 Attribute_Name => Name_Unrestricted_Access));
14168 Append_To (Args, Make_Null (Loc));
14171 -- Edge cases exist where entry initialization functions are
14172 -- called, but no entries exist, so null is appended.
14174 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
14175 Append_To (Args, Make_Null (Loc));
14178 -- Entry_Bodies parameter. This is a pointer to an array of
14179 -- pointers to the entry body procedures and barrier functions of
14180 -- the object. If the protected type has no entries this object
14181 -- will not exist, in this case, pass a null (it can happen when
14182 -- there are protected interrupt handlers or interfaces).
14185 P_Arr := Entry_Bodies_Array (Ptyp);
14187 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14188 -- multiple entries).
14191 Make_Attribute_Reference (Loc,
14192 Prefix => New_Occurrence_Of (P_Arr, Loc),
14193 Attribute_Name => Name_Unrestricted_Access));
14195 if Pkg_Id = System_Tasking_Protected_Objects_Entries then
14197 -- Find index mapping function (clumsy but ok for now)
14199 while Ekind (P_Arr) /= E_Function loop
14200 Next_Entity (P_Arr);
14204 Make_Attribute_Reference (Loc,
14205 Prefix => New_Occurrence_Of (P_Arr, Loc),
14206 Attribute_Name => Name_Unrestricted_Access));
14209 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
14211 -- This is the case where we have a protected object with
14212 -- interfaces and no entries, and the single entry restriction
14213 -- is in effect. We pass a null pointer for the entry
14214 -- parameter because there is no actual entry.
14216 Append_To (Args, Make_Null (Loc));
14218 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
14220 -- This is the case where we have a protected object with no
14222 -- - either interrupt handlers with non restricted profile,
14224 -- Note that the types which are used for interrupt handlers
14225 -- (Static/Dynamic_Interrupt_Protection) are derived from
14226 -- Protection_Entries. We pass two null pointers because there
14227 -- is no actual entry, and the initialization procedure needs
14228 -- both Entry_Bodies and Find_Body_Index.
14230 Append_To (Args, Make_Null (Loc));
14231 Append_To (Args, Make_Null (Loc));
14235 Make_Procedure_Call_Statement (Loc,
14237 New_Occurrence_Of (RTE (Called_Subp), Loc),
14238 Parameter_Associations => Args));
14242 if Has_Attach_Handler (Ptyp) then
14244 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14245 -- make the following call:
14247 -- Install_Handlers (_object,
14248 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14250 -- or, in the case of Ravenscar:
14252 -- Install_Restricted_Handlers
14253 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14256 Args : constant List_Id := New_List;
14257 Table : constant List_Id := New_List;
14258 Ritem : Node_Id := First_Rep_Item (Ptyp);
14261 -- Build the Priority parameter (only for ravenscar)
14265 -- Priority comes from a pragma
14267 if Present (Prio_Var) then
14268 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
14270 -- Priority is the default one
14275 (RTE (RE_Default_Interrupt_Priority), Loc));
14279 -- Build the Attach_Handler table argument
14281 while Present (Ritem) loop
14282 if Nkind (Ritem) = N_Pragma
14283 and then Pragma_Name (Ritem) = Name_Attach_Handler
14286 Handler : constant Node_Id :=
14287 First (Pragma_Argument_Associations (Ritem));
14289 Interrupt : constant Node_Id := Next (Handler);
14290 Expr : constant Node_Id := Expression (Interrupt);
14294 Make_Aggregate (Loc, Expressions => New_List (
14295 Unchecked_Convert_To
14296 (RTE (RE_System_Interrupt_Id), Expr),
14297 Make_Attribute_Reference (Loc,
14299 Make_Selected_Component (Loc,
14301 Make_Identifier (Loc, Name_uInit),
14303 Duplicate_Subexpr_No_Checks
14304 (Expression (Handler))),
14305 Attribute_Name => Name_Access))));
14309 Next_Rep_Item (Ritem);
14312 -- Append the table argument we just built
14314 Append_To (Args, Make_Aggregate (Loc, Table));
14316 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14317 -- call to the statements.
14320 -- Call a simplified version of Install_Handlers to be used
14321 -- when the Ravenscar restrictions are in effect
14322 -- (Install_Restricted_Handlers).
14325 Make_Procedure_Call_Statement (Loc,
14328 (RTE (RE_Install_Restricted_Handlers), Loc),
14329 Parameter_Associations => Args));
14332 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
14334 -- First, prepends the _object argument
14337 Make_Attribute_Reference (Loc,
14339 Make_Selected_Component (Loc,
14340 Prefix => Make_Identifier (Loc, Name_uInit),
14342 Make_Identifier (Loc, Name_uObject)),
14343 Attribute_Name => Name_Unchecked_Access));
14346 -- Then, insert call to Install_Handlers
14349 Make_Procedure_Call_Statement (Loc,
14351 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc),
14352 Parameter_Associations => Args));
14358 end Make_Initialize_Protection;
14360 ---------------------------
14361 -- Make_Task_Create_Call --
14362 ---------------------------
14364 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
14365 Loc : constant Source_Ptr := Sloc (Task_Rec);
14375 Ttyp := Corresponding_Concurrent_Type (Task_Rec);
14376 Tnam := Chars (Ttyp);
14378 -- Get task declaration. In the case of a task type declaration, this is
14379 -- simply the parent of the task type entity. In the single task
14380 -- declaration, this parent will be the implicit type, and we can find
14381 -- the corresponding single task declaration by searching forward in the
14382 -- declaration list in the tree.
14384 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14385 -- this type should have been removed during semantic analysis.
14387 Tdec := Parent (Ttyp);
14388 while not Nkind_In (Tdec, N_Task_Type_Declaration,
14389 N_Single_Task_Declaration)
14394 -- Now we can find the task definition from this declaration
14396 Tdef := Task_Definition (Tdec);
14398 -- Build the parameter list for the call. Note that _Init is the name
14399 -- of the formal for the object to be initialized, which is the task
14400 -- value record itself.
14404 -- Priority parameter. Set to Unspecified_Priority unless there is a
14405 -- Priority rep item, in which case we take the value from the rep item.
14406 -- Not used on Ravenscar_EDF profile.
14408 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then
14409 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
14411 Make_Selected_Component (Loc,
14412 Prefix => Make_Identifier (Loc, Name_uInit),
14413 Selector_Name => Make_Identifier (Loc, Name_uPriority)));
14416 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14420 -- Optional Stack parameter
14422 if Restricted_Profile then
14424 -- If the stack has been preallocated by the expander then
14425 -- pass its address. Otherwise, pass a null address.
14427 if Preallocated_Stacks_On_Target then
14429 Make_Attribute_Reference (Loc,
14431 Make_Selected_Component (Loc,
14432 Prefix => Make_Identifier (Loc, Name_uInit),
14433 Selector_Name => Make_Identifier (Loc, Name_uStack)),
14434 Attribute_Name => Name_Address));
14438 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
14442 -- Size parameter. If no Storage_Size pragma is present, then
14443 -- the size is taken from the taskZ variable for the type, which
14444 -- is either Unspecified_Size, or has been reset by the use of
14445 -- a Storage_Size attribute definition clause. If a pragma is
14446 -- present, then the size is taken from the _Size field of the
14447 -- task value record, which was set from the pragma value.
14449 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then
14451 Make_Selected_Component (Loc,
14452 Prefix => Make_Identifier (Loc, Name_uInit),
14453 Selector_Name => Make_Identifier (Loc, Name_uSize)));
14457 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc));
14460 -- Secondary_Stack parameter used for restricted profiles
14462 if Restricted_Profile then
14464 -- If the secondary stack has been allocated by the expander then
14465 -- pass its access pointer. Otherwise, pass null.
14467 if Create_Secondary_Stack_For_Task (Ttyp) then
14469 Make_Attribute_Reference (Loc,
14471 Make_Selected_Component (Loc,
14472 Prefix => Make_Identifier (Loc, Name_uInit),
14474 Make_Identifier (Loc, Name_uSecondary_Stack)),
14475 Attribute_Name => Name_Unrestricted_Access));
14478 Append_To (Args, Make_Null (Loc));
14482 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
14483 -- is a Secondary_Stack_Size pragma, in which case take the value from
14484 -- the pragma. If the restriction No_Secondary_Stack is active then a
14485 -- size of 0 is passed regardless to prevent the allocation of the
14488 if Restriction_Active (No_Secondary_Stack) then
14489 Append_To (Args, Make_Integer_Literal (Loc, 0));
14491 elsif Has_Rep_Pragma
14492 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False)
14495 Make_Selected_Component (Loc,
14496 Prefix => Make_Identifier (Loc, Name_uInit),
14498 Make_Identifier (Loc, Name_uSecondary_Stack_Size)));
14502 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
14505 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14506 -- Task_Info pragma, in which case we take the value from the pragma.
14508 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then
14510 Make_Selected_Component (Loc,
14511 Prefix => Make_Identifier (Loc, Name_uInit),
14512 Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
14516 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc));
14519 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14520 -- in which case we take the value from the rep item. The parameter is
14521 -- passed as an Integer because in the case of unspecified CPU the
14522 -- value is not in the range of CPU_Range.
14524 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then
14526 Convert_To (Standard_Integer,
14527 Make_Selected_Component (Loc,
14528 Prefix => Make_Identifier (Loc, Name_uInit),
14529 Selector_Name => Make_Identifier (Loc, Name_uCPU))));
14532 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc));
14535 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then
14537 -- Deadline parameter. If no Relative_Deadline pragma is present,
14538 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14539 -- the deadline is taken from the _Relative_Deadline field of the
14540 -- task value record, which was set from the pragma value. Note that
14541 -- this parameter must not be generated for the restricted profiles
14542 -- since Ravenscar does not allow deadlines.
14544 -- Case where pragma Relative_Deadline applies: use given value
14546 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
14548 Make_Selected_Component (Loc,
14549 Prefix => Make_Identifier (Loc, Name_uInit),
14551 Make_Identifier (Loc, Name_uRelative_Deadline)));
14553 -- No pragma Relative_Deadline apply to the task
14557 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14561 if not Restricted_Profile then
14563 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14564 -- present, then the dispatching domain is null. If a rep item is
14565 -- present, then the dispatching domain is taken from the
14566 -- _Dispatching_Domain field of the task value record, which was set
14567 -- from the rep item value.
14569 -- Case where Dispatching_Domain rep item applies: use given value
14572 (Ttyp, Name_Dispatching_Domain, Check_Parents => False)
14575 Make_Selected_Component (Loc,
14577 Make_Identifier (Loc, Name_uInit),
14579 Make_Identifier (Loc, Name_uDispatching_Domain)));
14581 -- No pragma or aspect Dispatching_Domain applies to the task
14584 Append_To (Args, Make_Null (Loc));
14587 -- Number of entries. This is an expression of the form:
14589 -- n + _Init.a'Length + _Init.a'B'Length + ...
14591 -- where a,b... are the entry family names for the task definition
14594 Build_Entry_Count_Expression
14599 (Parent (Corresponding_Record_Type (Ttyp))))),
14601 Append_To (Args, Ecount);
14603 -- Master parameter. This is a reference to the _Master parameter of
14604 -- the initialization procedure, except in the case of the pragma
14605 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14606 -- System.Tasking.Library_Task_Level.
14608 if Restriction_Active (No_Task_Hierarchy) = False then
14609 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
14612 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
14616 -- State parameter. This is a pointer to the task body procedure. The
14617 -- required value is obtained by taking 'Unrestricted_Access of the task
14618 -- body procedure and converting it (with an unchecked conversion) to
14619 -- the type required by the task kernel. For further details, see the
14620 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14621 -- than 'Address in order to avoid creating trampolines.
14624 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp);
14625 Subp_Ptr_Typ : constant Node_Id :=
14626 Create_Itype (E_Access_Subprogram_Type, Tdec);
14627 Ref : constant Node_Id := Make_Itype_Reference (Loc);
14630 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc);
14631 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
14633 -- Be sure to freeze a reference to the access-to-subprogram type,
14634 -- otherwise gigi will complain that it's in the wrong scope, because
14635 -- it's actually inside the init procedure for the record type that
14636 -- corresponds to the task type.
14638 Set_Itype (Ref, Subp_Ptr_Typ);
14639 Append_Freeze_Action (Task_Rec, Ref);
14642 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
14643 Make_Qualified_Expression (Loc,
14644 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc),
14646 Make_Attribute_Reference (Loc,
14647 Prefix => New_Occurrence_Of (Body_Proc, Loc),
14648 Attribute_Name => Name_Unrestricted_Access))));
14651 -- Discriminants parameter. This is just the address of the task
14652 -- value record itself (which contains the discriminant values
14655 Make_Attribute_Reference (Loc,
14656 Prefix => Make_Identifier (Loc, Name_uInit),
14657 Attribute_Name => Name_Address));
14659 -- Elaborated parameter. This is an access to the elaboration Boolean
14662 Make_Attribute_Reference (Loc,
14663 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
14664 Attribute_Name => Name_Unchecked_Access));
14666 -- Add Chain parameter (not done for sequential elaboration policy, see
14667 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14669 if Partition_Elaboration_Policy /= 'S' then
14670 Append_To (Args, Make_Identifier (Loc, Name_uChain));
14673 -- Task name parameter. Take this from the _Task_Id parameter to the
14674 -- init call unless there is a Task_Name pragma, in which case we take
14675 -- the value from the pragma.
14677 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then
14678 -- Copy expression in full, because it may be dynamic and have
14685 (Pragma_Argument_Associations
14687 (Ttyp, Name_Task_Name, Check_Parents => False))))));
14690 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
14693 -- Created_Task parameter. This is the _Task_Id field of the task
14697 Make_Selected_Component (Loc,
14698 Prefix => Make_Identifier (Loc, Name_uInit),
14699 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
14705 if Restricted_Profile then
14706 if Partition_Elaboration_Policy = 'S' then
14707 Create_RE := RE_Create_Restricted_Task_Sequential;
14709 Create_RE := RE_Create_Restricted_Task;
14712 Create_RE := RE_Create_Task;
14715 Name := New_Occurrence_Of (RTE (Create_RE), Loc);
14719 Make_Procedure_Call_Statement (Loc,
14721 Parameter_Associations => Args);
14722 end Make_Task_Create_Call;
14724 ------------------------------
14725 -- Next_Protected_Operation --
14726 ------------------------------
14728 function Next_Protected_Operation (N : Node_Id) return Node_Id is
14732 -- Check whether there is a subsequent body for a protected operation
14733 -- in the current protected body. In Ada2012 that includes expression
14734 -- functions that are completions.
14736 Next_Op := Next (N);
14737 while Present (Next_Op)
14738 and then not Nkind_In (Next_Op,
14739 N_Subprogram_Body, N_Entry_Body, N_Expression_Function)
14745 end Next_Protected_Operation;
14747 ---------------------
14748 -- Null_Statements --
14749 ---------------------
14751 function Null_Statements (Stats : List_Id) return Boolean is
14755 Stmt := First (Stats);
14756 while Nkind (Stmt) /= N_Empty
14757 and then (Nkind_In (Stmt, N_Null_Statement, N_Label)
14759 (Nkind (Stmt) = N_Pragma
14761 Nam_In (Pragma_Name_Unmapped (Stmt),
14769 return Nkind (Stmt) = N_Empty;
14770 end Null_Statements;
14772 --------------------------
14773 -- Parameter_Block_Pack --
14774 --------------------------
14776 function Parameter_Block_Pack
14778 Blk_Typ : Entity_Id;
14782 Stmts : List_Id) return Node_Id
14784 Actual : Entity_Id;
14785 Expr : Node_Id := Empty;
14786 Formal : Entity_Id;
14787 Has_Param : Boolean := False;
14790 Temp_Asn : Node_Id;
14791 Temp_Nam : Node_Id;
14794 Actual := First (Actuals);
14795 Formal := Defining_Identifier (First (Formals));
14796 Params := New_List;
14797 while Present (Actual) loop
14798 if Is_By_Copy_Type (Etype (Actual)) then
14800 -- Jnn : aliased <formal-type>
14802 Temp_Nam := Make_Temporary (Loc, 'J');
14805 Make_Object_Declaration (Loc,
14806 Aliased_Present => True,
14807 Defining_Identifier => Temp_Nam,
14808 Object_Definition =>
14809 New_Occurrence_Of (Etype (Formal), Loc)));
14811 -- The object is initialized with an explicit assignment
14812 -- later. Indicate that it does not need an initialization
14813 -- to prevent spurious warnings if the type excludes null.
14815 Set_No_Initialization (Last (Decls));
14817 if Ekind (Formal) /= E_Out_Parameter then
14823 New_Occurrence_Of (Temp_Nam, Loc);
14825 Set_Assignment_OK (Temp_Asn);
14828 Make_Assignment_Statement (Loc,
14830 Expression => New_Copy_Tree (Actual)));
14833 -- If the actual is not controlling, generate:
14835 -- Jnn'unchecked_access
14837 -- and add it to aggegate for access to formals. Note that the
14838 -- actual may be by-copy but still be a controlling actual if it
14839 -- is an access to class-wide interface.
14841 if not Is_Controlling_Actual (Actual) then
14843 Make_Attribute_Reference (Loc,
14844 Attribute_Name => Name_Unchecked_Access,
14845 Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
14850 -- The controlling parameter is omitted
14853 if not Is_Controlling_Actual (Actual) then
14855 Make_Reference (Loc, New_Copy_Tree (Actual)));
14861 Next_Actual (Actual);
14862 Next_Formal_With_Extras (Formal);
14866 Expr := Make_Aggregate (Loc, Params);
14871 -- J1'unchecked_access;
14872 -- <actual2>'reference;
14875 P := Make_Temporary (Loc, 'P');
14878 Make_Object_Declaration (Loc,
14879 Defining_Identifier => P,
14880 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc),
14881 Expression => Expr));
14884 end Parameter_Block_Pack;
14886 ----------------------------
14887 -- Parameter_Block_Unpack --
14888 ----------------------------
14890 function Parameter_Block_Unpack
14894 Formals : List_Id) return List_Id
14896 Actual : Entity_Id;
14898 Formal : Entity_Id;
14899 Has_Asnmt : Boolean := False;
14900 Result : constant List_Id := New_List;
14903 Actual := First (Actuals);
14904 Formal := Defining_Identifier (First (Formals));
14905 while Present (Actual) loop
14906 if Is_By_Copy_Type (Etype (Actual))
14907 and then Ekind (Formal) /= E_In_Parameter
14910 -- <actual> := P.<formal>;
14913 Make_Assignment_Statement (Loc,
14917 Make_Explicit_Dereference (Loc,
14918 Make_Selected_Component (Loc,
14920 New_Occurrence_Of (P, Loc),
14922 Make_Identifier (Loc, Chars (Formal)))));
14924 Set_Assignment_OK (Name (Asnmt));
14925 Append_To (Result, Asnmt);
14930 Next_Actual (Actual);
14931 Next_Formal_With_Extras (Formal);
14937 return New_List (Make_Null_Statement (Loc));
14939 end Parameter_Block_Unpack;
14941 ---------------------
14942 -- Reset_Scopes_To --
14943 ---------------------
14945 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is
14946 function Reset_Scope (N : Node_Id) return Traverse_Result;
14947 -- Temporaries may have been declared during expansion of the procedure
14948 -- created for an entry body or an accept alternative. Indicate that
14949 -- their scope is the new body, to ensure proper generation of uplevel
14950 -- references where needed during unnesting.
14952 procedure Reset_Scopes is new Traverse_Proc (Reset_Scope);
14958 function Reset_Scope (N : Node_Id) return Traverse_Result is
14962 -- If this is a block statement with an Identifier, it forms a scope,
14963 -- so we want to reset its scope but not look inside.
14966 and then Nkind (N) = N_Block_Statement
14967 and then Present (Identifier (N))
14969 Set_Scope (Entity (Identifier (N)), E);
14972 -- Ditto for a package declaration or a full type declaration, etc.
14974 elsif (Nkind (N) = N_Package_Declaration
14975 and then N /= Specification (N))
14976 or else Nkind (N) in N_Declaration
14977 or else Nkind (N) in N_Renaming_Declaration
14979 Set_Scope (Defining_Entity (N), E);
14984 -- Scan declarations in new body. Declarations in the statement
14985 -- part will be handled during later traversal.
14987 Decl := First (Declarations (N));
14988 while Present (Decl) loop
14989 Reset_Scopes (Decl);
14993 elsif Nkind (N) = N_Freeze_Entity then
14995 -- Scan the actions associated with a freeze node, which may
14996 -- actually be declarations with entities that need to have
14997 -- their scopes reset.
14999 Decl := First (Actions (N));
15000 while Present (Decl) loop
15001 Reset_Scopes (Decl);
15005 elsif N /= Bod and then Nkind (N) in N_Proper_Body then
15007 -- A subprogram without a separate declaration may be encountered,
15008 -- and we need to reset the subprogram's entity's scope.
15010 if Nkind (N) = N_Subprogram_Body then
15011 Set_Scope (Defining_Entity (Specification (N)), E);
15020 -- Start of processing for Reset_Scopes_To
15023 Reset_Scopes (Bod);
15024 end Reset_Scopes_To;
15026 ----------------------
15027 -- Set_Discriminals --
15028 ----------------------
15030 procedure Set_Discriminals (Dec : Node_Id) is
15033 D_Minal : Entity_Id;
15036 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
15037 Pdef := Defining_Identifier (Dec);
15039 if Has_Discriminants (Pdef) then
15040 D := First_Discriminant (Pdef);
15041 while Present (D) loop
15043 Make_Defining_Identifier (Sloc (D),
15044 Chars => New_External_Name (Chars (D), 'D'));
15046 Set_Ekind (D_Minal, E_Constant);
15047 Set_Etype (D_Minal, Etype (D));
15048 Set_Scope (D_Minal, Pdef);
15049 Set_Discriminal (D, D_Minal);
15050 Set_Discriminal_Link (D_Minal, D);
15052 Next_Discriminant (D);
15055 end Set_Discriminals;
15057 -----------------------
15058 -- Trivial_Accept_OK --
15059 -----------------------
15061 function Trivial_Accept_OK return Boolean is
15063 case Opt.Task_Dispatching_Policy is
15065 -- If we have the default task dispatching policy in effect, we can
15066 -- definitely do the optimization (one way of looking at this is to
15067 -- think of the formal definition of the default policy being allowed
15068 -- to run any task it likes after a rendezvous, so even if notionally
15069 -- a full rescheduling occurs, we can say that our dispatching policy
15070 -- (i.e. the default dispatching policy) reorders the queue to be the
15071 -- same as just before the call.
15076 -- FIFO_Within_Priorities certainly does not permit this
15077 -- optimization since the Rendezvous is a scheduling action that may
15078 -- require some other task to be run.
15083 -- For now, disallow the optimization for all other policies. This
15084 -- may be over-conservative, but it is certainly not incorrect.
15089 end Trivial_Accept_OK;