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_Ch6; use Sem_Ch6;
52 with Sem_Ch8; use Sem_Ch8;
53 with Sem_Ch9; use Sem_Ch9;
54 with Sem_Ch11; use Sem_Ch11;
55 with Sem_Elab; use Sem_Elab;
56 with Sem_Eval; use Sem_Eval;
57 with Sem_Prag; use Sem_Prag;
58 with Sem_Res; use Sem_Res;
59 with Sem_Util; use Sem_Util;
60 with Sinfo; use Sinfo;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Targparm; use Targparm;
64 with Tbuild; use Tbuild;
65 with Uintp; use Uintp;
66 with Validsw; use Validsw;
68 package body Exp_Ch9 is
70 -- The following constant establishes the upper bound for the index of
71 -- an entry family. It is used to limit the allocated size of protected
72 -- types with defaulted discriminant of an integer type, when the bound
73 -- of some entry family depends on a discriminant. The limitation to entry
74 -- families of 128K should be reasonable in all cases, and is a documented
75 -- implementation restriction.
77 Entry_Family_Bound : constant Pos := 2**16;
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Actual_Index_Expression
87 Tsk : Entity_Id) return Node_Id;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
92 procedure Add_Object_Pointer
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
101 procedure Add_Formal_Renamings
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
113 function Build_Accept_Body (Astat : Node_Id) return Node_Id;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
118 function Build_Barrier_Function
121 Pid : Node_Id) return Node_Id;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
125 function Build_Barrier_Function_Specification
127 Def_Id : Entity_Id) return Node_Id;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
131 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id);
132 -- Build the body of a wrapper procedure for an entry or entry family that
133 -- has contract cases, preconditions, or postconditions. The body gathers
134 -- the executable contract items and expands them in the usual way, and
135 -- performs the entry call itself. This way preconditions are evaluated
136 -- before the call is queued. E is the entry in question, and Decl is the
137 -- enclosing synchronized type declaration at whose freeze point the
138 -- generated body is analyzed.
140 function Build_Corresponding_Record
143 Loc : Source_Ptr) return Node_Id;
144 -- Common to tasks and protected types. Copy discriminant specifications,
145 -- build record declaration. N is the type declaration, Ctyp is the
146 -- concurrent entity (task type or protected type).
148 function Build_Dispatching_Tag_Check
150 N : Node_Id) return Node_Id;
151 -- Utility to create the tree to check whether the dispatching call in
152 -- a timed entry call, a conditional entry call, or an asynchronous
153 -- transfer of control is a call to a primitive of a non-synchronized type.
154 -- K is the temporary that holds the tagged kind of the target object, and
155 -- N is the enclosing construct.
157 function Build_Entry_Count_Expression
158 (Concurrent_Type : Node_Id;
159 Component_List : List_Id;
160 Loc : Source_Ptr) return Node_Id;
161 -- Compute number of entries for concurrent object. This is a count of
162 -- simple entries, followed by an expression that computes the length
163 -- of the range of each entry family. A single array with that size is
164 -- allocated for each concurrent object of the type.
166 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
167 -- Build the function that translates the entry index in the call
168 -- (which depends on the size of entry families) into an index into the
169 -- Entry_Bodies_Array, to determine the body and barrier function used
170 -- in a protected entry call. A pointer to this function appears in every
173 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
174 -- Build subprogram declaration for previous one
176 function Build_Lock_Free_Protected_Subprogram_Body
179 Unprot_Spec : Node_Id) return Node_Id;
180 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
181 -- the subprogram specification of the unprotected version of N. Transform
182 -- N such that it invokes the unprotected version of the body.
184 function Build_Lock_Free_Unprotected_Subprogram_Body
186 Prot_Typ : Node_Id) return Node_Id;
187 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
188 -- of N where the original statements of N are synchronized through atomic
189 -- actions such as compare and exchange. Prior to invoking this routine, it
190 -- has been established that N can be implemented in a lock-free fashion.
192 function Build_Parameter_Block
196 Decls : List_Id) return Entity_Id;
197 -- Generate an access type for each actual parameter in the list Actuals.
198 -- Create an encapsulating record that contains all the actuals and return
199 -- its type. Generate:
200 -- type Ann1 is access all <actual1-type>
202 -- type AnnN is access all <actualN-type>
203 -- type Pnn is record
209 function Build_Protected_Entry
212 Pid : Node_Id) return Node_Id;
213 -- Build the procedure implementing the statement sequence of the specified
216 function Build_Protected_Entry_Specification
219 Ent_Id : Entity_Id) return Node_Id;
220 -- Build a specification for the procedure implementing the statements of
221 -- the specified entry body. Add attributes associating it with the entry
222 -- defining identifier Ent_Id.
224 function Build_Protected_Spec
226 Obj_Type : Entity_Id;
228 Unprotected : Boolean := False) return List_Id;
229 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
230 -- Subprogram_Type. Builds signature of protected subprogram, adding the
231 -- formal that corresponds to the object itself. For an access to protected
232 -- subprogram, there is no object type to specify, so the parameter has
233 -- type Address and mode In. An indirect call through such a pointer will
234 -- convert the address to a reference to the actual object. The object is
235 -- a limited record and therefore a by_reference type.
237 function Build_Protected_Subprogram_Body
240 N_Op_Spec : Node_Id) return Node_Id;
241 -- This function is used to construct the protected version of a protected
242 -- subprogram. Its statement sequence first defers abort, then locks the
243 -- associated protected object, and then enters a block that contains a
244 -- call to the unprotected version of the subprogram (for details, see
245 -- Build_Unprotected_Subprogram_Body). This block statement requires a
246 -- cleanup handler that unlocks the object in all cases. For details,
247 -- see Exp_Ch7.Expand_Cleanup_Actions.
249 function Build_Renamed_Formal_Declaration
253 Renamed_Formal : Node_Id) return Node_Id;
254 -- Create a renaming declaration for a formal, within a protected entry
255 -- body or an accept body. The renamed object is a component of the
256 -- parameter block that is a parameter in the entry call.
258 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
259 -- does not dereference the corresponding component to prevent an illegal
260 -- use of the incomplete type (AI05-0151).
262 function Build_Selected_Name
264 Selector : Entity_Id;
265 Append_Char : Character := ' ') return Name_Id;
266 -- Build a name in the form of Prefix__Selector, with an optional character
267 -- appended. This is used for internal subprograms generated for operations
268 -- of protected types, including barrier functions. For the subprograms
269 -- generated for entry bodies and entry barriers, the generated name
270 -- includes a sequence number that makes names unique in the presence of
271 -- entry overloading. This is necessary because entry body procedures and
272 -- barrier functions all have the same signature.
274 procedure Build_Simple_Entry_Call
279 -- Some comments here would be useful ???
281 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
282 -- This routine constructs a specification for the procedure that we will
283 -- build for the task body for task type T. The spec has the form:
285 -- procedure tnameB (_Task : access tnameV);
287 -- where name is the character name taken from the task type entity that
288 -- is passed as the argument to the procedure, and tnameV is the task
289 -- value type that is associated with the task type.
291 function Build_Unprotected_Subprogram_Body
293 Pid : Node_Id) return Node_Id;
294 -- This routine constructs the unprotected version of a protected
295 -- subprogram body, which contains all of the code in the original,
296 -- unexpanded body. This is the version of the protected subprogram that is
297 -- called from all protected operations on the same object, including the
298 -- protected version of the same subprogram.
300 procedure Build_Wrapper_Bodies
304 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
305 -- record of a concurrent type. N is the insertion node where all bodies
306 -- will be placed. This routine builds the bodies of the subprograms which
307 -- serve as an indirection mechanism to overriding primitives of concurrent
308 -- types, entries and protected procedures. Any new body is analyzed.
310 procedure Build_Wrapper_Specs
314 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
315 -- record of a concurrent type. N is the insertion node where all specs
316 -- will be placed. This routine builds the specs of the subprograms which
317 -- serve as an indirection mechanism to overriding primitives of concurrent
318 -- types, entries and protected procedures. Any new spec is analyzed.
320 procedure Collect_Entry_Families
323 Current_Node : in out Node_Id;
324 Conctyp : Entity_Id);
325 -- For each entry family in a concurrent type, create an anonymous array
326 -- type of the right size, and add a component to the corresponding_record.
328 function Concurrent_Object
329 (Spec_Id : Entity_Id;
330 Conc_Typ : Entity_Id) return Entity_Id;
331 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
332 -- the entity associated with the concurrent object in the Protected_Body_
333 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
334 -- denotes formal parameter _O, _object or _task.
336 function Copy_Result_Type (Res : Node_Id) return Node_Id;
337 -- Copy the result type of a function specification, when building the
338 -- internal operation corresponding to a protected function, or when
339 -- expanding an access to protected function. If the result is an anonymous
340 -- access to subprogram itself, we need to create a new signature with the
341 -- same parameter names and the same resolved types, but with new entities
344 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean;
345 -- Return whether a secondary stack for the task T should be created by the
346 -- expander. The secondary stack for a task will be created by the expander
347 -- if the size of the stack has been specified by the Secondary_Stack_Size
348 -- representation aspect and either the No_Implicit_Heap_Allocations or
349 -- No_Implicit_Task_Allocations restrictions are in effect and the
350 -- No_Secondary_Stack restriction is not.
352 procedure Debug_Private_Data_Declarations (Decls : List_Id);
353 -- Decls is a list which may contain the declarations created by Install_
354 -- Private_Data_Declarations. All generated entities are marked as needing
355 -- debug info and debug nodes are manually generation where necessary. This
356 -- step of the expansion must to be done after private data has been moved
357 -- to its final resting scope to ensure proper visibility of debug objects.
359 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id);
360 -- If control flow optimizations are suppressed, and Alt is an accept,
361 -- delay, or entry call alternative with no trailing statements, insert
362 -- a null trailing statement with the given Loc (which is the sloc of
363 -- the accept, delay, or entry call statement). There might not be any
364 -- generated code for the accept, delay, or entry call itself (the effect
365 -- of these statements is part of the general processsing done for the
366 -- enclosing selective accept, timed entry call, or asynchronous select),
367 -- and the null statement is there to carry the sloc of that statement to
368 -- the back-end for trace-based coverage analysis purposes.
370 procedure Extract_Dispatching_Call
372 Call_Ent : out Entity_Id;
373 Object : out Entity_Id;
374 Actuals : out List_Id;
375 Formals : out List_Id);
376 -- Given a dispatching call, extract the entity of the name of the call,
377 -- its actual dispatching object, its actual parameters and the formal
378 -- parameters of the overridden interface-level version. If the type of
379 -- the dispatching object is an access type then an explicit dereference
380 -- is returned in Object.
382 procedure Extract_Entry
384 Concval : out Node_Id;
386 Index : out Node_Id);
387 -- Given an entry call, returns the associated concurrent object, the entry
388 -- name, and the entry family index.
390 function Family_Offset
395 Cap : Boolean) return Node_Id;
396 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
397 -- accept statement, or the upper bound in the discrete subtype of an entry
398 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
399 -- type of the entry. If Cap is true, the result is capped according to
400 -- Entry_Family_Bound.
407 Cap : Boolean) return Node_Id;
408 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
409 -- family, and handle properly the superflat case. This is equivalent to
410 -- the use of 'Length on the index type, but must use Family_Offset to
411 -- handle properly the case of bounds that depend on discriminants. If
412 -- Cap is true, the result is capped according to Entry_Family_Bound.
414 procedure Find_Enclosing_Context
416 Context : out Node_Id;
417 Context_Id : out Entity_Id;
418 Context_Decls : out List_Id);
419 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
420 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
421 -- nearest enclosing body, block, package, or return statement and return
422 -- its constituents. Context is the enclosing construct, Context_Id is
423 -- the scope of Context_Id and Context_Decls is the declarative list of
426 function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
427 -- Given a subprogram identifier, return the entity which is associated
428 -- with the protection entry index in the Protected_Body_Subprogram or
429 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
432 function Is_Potentially_Large_Family
433 (Base_Index : Entity_Id;
436 Hi : Node_Id) return Boolean;
438 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
439 -- Determine whether Id is a function or a procedure and is marked as a
440 -- private primitive.
442 function Null_Statements (Stats : List_Id) return Boolean;
443 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
444 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
445 -- to still count as null. Returns True for a null sequence. The argument
446 -- is the list of statements from the DO-END sequence.
448 function Parameter_Block_Pack
454 Stmts : List_Id) return Entity_Id;
455 -- Set the components of the generated parameter block with the values
456 -- of the actual parameters. Generate aliased temporaries to capture the
457 -- values for types that are passed by copy. Otherwise generate a reference
458 -- to the actual's value. Return the address of the aggregate block.
460 -- Jnn1 : alias <formal-type1>;
461 -- Jnn1 := <actual1>;
464 -- Jnn1'unchecked_access;
465 -- <actual2>'reference;
468 function Parameter_Block_Unpack
472 Formals : List_Id) return List_Id;
473 -- Retrieve the values of the components from the parameter block and
474 -- assign then to the original actual parameters. Generate:
475 -- <actual1> := P.<formal1>;
477 -- <actualN> := P.<formalN>;
479 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id);
480 -- Reset the scope of declarations and blocks at the top level of Bod
481 -- to be E. Bod is either a block or a subprogram body. Used after
482 -- expanding various kinds of entry bodies into their corresponding
483 -- constructs. This is needed during unnesting to determine whether a
484 -- body generated for an entry or an accept alternative includes uplevel
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 ---------------------
3499 -- Analyze_Pragmas --
3500 ---------------------
3502 procedure Analyze_Pragmas (From : Node_Id) is
3506 Decl := Next (From);
3507 while Present (Decl) loop
3508 if Nkind (Decl) = N_Pragma then
3509 Analyze_Pragma (Decl);
3511 -- No candidate pragmas are available for analysis
3519 end Analyze_Pragmas;
3525 procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
3527 Insert_Nod : Node_Id;
3528 Next_Decl : Node_Id;
3531 pragma Assert (Nkind (From) = N_Subprogram_Body);
3533 -- The pragmas are moved in an order-preserving fashion
3537 -- Inspect the declarations of the subprogram body and relocate all
3538 -- candidate pragmas.
3540 Decl := First (Declarations (From));
3541 while Present (Decl) loop
3543 -- Preserve the following declaration for iteration purposes, due
3544 -- to possible relocation of a pragma.
3546 Next_Decl := Next (Decl);
3548 if Nkind (Decl) = N_Pragma then
3550 Insert_After (Insert_Nod, Decl);
3553 -- Skip internally generated code
3555 elsif not Comes_From_Source (Decl) then
3558 -- No candidate pragmas are available for relocation
3570 Body_Id : constant Entity_Id := Defining_Entity (N);
3571 Loc : constant Source_Ptr := Sloc (N);
3576 Spec_Id : Entity_Id;
3578 -- Start of processing for Build_Private_Protected_Declaration
3581 Formal := First_Formal (Body_Id);
3583 -- The protected operation always has at least one formal, namely the
3584 -- object itself, but it is only placed in the parameter list if
3585 -- expansion is enabled.
3587 if Present (Formal) or else Expander_Active then
3588 Formals := Copy_Parameter_List (Body_Id);
3594 Make_Defining_Identifier (Sloc (Body_Id),
3595 Chars => Chars (Body_Id));
3597 -- Indicate that the entity comes from source, to ensure that cross-
3598 -- reference information is properly generated. The body itself is
3599 -- rewritten during expansion, and the body entity will not appear in
3600 -- calls to the operation.
3602 Set_Comes_From_Source (Spec_Id, True);
3604 if Nkind (Specification (N)) = N_Procedure_Specification then
3606 Make_Procedure_Specification (Loc,
3607 Defining_Unit_Name => Spec_Id,
3608 Parameter_Specifications => Formals);
3611 Make_Function_Specification (Loc,
3612 Defining_Unit_Name => Spec_Id,
3613 Parameter_Specifications => Formals,
3614 Result_Definition =>
3615 New_Occurrence_Of (Etype (Body_Id), Loc));
3618 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
3619 Set_Corresponding_Body (Decl, Body_Id);
3620 Set_Corresponding_Spec (N, Spec_Id);
3622 Insert_Before (N, Decl);
3624 -- Associate all aspects and pragmas of the body with the spec. This
3625 -- ensures that these annotations apply to the initial declaration of
3626 -- the subprogram body.
3628 Move_Aspects (From => N, To => Decl);
3629 Move_Pragmas (From => N, To => Decl);
3633 -- The analysis of the spec may generate pragmas which require manual
3634 -- analysis. Since the generation of the spec and the relocation of the
3635 -- annotations is driven by the expansion of the stand-alone body, the
3636 -- pragmas will not be analyzed in a timely manner. Do this now.
3638 Analyze_Pragmas (Decl);
3640 Set_Convention (Spec_Id, Convention_Protected);
3641 Set_Has_Completion (Spec_Id);
3644 end Build_Private_Protected_Declaration;
3646 ---------------------------
3647 -- Build_Protected_Entry --
3648 ---------------------------
3650 function Build_Protected_Entry
3653 Pid : Node_Id) return Node_Id
3655 Bod_Decls : constant List_Id := New_List;
3656 Decls : constant List_Id := Declarations (N);
3657 End_Lab : constant Node_Id :=
3658 End_Label (Handled_Statement_Sequence (N));
3659 End_Loc : constant Source_Ptr :=
3660 Sloc (Last (Statements (Handled_Statement_Sequence (N))));
3661 -- Used for the generated call to Complete_Entry_Body
3663 Loc : constant Source_Ptr := Sloc (N);
3667 Bod_Stmts : List_Id;
3670 Proc_Body : Node_Id;
3672 EH_Loc : Source_Ptr;
3673 -- Used for the exception handler, inserted at end of the body
3676 -- Set the source location on the exception handler only when debugging
3677 -- the expanded code (see Make_Implicit_Exception_Handler).
3679 if Debug_Generated_Code then
3682 -- Otherwise the inserted code should not be visible to the debugger
3685 EH_Loc := No_Location;
3689 Make_Defining_Identifier (Loc,
3690 Chars => Chars (Protected_Body_Subprogram (Ent)));
3691 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty);
3693 -- Add the following declarations:
3695 -- type poVP is access poV;
3696 -- _object : poVP := poVP (_O);
3698 -- where _O is the formal parameter associated with the concurrent
3699 -- object. These declarations are needed for Complete_Entry_Body.
3701 Add_Object_Pointer (Loc, Pid, Bod_Decls);
3703 -- Add renamings for all formals, the Protection object, discriminals,
3704 -- privals and the entry index constant for use by debugger.
3706 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc);
3707 Debug_Private_Data_Declarations (Decls);
3709 -- Put the declarations and the statements from the entry
3713 Make_Block_Statement (Loc,
3714 Declarations => Decls,
3715 Handled_Statement_Sequence => Handled_Statement_Sequence (N)));
3717 case Corresponding_Runtime_Package (Pid) is
3718 when System_Tasking_Protected_Objects_Entries =>
3719 Append_To (Bod_Stmts,
3720 Make_Procedure_Call_Statement (End_Loc,
3722 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
3723 Parameter_Associations => New_List (
3724 Make_Attribute_Reference (End_Loc,
3726 Make_Selected_Component (End_Loc,
3728 Make_Identifier (End_Loc, Name_uObject),
3730 Make_Identifier (End_Loc, Name_uObject)),
3731 Attribute_Name => Name_Unchecked_Access))));
3733 when System_Tasking_Protected_Objects_Single_Entry =>
3735 -- Historically, a call to Complete_Single_Entry_Body was
3736 -- inserted, but it was a null procedure.
3741 raise Program_Error;
3744 -- When exceptions cannot be propagated, we never need to call
3745 -- Exception_Complete_Entry_Body.
3747 if No_Exception_Handlers_Set then
3749 Make_Subprogram_Body (Loc,
3750 Specification => Bod_Spec,
3751 Declarations => Bod_Decls,
3752 Handled_Statement_Sequence =>
3753 Make_Handled_Sequence_Of_Statements (Loc,
3754 Statements => Bod_Stmts,
3755 End_Label => End_Lab));
3758 Ohandle := Make_Others_Choice (Loc);
3759 Set_All_Others (Ohandle);
3761 case Corresponding_Runtime_Package (Pid) is
3762 when System_Tasking_Protected_Objects_Entries =>
3765 (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
3767 when System_Tasking_Protected_Objects_Single_Entry =>
3770 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
3773 raise Program_Error;
3776 -- Establish link between subprogram body entity and source entry
3778 Set_Corresponding_Protected_Entry (Bod_Id, Ent);
3780 -- Create body of entry procedure. The renaming declarations are
3781 -- placed ahead of the block that contains the actual entry body.
3784 Make_Subprogram_Body (Loc,
3785 Specification => Bod_Spec,
3786 Declarations => Bod_Decls,
3787 Handled_Statement_Sequence =>
3788 Make_Handled_Sequence_Of_Statements (Loc,
3789 Statements => Bod_Stmts,
3790 End_Label => End_Lab,
3791 Exception_Handlers => New_List (
3792 Make_Implicit_Exception_Handler (EH_Loc,
3793 Exception_Choices => New_List (Ohandle),
3795 Statements => New_List (
3796 Make_Procedure_Call_Statement (EH_Loc,
3798 Parameter_Associations => New_List (
3799 Make_Attribute_Reference (EH_Loc,
3801 Make_Selected_Component (EH_Loc,
3803 Make_Identifier (EH_Loc, Name_uObject),
3805 Make_Identifier (EH_Loc, Name_uObject)),
3806 Attribute_Name => Name_Unchecked_Access),
3808 Make_Function_Call (EH_Loc,
3811 (RTE (RE_Get_GNAT_Exception), Loc)))))))));
3813 Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent));
3816 end Build_Protected_Entry;
3818 -----------------------------------------
3819 -- Build_Protected_Entry_Specification --
3820 -----------------------------------------
3822 function Build_Protected_Entry_Specification
3825 Ent_Id : Entity_Id) return Node_Id
3827 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP);
3830 Set_Debug_Info_Needed (Def_Id);
3832 if Present (Ent_Id) then
3833 Append_Elmt (P, Accept_Address (Ent_Id));
3837 Make_Procedure_Specification (Loc,
3838 Defining_Unit_Name => Def_Id,
3839 Parameter_Specifications => New_List (
3840 Make_Parameter_Specification (Loc,
3841 Defining_Identifier =>
3842 Make_Defining_Identifier (Loc, Name_uO),
3844 New_Occurrence_Of (RTE (RE_Address), Loc)),
3846 Make_Parameter_Specification (Loc,
3847 Defining_Identifier => P,
3849 New_Occurrence_Of (RTE (RE_Address), Loc)),
3851 Make_Parameter_Specification (Loc,
3852 Defining_Identifier =>
3853 Make_Defining_Identifier (Loc, Name_uE),
3855 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))));
3856 end Build_Protected_Entry_Specification;
3858 --------------------------
3859 -- Build_Protected_Spec --
3860 --------------------------
3862 function Build_Protected_Spec
3864 Obj_Type : Entity_Id;
3866 Unprotected : Boolean := False) return List_Id
3868 Loc : constant Source_Ptr := Sloc (N);
3871 New_Plist : List_Id;
3872 New_Param : Node_Id;
3875 New_Plist := New_List;
3877 Formal := First_Formal (Ident);
3878 while Present (Formal) loop
3880 Make_Parameter_Specification (Loc,
3881 Defining_Identifier =>
3882 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
3883 Aliased_Present => Aliased_Present (Parent (Formal)),
3884 In_Present => In_Present (Parent (Formal)),
3885 Out_Present => Out_Present (Parent (Formal)),
3886 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc));
3889 Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
3892 Append (New_Param, New_Plist);
3893 Next_Formal (Formal);
3896 -- If the subprogram is a procedure and the context is not an access
3897 -- to protected subprogram, the parameter is in-out. Otherwise it is
3901 Make_Parameter_Specification (Loc,
3902 Defining_Identifier =>
3903 Make_Defining_Identifier (Loc, Name_uObject),
3906 (Etype (Ident) = Standard_Void_Type
3907 and then not Is_RTE (Obj_Type, RE_Address)),
3909 New_Occurrence_Of (Obj_Type, Loc));
3910 Set_Debug_Info_Needed (Defining_Identifier (Decl));
3911 Prepend_To (New_Plist, Decl);
3914 end Build_Protected_Spec;
3916 ---------------------------------------
3917 -- Build_Protected_Sub_Specification --
3918 ---------------------------------------
3920 function Build_Protected_Sub_Specification
3922 Prot_Typ : Entity_Id;
3923 Mode : Subprogram_Protection_Mode) return Node_Id
3925 Loc : constant Source_Ptr := Sloc (N);
3929 New_Plist : List_Id;
3932 Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
3933 (Dispatching_Mode => ' ',
3934 Protected_Mode => 'P',
3935 Unprotected_Mode => 'N');
3938 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
3940 Decl := Unit_Declaration_Node (Corresponding_Spec (N));
3945 Def_Id := Defining_Unit_Name (Specification (Decl));
3948 Build_Protected_Spec
3949 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id,
3950 Mode = Unprotected_Mode);
3952 Make_Defining_Identifier (Loc,
3953 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
3955 -- Reference the original nondispatching subprogram since the analysis
3956 -- of the object.operation notation may need its original name (see
3957 -- Sem_Ch4.Names_Match).
3959 if Mode = Dispatching_Mode then
3960 Set_Ekind (New_Id, Ekind (Def_Id));
3961 Set_Original_Protected_Subprogram (New_Id, Def_Id);
3964 -- Link the protected or unprotected version to the original subprogram
3967 Set_Ekind (New_Id, Ekind (Def_Id));
3968 Set_Protected_Subprogram (New_Id, Def_Id);
3970 -- The unprotected operation carries the user code, and debugging
3971 -- information must be generated for it, even though this spec does
3972 -- not come from source. It is also convenient to allow gdb to step
3973 -- into the protected operation, even though it only contains lock/
3976 Set_Debug_Info_Needed (New_Id);
3978 -- If a pragma Eliminate applies to the source entity, the internal
3979 -- subprograms will be eliminated as well.
3981 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
3983 if Nkind (Specification (Decl)) = N_Procedure_Specification then
3985 Make_Procedure_Specification (Loc,
3986 Defining_Unit_Name => New_Id,
3987 Parameter_Specifications => New_Plist);
3989 -- Create a new specification for the anonymous subprogram type
3993 Make_Function_Specification (Loc,
3994 Defining_Unit_Name => New_Id,
3995 Parameter_Specifications => New_Plist,
3996 Result_Definition =>
3997 Copy_Result_Type (Result_Definition (Specification (Decl))));
3999 Set_Return_Present (Defining_Unit_Name (New_Spec));
4003 end Build_Protected_Sub_Specification;
4005 -------------------------------------
4006 -- Build_Protected_Subprogram_Body --
4007 -------------------------------------
4009 function Build_Protected_Subprogram_Body
4012 N_Op_Spec : Node_Id) return Node_Id
4014 Exc_Safe : constant Boolean := not Might_Raise (N);
4015 -- True if N cannot raise an exception
4017 Loc : constant Source_Ptr := Sloc (N);
4018 Op_Spec : constant Node_Id := Specification (N);
4019 P_Op_Spec : constant Node_Id :=
4020 Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
4023 Lock_Name : Node_Id;
4024 Lock_Stmt : Node_Id;
4025 Object_Parm : Node_Id;
4028 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
4029 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
4033 Unprot_Call : Node_Id;
4036 -- Build a list of the formal parameters of the protected version of
4037 -- the subprogram to use as the actual parameters of the unprotected
4040 Uactuals := New_List;
4041 Pformal := First (Parameter_Specifications (P_Op_Spec));
4042 while Present (Pformal) loop
4043 Append_To (Uactuals,
4044 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
4048 -- Make a call to the unprotected version of the subprogram built above
4049 -- for use by the protected version built below.
4051 if Nkind (Op_Spec) = N_Function_Specification then
4053 R := Make_Temporary (Loc, 'R');
4056 Make_Object_Declaration (Loc,
4057 Defining_Identifier => R,
4058 Constant_Present => True,
4059 Object_Definition =>
4060 New_Copy (Result_Definition (N_Op_Spec)),
4062 Make_Function_Call (Loc,
4064 Make_Identifier (Loc,
4065 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4066 Parameter_Associations => Uactuals));
4069 Make_Simple_Return_Statement (Loc,
4070 Expression => New_Occurrence_Of (R, Loc));
4074 Make_Simple_Return_Statement (Loc,
4076 Make_Function_Call (Loc,
4078 Make_Identifier (Loc,
4079 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4080 Parameter_Associations => Uactuals));
4083 Lock_Kind := RE_Lock_Read_Only;
4087 Make_Procedure_Call_Statement (Loc,
4089 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
4090 Parameter_Associations => Uactuals);
4092 Lock_Kind := RE_Lock;
4095 -- Wrap call in block that will be covered by an at_end handler
4097 if not Exc_Safe then
4099 Make_Block_Statement (Loc,
4100 Handled_Statement_Sequence =>
4101 Make_Handled_Sequence_Of_Statements (Loc,
4102 Statements => New_List (Unprot_Call)));
4105 -- Make the protected subprogram body. This locks the protected
4106 -- object and calls the unprotected version of the subprogram.
4108 case Corresponding_Runtime_Package (Pid) is
4109 when System_Tasking_Protected_Objects_Entries =>
4110 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc);
4112 when System_Tasking_Protected_Objects_Single_Entry =>
4113 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc);
4115 when System_Tasking_Protected_Objects =>
4116 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc);
4119 raise Program_Error;
4123 Make_Attribute_Reference (Loc,
4125 Make_Selected_Component (Loc,
4126 Prefix => Make_Identifier (Loc, Name_uObject),
4127 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4128 Attribute_Name => Name_Unchecked_Access);
4131 Make_Procedure_Call_Statement (Loc,
4133 Parameter_Associations => New_List (Object_Parm));
4135 if Abort_Allowed then
4137 Build_Runtime_Call (Loc, RE_Abort_Defer),
4141 Stmts := New_List (Lock_Stmt);
4144 if not Exc_Safe then
4145 Append (Unprot_Call, Stmts);
4147 if Nkind (Op_Spec) = N_Function_Specification then
4149 Stmts := Empty_List;
4151 Append (Unprot_Call, Stmts);
4154 -- Historical note: Previously, call to the cleanup was inserted
4155 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4156 -- which is also shared by the 'not Exc_Safe' path.
4158 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
4160 if Nkind (Op_Spec) = N_Function_Specification then
4161 Append_To (Stmts, Return_Stmt);
4162 Append_To (Pre_Stmts,
4163 Make_Block_Statement (Loc,
4164 Declarations => New_List (Unprot_Call),
4165 Handled_Statement_Sequence =>
4166 Make_Handled_Sequence_Of_Statements (Loc,
4167 Statements => Stmts)));
4173 Make_Subprogram_Body (Loc,
4174 Declarations => Empty_List,
4175 Specification => P_Op_Spec,
4176 Handled_Statement_Sequence =>
4177 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
4179 -- Mark this subprogram as a protected subprogram body so that the
4180 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4181 -- path as otherwise the cleanup has already been inserted.
4183 if not Exc_Safe then
4184 Set_Is_Protected_Subprogram_Body (Sub_Body);
4188 end Build_Protected_Subprogram_Body;
4190 -------------------------------------
4191 -- Build_Protected_Subprogram_Call --
4192 -------------------------------------
4194 procedure Build_Protected_Subprogram_Call
4198 External : Boolean := True)
4200 Loc : constant Source_Ptr := Sloc (N);
4201 Sub : constant Entity_Id := Entity (Name);
4207 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
4210 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
4213 if Present (Parameter_Associations (N)) then
4214 Params := New_Copy_List_Tree (Parameter_Associations (N));
4219 -- If the type is an untagged derived type, convert to the root type,
4220 -- which is the one on which the operations are defined.
4222 if Nkind (Rec) = N_Unchecked_Type_Conversion
4223 and then not Is_Tagged_Type (Etype (Rec))
4224 and then Is_Derived_Type (Etype (Rec))
4226 Set_Etype (Rec, Root_Type (Etype (Rec)));
4227 Set_Subtype_Mark (Rec,
4228 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
4231 Prepend (Rec, Params);
4233 if Ekind (Sub) = E_Procedure then
4235 Make_Procedure_Call_Statement (Loc,
4237 Parameter_Associations => Params));
4240 pragma Assert (Ekind (Sub) = E_Function);
4242 Make_Function_Call (Loc,
4244 Parameter_Associations => Params));
4246 -- Preserve type of call for subsequent processing (required for
4247 -- call to Wrap_Transient_Expression in the case of a shared passive
4250 Set_Etype (N, Etype (New_Sub));
4254 and then Nkind (Rec) = N_Unchecked_Type_Conversion
4255 and then Is_Entity_Name (Expression (Rec))
4256 and then Is_Shared_Passive (Entity (Expression (Rec)))
4258 Add_Shared_Var_Lock_Procs (N);
4260 end Build_Protected_Subprogram_Call;
4262 ---------------------------------------------
4263 -- Build_Protected_Subprogram_Call_Cleanup --
4264 ---------------------------------------------
4266 procedure Build_Protected_Subprogram_Call_Cleanup
4275 -- If the associated protected object has entries, a protected
4276 -- procedure has to service entry queues. In this case generate:
4278 -- Service_Entries (_object._object'Access);
4280 if Nkind (Op_Spec) = N_Procedure_Specification
4281 and then Has_Entries (Conc_Typ)
4283 case Corresponding_Runtime_Package (Conc_Typ) is
4284 when System_Tasking_Protected_Objects_Entries =>
4285 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc);
4287 when System_Tasking_Protected_Objects_Single_Entry =>
4288 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc);
4291 raise Program_Error;
4295 Make_Procedure_Call_Statement (Loc,
4297 Parameter_Associations => New_List (
4298 Make_Attribute_Reference (Loc,
4300 Make_Selected_Component (Loc,
4301 Prefix => Make_Identifier (Loc, Name_uObject),
4302 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4303 Attribute_Name => Name_Unchecked_Access))));
4307 -- Unlock (_object._object'Access);
4309 case Corresponding_Runtime_Package (Conc_Typ) is
4310 when System_Tasking_Protected_Objects_Entries =>
4311 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc);
4313 when System_Tasking_Protected_Objects_Single_Entry =>
4314 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc);
4316 when System_Tasking_Protected_Objects =>
4317 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc);
4320 raise Program_Error;
4324 Make_Procedure_Call_Statement (Loc,
4326 Parameter_Associations => New_List (
4327 Make_Attribute_Reference (Loc,
4329 Make_Selected_Component (Loc,
4330 Prefix => Make_Identifier (Loc, Name_uObject),
4331 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4332 Attribute_Name => Name_Unchecked_Access))));
4338 if Abort_Allowed then
4339 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4341 end Build_Protected_Subprogram_Call_Cleanup;
4343 -------------------------
4344 -- Build_Selected_Name --
4345 -------------------------
4347 function Build_Selected_Name
4348 (Prefix : Entity_Id;
4349 Selector : Entity_Id;
4350 Append_Char : Character := ' ') return Name_Id
4352 Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
4353 Select_Len : Natural;
4356 Get_Name_String (Chars (Selector));
4357 Select_Len := Name_Len;
4358 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
4359 Get_Name_String (Chars (Prefix));
4361 -- If scope is anonymous type, discard suffix to recover name of
4362 -- single protected object. Otherwise use protected type name.
4364 if Name_Buffer (Name_Len) = 'T' then
4365 Name_Len := Name_Len - 1;
4368 Add_Str_To_Name_Buffer ("__");
4369 for J in 1 .. Select_Len loop
4370 Add_Char_To_Name_Buffer (Select_Buffer (J));
4373 -- Now add the Append_Char if specified. The encoding to follow
4374 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4375 -- then the entity is associated to a protected type subprogram.
4376 -- Otherwise, it is a protected type entry. For each case, the
4377 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4379 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4381 if Append_Char /= ' ' then
4382 if Append_Char = 'P' or Append_Char = 'N' then
4383 Add_Char_To_Name_Buffer (Append_Char);
4386 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
4387 return New_External_Name (Name_Find, ' ', -1);
4392 end Build_Selected_Name;
4394 -----------------------------
4395 -- Build_Simple_Entry_Call --
4396 -----------------------------
4398 -- A task entry call is converted to a call to Call_Simple
4401 -- P : parms := (parm, parm, parm);
4403 -- Call_Simple (acceptor-task, entry-index, P'Address);
4409 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4410 -- the parameters, and the constructed aggregate value contains either the
4411 -- parameters or, in the case of non-elementary types, references to these
4412 -- parameters. Then the address of this aggregate is passed to the runtime
4413 -- routine, along with the task id value and the task entry index value.
4414 -- Pnn is only required if parameters are present.
4416 -- The assignments after the call are present only in the case of in-out
4417 -- or out parameters for elementary types, and are used to assign back the
4418 -- resulting values of such parameters.
4420 -- Note: the reason that we insert a block here is that in the context
4421 -- of selects, conditional entry calls etc. the entry call statement
4422 -- appears on its own, not as an element of a list.
4424 -- A protected entry call is converted to a Protected_Entry_Call:
4427 -- P : E1_Params := (param, param, param);
4429 -- Bnn : Communications_Block;
4432 -- P : E1_Params := (param, param, param);
4433 -- Bnn : Communications_Block;
4436 -- Protected_Entry_Call (
4437 -- Object => po._object'Access,
4438 -- E => <entry index>;
4439 -- Uninterpreted_Data => P'Address;
4440 -- Mode => Simple_Call;
4447 procedure Build_Simple_Entry_Call
4456 -- If call has been inlined, nothing left to do
4458 if Nkind (N) = N_Block_Statement then
4462 -- Convert entry call to Call_Simple call
4465 Loc : constant Source_Ptr := Sloc (N);
4466 Parms : constant List_Id := Parameter_Associations (N);
4467 Stats : constant List_Id := New_List;
4470 Comm_Name : Entity_Id;
4474 Ent_Acc : Entity_Id;
4476 Iface_Tag : Entity_Id;
4477 Iface_Typ : Entity_Id;
4490 -- Simple entry and entry family cases merge here
4492 Ent := Entity (Ename);
4493 Ent_Acc := Entry_Parameters_Type (Ent);
4494 Conctyp := Etype (Concval);
4496 -- If prefix is an access type, dereference to obtain the task type
4498 if Is_Access_Type (Conctyp) then
4499 Conctyp := Designated_Type (Conctyp);
4502 -- Special case for protected subprogram calls
4504 if Is_Protected_Type (Conctyp)
4505 and then Is_Subprogram (Entity (Ename))
4507 if not Is_Eliminated (Entity (Ename)) then
4508 Build_Protected_Subprogram_Call
4509 (N, Ename, Convert_Concurrent (Concval, Conctyp));
4516 -- First parameter is the Task_Id value from the task value or the
4517 -- Object from the protected object value, obtained by selecting
4518 -- the _Task_Id or _Object from the result of doing an unchecked
4519 -- conversion to convert the value to the corresponding record type.
4521 if Nkind (Concval) = N_Function_Call
4522 and then Is_Task_Type (Conctyp)
4523 and then Ada_Version >= Ada_2005
4526 ExpR : constant Node_Id := Relocate_Node (Concval);
4527 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR);
4532 Make_Object_Declaration (Loc,
4533 Defining_Identifier => Obj,
4534 Object_Definition => New_Occurrence_Of (Conctyp, Loc),
4535 Expression => ExpR);
4536 Set_Etype (Obj, Conctyp);
4537 Decls := New_List (Decl);
4538 Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
4545 Parm1 := Concurrent_Ref (Concval);
4547 -- Second parameter is the entry index, computed by the routine
4548 -- provided for this purpose. The value of this expression is
4549 -- assigned to an intermediate variable to assure that any entry
4550 -- family index expressions are evaluated before the entry
4553 if not Is_Protected_Type (Conctyp)
4555 Corresponding_Runtime_Package (Conctyp) =
4556 System_Tasking_Protected_Objects_Entries
4558 X := Make_Defining_Identifier (Loc, Name_uX);
4561 Make_Object_Declaration (Loc,
4562 Defining_Identifier => X,
4563 Object_Definition =>
4564 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
4565 Expression => Actual_Index_Expression (
4566 Loc, Entity (Ename), Index, Concval));
4568 Append_To (Decls, Xdecl);
4569 Parm2 := New_Occurrence_Of (X, Loc);
4576 -- The third parameter is the packaged parameters. If there are
4577 -- none, then it is just the null address, since nothing is passed.
4580 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
4583 -- Case of parameters present, where third argument is the address
4584 -- of a packaged record containing the required parameter values.
4587 -- First build a list of parameter values, which are references to
4588 -- objects of the parameter types.
4592 Actual := First_Actual (N);
4593 Formal := First_Formal (Ent);
4594 while Present (Actual) loop
4596 -- If it is a by-copy type, copy it to a new variable. The
4597 -- packaged record has a field that points to this variable.
4599 if Is_By_Copy_Type (Etype (Actual)) then
4601 Make_Object_Declaration (Loc,
4602 Defining_Identifier => Make_Temporary (Loc, 'J'),
4603 Aliased_Present => True,
4604 Object_Definition =>
4605 New_Occurrence_Of (Etype (Formal), Loc));
4607 -- Mark the object as not needing initialization since the
4608 -- initialization is performed separately, avoiding errors
4609 -- on cases such as formals of null-excluding access types.
4611 Set_No_Initialization (N_Node);
4613 -- We must make a separate assignment statement for the
4614 -- case of limited types. We cannot assign it unless the
4615 -- Assignment_OK flag is set first. An out formal of an
4616 -- access type or whose type has a Default_Value must also
4617 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4618 -- but no constraint, predicate, or null-exclusion check is
4619 -- applied before the call.
4621 if Ekind (Formal) /= E_Out_Parameter
4622 or else Is_Access_Type (Etype (Formal))
4624 (Is_Scalar_Type (Etype (Formal))
4626 Present (Default_Aspect_Value (Etype (Formal))))
4629 New_Occurrence_Of (Defining_Identifier (N_Node), Loc);
4630 Set_Assignment_OK (N_Var);
4632 Make_Assignment_Statement (Loc,
4634 Expression => Relocate_Node (Actual)));
4636 -- Mark the object as internal, so we don't later reset
4637 -- No_Initialization flag in Default_Initialize_Object,
4638 -- which would lead to needless default initialization.
4639 -- We don't set this outside the if statement, because
4640 -- out scalar parameters without Default_Value do require
4641 -- default initialization if Initialize_Scalars applies.
4643 Set_Is_Internal (Defining_Identifier (N_Node));
4645 -- If actual is an out parameter of a null-excluding
4646 -- access type, there is access check on entry, so set
4647 -- Suppress_Assignment_Checks on the generated statement
4648 -- that assigns the actual to the parameter block.
4650 Set_Suppress_Assignment_Checks (Last (Stats));
4653 Append (N_Node, Decls);
4656 Make_Attribute_Reference (Loc,
4657 Attribute_Name => Name_Unchecked_Access,
4660 (Defining_Identifier (N_Node), Loc)));
4663 -- Interface class-wide formal
4665 if Ada_Version >= Ada_2005
4666 and then Ekind (Etype (Formal)) = E_Class_Wide_Type
4667 and then Is_Interface (Etype (Formal))
4669 Iface_Typ := Etype (Etype (Formal));
4672 -- formal_iface_type! (actual.iface_tag)'reference
4675 Find_Interface_Tag (Etype (Actual), Iface_Typ);
4676 pragma Assert (Present (Iface_Tag));
4679 Make_Reference (Loc,
4680 Unchecked_Convert_To (Iface_Typ,
4681 Make_Selected_Component (Loc,
4683 Relocate_Node (Actual),
4685 New_Occurrence_Of (Iface_Tag, Loc)))));
4691 Make_Reference (Loc, Relocate_Node (Actual)));
4695 Next_Actual (Actual);
4696 Next_Formal_With_Extras (Formal);
4699 -- Now build the declaration of parameters initialized with the
4700 -- aggregate containing this constructed parameter list.
4702 P := Make_Defining_Identifier (Loc, Name_uP);
4705 Make_Object_Declaration (Loc,
4706 Defining_Identifier => P,
4707 Object_Definition =>
4708 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc),
4710 Make_Aggregate (Loc, Expressions => Plist));
4713 Make_Attribute_Reference (Loc,
4714 Prefix => New_Occurrence_Of (P, Loc),
4715 Attribute_Name => Name_Address);
4717 Append (Pdecl, Decls);
4720 -- Now we can create the call, case of protected type
4722 if Is_Protected_Type (Conctyp) then
4723 case Corresponding_Runtime_Package (Conctyp) is
4724 when System_Tasking_Protected_Objects_Entries =>
4726 -- Change the type of the index declaration
4728 Set_Object_Definition (Xdecl,
4729 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc));
4731 -- Some additional declarations for protected entry calls
4737 -- Bnn : Communications_Block;
4739 Comm_Name := Make_Temporary (Loc, 'B');
4742 Make_Object_Declaration (Loc,
4743 Defining_Identifier => Comm_Name,
4744 Object_Definition =>
4746 (RTE (RE_Communication_Block), Loc)));
4748 -- Some additional statements for protected entry calls
4750 -- Protected_Entry_Call
4751 -- (Object => po._object'Access,
4752 -- E => <entry index>;
4753 -- Uninterpreted_Data => P'Address;
4754 -- Mode => Simple_Call;
4758 Make_Procedure_Call_Statement (Loc,
4760 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
4762 Parameter_Associations => New_List (
4763 Make_Attribute_Reference (Loc,
4764 Attribute_Name => Name_Unchecked_Access,
4768 New_Occurrence_Of (RTE (RE_Simple_Call), Loc),
4769 New_Occurrence_Of (Comm_Name, Loc)));
4771 when System_Tasking_Protected_Objects_Single_Entry =>
4773 -- Protected_Single_Entry_Call
4774 -- (Object => po._object'Access,
4775 -- Uninterpreted_Data => P'Address);
4778 Make_Procedure_Call_Statement (Loc,
4781 (RTE (RE_Protected_Single_Entry_Call), Loc),
4783 Parameter_Associations => New_List (
4784 Make_Attribute_Reference (Loc,
4785 Attribute_Name => Name_Unchecked_Access,
4790 raise Program_Error;
4793 -- Case of task type
4797 Make_Procedure_Call_Statement (Loc,
4799 New_Occurrence_Of (RTE (RE_Call_Simple), Loc),
4800 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
4804 Append_To (Stats, Call);
4806 -- If there are out or in/out parameters by copy add assignment
4807 -- statements for the result values.
4809 if Present (Parms) then
4810 Actual := First_Actual (N);
4811 Formal := First_Formal (Ent);
4813 Set_Assignment_OK (Actual);
4814 while Present (Actual) loop
4815 if Is_By_Copy_Type (Etype (Actual))
4816 and then Ekind (Formal) /= E_In_Parameter
4819 Make_Assignment_Statement (Loc,
4820 Name => New_Copy (Actual),
4822 Make_Explicit_Dereference (Loc,
4823 Make_Selected_Component (Loc,
4824 Prefix => New_Occurrence_Of (P, Loc),
4826 Make_Identifier (Loc, Chars (Formal)))));
4828 -- In all cases (including limited private types) we want
4829 -- the assignment to be valid.
4831 Set_Assignment_OK (Name (N_Node));
4833 -- If the call is the triggering alternative in an
4834 -- asynchronous select, or the entry_call alternative of a
4835 -- conditional entry call, the assignments for in-out
4836 -- parameters are incorporated into the statement list that
4837 -- follows, so that there are executed only if the entry
4840 if (Nkind (Parent (N)) = N_Triggering_Alternative
4841 and then N = Triggering_Statement (Parent (N)))
4843 (Nkind (Parent (N)) = N_Entry_Call_Alternative
4844 and then N = Entry_Call_Statement (Parent (N)))
4846 if No (Statements (Parent (N))) then
4847 Set_Statements (Parent (N), New_List);
4850 Prepend (N_Node, Statements (Parent (N)));
4853 Insert_After (Call, N_Node);
4857 Next_Actual (Actual);
4858 Next_Formal_With_Extras (Formal);
4862 -- Finally, create block and analyze it
4865 Make_Block_Statement (Loc,
4866 Declarations => Decls,
4867 Handled_Statement_Sequence =>
4868 Make_Handled_Sequence_Of_Statements (Loc,
4869 Statements => Stats)));
4873 end Build_Simple_Entry_Call;
4875 --------------------------------
4876 -- Build_Task_Activation_Call --
4877 --------------------------------
4879 procedure Build_Task_Activation_Call (N : Node_Id) is
4880 function Activation_Call_Loc return Source_Ptr;
4881 -- Find a suitable source location for the activation call
4883 -------------------------
4884 -- Activation_Call_Loc --
4885 -------------------------
4887 function Activation_Call_Loc return Source_Ptr is
4889 -- The activation call must carry the location of the "end" keyword
4890 -- when the context is a package declaration.
4892 if Nkind (N) = N_Package_Declaration then
4893 return End_Keyword_Location (N);
4895 -- Otherwise the activation call must carry the location of the
4899 return Begin_Keyword_Location (N);
4901 end Activation_Call_Loc;
4912 -- Start of processing for Build_Task_Activation_Call
4915 -- For sequential elaboration policy, all the tasks will be activated at
4916 -- the end of the elaboration.
4918 if Partition_Elaboration_Policy = 'S' then
4921 -- Do not create an activation call for a package spec if the package
4922 -- has a completing body. The activation call will be inserted after
4923 -- the "begin" of the body.
4925 elsif Nkind (N) = N_Package_Declaration
4926 and then Present (Corresponding_Body (N))
4931 -- Obtain the activation chain entity. Block statements, entry bodies,
4932 -- subprogram bodies, and task bodies keep the entity in their nodes.
4933 -- Package bodies on the other hand store it in the declaration of the
4934 -- corresponding package spec.
4938 if Nkind (Owner) = N_Package_Body then
4939 Owner := Unit_Declaration_Node (Corresponding_Spec (Owner));
4942 Chain := Activation_Chain_Entity (Owner);
4944 -- Nothing to do when there are no tasks to activate. This is indicated
4945 -- by a missing activation chain entity.
4951 -- The location of the activation call must be as close as possible to
4952 -- the intended semantic location of the activation because the ABE
4953 -- mechanism relies heavily on accurate locations.
4955 Loc := Activation_Call_Loc;
4957 if Restricted_Profile then
4958 Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc);
4960 Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc);
4964 Make_Procedure_Call_Statement (Loc,
4966 Parameter_Associations =>
4967 New_List (Make_Attribute_Reference (Loc,
4968 Prefix => New_Occurrence_Of (Chain, Loc),
4969 Attribute_Name => Name_Unchecked_Access)));
4971 if Nkind (N) = N_Package_Declaration then
4972 if Present (Private_Declarations (Specification (N))) then
4973 Append (Call, Private_Declarations (Specification (N)));
4975 Append (Call, Visible_Declarations (Specification (N)));
4979 -- The call goes at the start of the statement sequence after the
4980 -- start of exception range label if one is present.
4982 if Present (Handled_Statement_Sequence (N)) then
4983 Stmt := First (Statements (Handled_Statement_Sequence (N)));
4985 -- A special case, skip exception range label if one is present
4986 -- (from front end zcx processing).
4988 if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then
4992 -- Another special case, if the first statement is a block from
4993 -- optimization of a local raise to a goto, then the call goes
4994 -- inside this block.
4996 if Nkind (Stmt) = N_Block_Statement
4997 and then Exception_Junk (Stmt)
4999 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
5002 -- Insertion point is after any exception label pushes, since we
5003 -- want it covered by any local handlers.
5005 while Nkind (Stmt) in N_Push_xxx_Label loop
5009 -- Now we have the proper insertion point
5011 Insert_Before (Stmt, Call);
5014 Set_Handled_Statement_Sequence (N,
5015 Make_Handled_Sequence_Of_Statements (Loc,
5016 Statements => New_List (Call)));
5022 if Legacy_Elaboration_Checks then
5023 Check_Task_Activation (N);
5025 end Build_Task_Activation_Call;
5027 -------------------------------
5028 -- Build_Task_Allocate_Block --
5029 -------------------------------
5031 procedure Build_Task_Allocate_Block
5036 T : constant Entity_Id := Entity (Expression (N));
5037 Init : constant Entity_Id := Base_Init_Proc (T);
5038 Loc : constant Source_Ptr := Sloc (N);
5039 Chain : constant Entity_Id :=
5040 Make_Defining_Identifier (Loc, Name_uChain);
5041 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5046 Make_Block_Statement (Loc,
5047 Identifier => New_Occurrence_Of (Blkent, Loc),
5048 Declarations => New_List (
5050 -- _Chain : Activation_Chain;
5052 Make_Object_Declaration (Loc,
5053 Defining_Identifier => Chain,
5054 Aliased_Present => True,
5055 Object_Definition =>
5056 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5058 Handled_Statement_Sequence =>
5059 Make_Handled_Sequence_Of_Statements (Loc,
5061 Statements => New_List (
5065 Make_Procedure_Call_Statement (Loc,
5066 Name => New_Occurrence_Of (Init, Loc),
5067 Parameter_Associations => Args),
5069 -- Activate_Tasks (_Chain);
5071 Make_Procedure_Call_Statement (Loc,
5072 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5073 Parameter_Associations => New_List (
5074 Make_Attribute_Reference (Loc,
5075 Prefix => New_Occurrence_Of (Chain, Loc),
5076 Attribute_Name => Name_Unchecked_Access))))),
5078 Has_Created_Identifier => True,
5079 Is_Task_Allocation_Block => True);
5082 Make_Implicit_Label_Declaration (Loc,
5083 Defining_Identifier => Blkent,
5084 Label_Construct => Block));
5086 Append_To (Actions, Block);
5088 Set_Activation_Chain_Entity (Block, Chain);
5089 end Build_Task_Allocate_Block;
5091 -----------------------------------------------
5092 -- Build_Task_Allocate_Block_With_Init_Stmts --
5093 -----------------------------------------------
5095 procedure Build_Task_Allocate_Block_With_Init_Stmts
5098 Init_Stmts : List_Id)
5100 Loc : constant Source_Ptr := Sloc (N);
5101 Chain : constant Entity_Id :=
5102 Make_Defining_Identifier (Loc, Name_uChain);
5103 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5107 Append_To (Init_Stmts,
5108 Make_Procedure_Call_Statement (Loc,
5109 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5110 Parameter_Associations => New_List (
5111 Make_Attribute_Reference (Loc,
5112 Prefix => New_Occurrence_Of (Chain, Loc),
5113 Attribute_Name => Name_Unchecked_Access))));
5116 Make_Block_Statement (Loc,
5117 Identifier => New_Occurrence_Of (Blkent, Loc),
5118 Declarations => New_List (
5120 -- _Chain : Activation_Chain;
5122 Make_Object_Declaration (Loc,
5123 Defining_Identifier => Chain,
5124 Aliased_Present => True,
5125 Object_Definition =>
5126 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5128 Handled_Statement_Sequence =>
5129 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
5131 Has_Created_Identifier => True,
5132 Is_Task_Allocation_Block => True);
5135 Make_Implicit_Label_Declaration (Loc,
5136 Defining_Identifier => Blkent,
5137 Label_Construct => Block));
5139 Append_To (Actions, Block);
5141 Set_Activation_Chain_Entity (Block, Chain);
5142 end Build_Task_Allocate_Block_With_Init_Stmts;
5144 -----------------------------------
5145 -- Build_Task_Proc_Specification --
5146 -----------------------------------
5148 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
5149 Loc : constant Source_Ptr := Sloc (T);
5150 Spec_Id : Entity_Id;
5153 -- Case of explicit task type, suffix TB
5155 if Comes_From_Source (T) then
5157 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB"));
5159 -- Case of anonymous task type, suffix B
5163 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B'));
5166 Set_Is_Internal (Spec_Id);
5168 -- Associate the procedure with the task, if this is the declaration
5169 -- (and not the body) of the procedure.
5171 if No (Task_Body_Procedure (T)) then
5172 Set_Task_Body_Procedure (T, Spec_Id);
5176 Make_Procedure_Specification (Loc,
5177 Defining_Unit_Name => Spec_Id,
5178 Parameter_Specifications => New_List (
5179 Make_Parameter_Specification (Loc,
5180 Defining_Identifier =>
5181 Make_Defining_Identifier (Loc, Name_uTask),
5183 Make_Access_Definition (Loc,
5185 New_Occurrence_Of (Corresponding_Record_Type (T), Loc)))));
5186 end Build_Task_Proc_Specification;
5188 ---------------------------------------
5189 -- Build_Unprotected_Subprogram_Body --
5190 ---------------------------------------
5192 function Build_Unprotected_Subprogram_Body
5194 Pid : Node_Id) return Node_Id
5196 Decls : constant List_Id := Declarations (N);
5199 -- Add renamings for the Protection object, discriminals, privals, and
5200 -- the entry index constant for use by debugger.
5202 Debug_Private_Data_Declarations (Decls);
5204 -- Make an unprotected version of the subprogram for use within the same
5205 -- object, with a new name and an additional parameter representing the
5209 Make_Subprogram_Body (Sloc (N),
5211 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
5212 Declarations => Decls,
5213 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
5214 end Build_Unprotected_Subprogram_Body;
5216 ----------------------------
5217 -- Collect_Entry_Families --
5218 ----------------------------
5220 procedure Collect_Entry_Families
5223 Current_Node : in out Node_Id;
5224 Conctyp : Entity_Id)
5227 Efam_Decl : Node_Id;
5228 Efam_Type : Entity_Id;
5231 Efam := First_Entity (Conctyp);
5232 while Present (Efam) loop
5233 if Ekind (Efam) = E_Entry_Family then
5234 Efam_Type := Make_Temporary (Loc, 'F');
5239 (Etype (Discrete_Subtype_Definition (Parent (Efam))));
5241 Bas_Decl : Node_Id := Empty;
5246 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
5248 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
5249 Bas := Make_Temporary (Loc, 'B');
5252 Make_Subtype_Declaration (Loc,
5253 Defining_Identifier => Bas,
5254 Subtype_Indication =>
5255 Make_Subtype_Indication (Loc,
5257 New_Occurrence_Of (Standard_Integer, Loc),
5259 Make_Range_Constraint (Loc,
5260 Range_Expression => Make_Range (Loc,
5261 Make_Integer_Literal
5262 (Loc, -Entry_Family_Bound),
5263 Make_Integer_Literal
5264 (Loc, Entry_Family_Bound - 1)))));
5266 Insert_After (Current_Node, Bas_Decl);
5267 Current_Node := Bas_Decl;
5272 Make_Full_Type_Declaration (Loc,
5273 Defining_Identifier => Efam_Type,
5275 Make_Unconstrained_Array_Definition (Loc,
5277 (New_List (New_Occurrence_Of (Bas, Loc))),
5279 Component_Definition =>
5280 Make_Component_Definition (Loc,
5281 Aliased_Present => False,
5282 Subtype_Indication =>
5283 New_Occurrence_Of (Standard_Character, Loc))));
5286 Insert_After (Current_Node, Efam_Decl);
5287 Current_Node := Efam_Decl;
5288 Analyze (Efam_Decl);
5291 Make_Component_Declaration (Loc,
5292 Defining_Identifier =>
5293 Make_Defining_Identifier (Loc, Chars (Efam)),
5295 Component_Definition =>
5296 Make_Component_Definition (Loc,
5297 Aliased_Present => False,
5298 Subtype_Indication =>
5299 Make_Subtype_Indication (Loc,
5301 New_Occurrence_Of (Efam_Type, Loc),
5304 Make_Index_Or_Discriminant_Constraint (Loc,
5305 Constraints => New_List (
5307 (Etype (Discrete_Subtype_Definition
5308 (Parent (Efam))), Loc)))))));
5314 end Collect_Entry_Families;
5316 -----------------------
5317 -- Concurrent_Object --
5318 -----------------------
5320 function Concurrent_Object
5321 (Spec_Id : Entity_Id;
5322 Conc_Typ : Entity_Id) return Entity_Id
5325 -- Parameter _O or _object
5327 if Is_Protected_Type (Conc_Typ) then
5328 return First_Formal (Protected_Body_Subprogram (Spec_Id));
5333 pragma Assert (Is_Task_Type (Conc_Typ));
5334 return First_Formal (Task_Body_Procedure (Conc_Typ));
5336 end Concurrent_Object;
5338 ----------------------
5339 -- Copy_Result_Type --
5340 ----------------------
5342 function Copy_Result_Type (Res : Node_Id) return Node_Id is
5343 New_Res : constant Node_Id := New_Copy_Tree (Res);
5348 -- If the result type is an access_to_subprogram, we must create new
5349 -- entities for its spec.
5351 if Nkind (New_Res) = N_Access_Definition
5352 and then Present (Access_To_Subprogram_Definition (New_Res))
5354 -- Provide new entities for the formals
5356 Par_Spec := First (Parameter_Specifications
5357 (Access_To_Subprogram_Definition (New_Res)));
5358 while Present (Par_Spec) loop
5359 Formal := Defining_Identifier (Par_Spec);
5360 Set_Defining_Identifier (Par_Spec,
5361 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
5367 end Copy_Result_Type;
5369 --------------------
5370 -- Concurrent_Ref --
5371 --------------------
5373 -- The expression returned for a reference to a concurrent object has the
5376 -- taskV!(name)._Task_Id
5380 -- objectV!(name)._Object
5382 -- for a protected object. For the case of an access to a concurrent
5383 -- object, there is an extra explicit dereference:
5385 -- taskV!(name.all)._Task_Id
5386 -- objectV!(name.all)._Object
5388 -- here taskV and objectV are the types for the associated records, which
5389 -- contain the required _Task_Id and _Object fields for tasks and protected
5390 -- objects, respectively.
5392 -- For the case of a task type name, the expression is
5396 -- i.e. a call to the Self function which returns precisely this Task_Id
5398 -- For the case of a protected type name, the expression is
5402 -- which is a renaming of the _object field of the current object
5403 -- record, passed into protected operations as a parameter.
5405 function Concurrent_Ref (N : Node_Id) return Node_Id is
5406 Loc : constant Source_Ptr := Sloc (N);
5407 Ntyp : constant Entity_Id := Etype (N);
5411 function Is_Current_Task (T : Entity_Id) return Boolean;
5412 -- Check whether the reference is to the immediately enclosing task
5413 -- type, or to an outer one (rare but legal).
5415 ---------------------
5416 -- Is_Current_Task --
5417 ---------------------
5419 function Is_Current_Task (T : Entity_Id) return Boolean is
5423 Scop := Current_Scope;
5424 while Present (Scop) and then Scop /= Standard_Standard loop
5428 elsif Is_Task_Type (Scop) then
5431 -- If this is a procedure nested within the task type, we must
5432 -- assume that it can be called from an inner task, and therefore
5433 -- cannot treat it as a local reference.
5435 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then
5439 Scop := Scope (Scop);
5443 -- We know that we are within the task body, so should have found it
5446 raise Program_Error;
5447 end Is_Current_Task;
5449 -- Start of processing for Concurrent_Ref
5452 if Is_Access_Type (Ntyp) then
5453 Dtyp := Designated_Type (Ntyp);
5455 if Is_Protected_Type (Dtyp) then
5456 Sel := Name_uObject;
5458 Sel := Name_uTask_Id;
5462 Make_Selected_Component (Loc,
5464 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
5465 Make_Explicit_Dereference (Loc, N)),
5466 Selector_Name => Make_Identifier (Loc, Sel));
5468 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then
5469 if Is_Task_Type (Entity (N)) then
5471 if Is_Current_Task (Entity (N)) then
5473 Make_Function_Call (Loc,
5474 Name => New_Occurrence_Of (RTE (RE_Self), Loc));
5479 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T');
5480 T_Body : constant Node_Id :=
5481 Parent (Corresponding_Body (Parent (Entity (N))));
5485 Make_Object_Declaration (Loc,
5486 Defining_Identifier => T_Self,
5487 Object_Definition =>
5488 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
5490 Make_Function_Call (Loc,
5491 Name => New_Occurrence_Of (RTE (RE_Self), Loc)));
5492 Prepend (Decl, Declarations (T_Body));
5494 Set_Scope (T_Self, Entity (N));
5495 return New_Occurrence_Of (T_Self, Loc);
5500 pragma Assert (Is_Protected_Type (Entity (N)));
5503 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc);
5507 if Is_Protected_Type (Ntyp) then
5508 Sel := Name_uObject;
5509 elsif Is_Task_Type (Ntyp) then
5510 Sel := Name_uTask_Id;
5512 raise Program_Error;
5516 Make_Selected_Component (Loc,
5518 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
5520 Selector_Name => Make_Identifier (Loc, Sel));
5524 ------------------------
5525 -- Convert_Concurrent --
5526 ------------------------
5528 function Convert_Concurrent
5530 Typ : Entity_Id) return Node_Id
5533 if not Is_Concurrent_Type (Typ) then
5537 Unchecked_Convert_To
5538 (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
5540 end Convert_Concurrent;
5542 -------------------------------------
5543 -- Create_Secondary_Stack_For_Task --
5544 -------------------------------------
5546 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is
5549 (Restriction_Active (No_Implicit_Heap_Allocations)
5550 or else Restriction_Active (No_Implicit_Task_Allocations))
5551 and then not Restriction_Active (No_Secondary_Stack)
5552 and then Has_Rep_Pragma
5553 (T, Name_Secondary_Stack_Size, Check_Parents => False);
5554 end Create_Secondary_Stack_For_Task;
5556 -------------------------------------
5557 -- Debug_Private_Data_Declarations --
5558 -------------------------------------
5560 procedure Debug_Private_Data_Declarations (Decls : List_Id) is
5561 Debug_Nod : Node_Id;
5565 Decl := First (Decls);
5566 while Present (Decl) and then not Comes_From_Source (Decl) loop
5568 -- Declaration for concurrent entity _object and its access type,
5569 -- along with the entry index subtype:
5570 -- type prot_typVP is access prot_typV;
5571 -- _object : prot_typVP := prot_typV (_O);
5572 -- subtype Jnn is <Type of Index> range Low .. High;
5574 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then
5575 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5577 -- Declaration for the Protection object, discriminals, privals, and
5578 -- entry index constant:
5579 -- conc_typR : protection_typ renames _object._object;
5580 -- discr_nameD : discr_typ renames _object.discr_name;
5581 -- discr_nameD : discr_typ renames _task.discr_name;
5582 -- prival_name : comp_typ renames _object.comp_name;
5583 -- J : constant Jnn :=
5584 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5586 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
5587 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5588 Debug_Nod := Debug_Renaming_Declaration (Decl);
5590 if Present (Debug_Nod) then
5591 Insert_After (Decl, Debug_Nod);
5597 end Debug_Private_Data_Declarations;
5599 ------------------------------
5600 -- Ensure_Statement_Present --
5601 ------------------------------
5603 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is
5607 if Opt.Suppress_Control_Flow_Optimizations
5608 and then Is_Empty_List (Statements (Alt))
5610 Stmt := Make_Null_Statement (Loc);
5612 -- Mark NULL statement as coming from source so that it is not
5613 -- eliminated by GIGI.
5615 -- Another covert channel. If this is a requirement, it must be
5616 -- documented in sinfo/einfo ???
5618 Set_Comes_From_Source (Stmt, True);
5620 Set_Statements (Alt, New_List (Stmt));
5622 end Ensure_Statement_Present;
5624 ----------------------------
5625 -- Entry_Index_Expression --
5626 ----------------------------
5628 function Entry_Index_Expression
5632 Ttyp : Entity_Id) return Node_Id
5642 -- The queues of entries and entry families appear in textual order in
5643 -- the associated record. The entry index is computed as the sum of the
5644 -- number of queues for all entries that precede the designated one, to
5645 -- which is added the index expression, if this expression denotes a
5646 -- member of a family.
5648 -- The following is a place holder for the count of simple entries
5650 Num := Make_Integer_Literal (Sloc, 1);
5652 -- We construct an expression which is a series of addition operations.
5653 -- The first operand is the number of single entries that precede this
5654 -- one, the second operand is the index value relative to the start of
5655 -- the referenced family, and the remaining operands are the lengths of
5656 -- the entry families that precede this entry, i.e. the constructed
5659 -- number_simple_entries +
5660 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5661 -- family'length + ...
5663 -- where index-value is the given index value, and s is the index
5664 -- subtype (we have to use pos because the subtype might be an
5665 -- enumeration type preventing direct subtraction). Note that the task
5666 -- entry array is one-indexed.
5668 -- The upper bound of the entry family may be a discriminant, so we
5669 -- retrieve the lower bound explicitly to compute offset, rather than
5670 -- using the index subtype which may mention a discriminant.
5672 if Present (Index) then
5673 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
5681 Make_Attribute_Reference (Sloc,
5682 Attribute_Name => Name_Pos,
5683 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
5684 Expressions => New_List (Relocate_Node (Index))),
5692 -- Now add lengths of preceding entries and entry families
5694 Prev := First_Entity (Ttyp);
5695 while Chars (Prev) /= Chars (Ent)
5696 or else (Ekind (Prev) /= Ekind (Ent))
5697 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
5699 if Ekind (Prev) = E_Entry then
5700 Set_Intval (Num, Intval (Num) + 1);
5702 elsif Ekind (Prev) = E_Entry_Family then
5703 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
5704 Lo := Type_Low_Bound (S);
5705 Hi := Type_High_Bound (S);
5710 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
5712 -- Other components are anonymous types to be ignored
5722 end Entry_Index_Expression;
5724 ---------------------------
5725 -- Establish_Task_Master --
5726 ---------------------------
5728 procedure Establish_Task_Master (N : Node_Id) is
5732 if Restriction_Active (No_Task_Hierarchy) = False then
5733 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
5735 -- The block may have no declarations (and nevertheless be a task
5736 -- master) if it contains a call that may return an object that
5739 if No (Declarations (N)) then
5740 Set_Declarations (N, New_List (Call));
5742 Prepend_To (Declarations (N), Call);
5747 end Establish_Task_Master;
5749 --------------------------------
5750 -- Expand_Accept_Declarations --
5751 --------------------------------
5753 -- Part of the expansion of an accept statement involves the creation of
5754 -- a declaration that can be referenced from the statement sequence of
5759 -- This declaration is inserted immediately before the accept statement
5760 -- and it is important that it be inserted before the statements of the
5761 -- statement sequence are analyzed. Thus it would be too late to create
5762 -- this declaration in the Expand_N_Accept_Statement routine, which is
5763 -- why there is a separate procedure to be called directly from Sem_Ch9.
5765 -- Ann is used to hold the address of the record containing the parameters
5766 -- (see Expand_N_Entry_Call for more details on how this record is built).
5767 -- References to the parameters do an unchecked conversion of this address
5768 -- to a pointer to the required record type, and then access the field that
5769 -- holds the value of the required parameter. The entity for the address
5770 -- variable is held as the top stack element (i.e. the last element) of the
5771 -- Accept_Address stack in the corresponding entry entity, and this element
5772 -- must be set in place before the statements are processed.
5774 -- The above description applies to the case of a stand alone accept
5775 -- statement, i.e. one not appearing as part of a select alternative.
5777 -- For the case of an accept that appears as part of a select alternative
5778 -- of a selective accept, we must still create the declaration right away,
5779 -- since Ann is needed immediately, but there is an important difference:
5781 -- The declaration is inserted before the selective accept, not before
5782 -- the accept statement (which is not part of a list anyway, and so would
5783 -- not accommodate inserted declarations)
5785 -- We only need one address variable for the entire selective accept. So
5786 -- the Ann declaration is created only for the first accept alternative,
5787 -- and subsequent accept alternatives reference the same Ann variable.
5789 -- We can distinguish the two cases by seeing whether the accept statement
5790 -- is part of a list. If not, then it must be in an accept alternative.
5792 -- To expand the requeue statement, a label is provided at the end of the
5793 -- accept statement or alternative of which it is a part, so that the
5794 -- statement can be skipped after the requeue is complete. This label is
5795 -- created here rather than during the expansion of the accept statement,
5796 -- because it will be needed by any requeue statements within the accept,
5797 -- which are expanded before the accept.
5799 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
5800 Loc : constant Source_Ptr := Sloc (N);
5801 Stats : constant Node_Id := Handled_Statement_Sequence (N);
5802 Ann : Entity_Id := Empty;
5809 if Expander_Active then
5811 -- If we have no handled statement sequence, we may need to build
5812 -- a dummy sequence consisting of a null statement. This can be
5813 -- skipped if the trivial accept optimization is permitted.
5815 if not Trivial_Accept_OK
5816 and then (No (Stats) or else Null_Statements (Statements (Stats)))
5818 Set_Handled_Statement_Sequence (N,
5819 Make_Handled_Sequence_Of_Statements (Loc,
5820 Statements => New_List (Make_Null_Statement (Loc))));
5823 -- Create and declare two labels to be placed at the end of the
5824 -- accept statement. The first label is used to allow requeues to
5825 -- skip the remainder of entry processing. The second label is used
5826 -- to skip the remainder of entry processing if the rendezvous
5827 -- completes in the middle of the accept body.
5829 if Present (Handled_Statement_Sequence (N)) then
5834 Ent := Make_Temporary (Loc, 'L');
5835 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5837 Make_Implicit_Label_Declaration (Loc,
5838 Defining_Identifier => Ent,
5839 Label_Construct => Lab);
5840 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5842 Ent := Make_Temporary (Loc, 'L');
5843 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5845 Make_Implicit_Label_Declaration (Loc,
5846 Defining_Identifier => Ent,
5847 Label_Construct => Lab);
5848 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5856 -- Case of stand alone accept statement
5858 if Is_List_Member (N) then
5860 if Present (Handled_Statement_Sequence (N)) then
5861 Ann := Make_Temporary (Loc, 'A');
5864 Make_Object_Declaration (Loc,
5865 Defining_Identifier => Ann,
5866 Object_Definition =>
5867 New_Occurrence_Of (RTE (RE_Address), Loc));
5869 Insert_Before_And_Analyze (N, Adecl);
5870 Insert_Before_And_Analyze (N, Ldecl);
5871 Insert_Before_And_Analyze (N, Ldecl2);
5874 -- Case of accept statement which is in an accept alternative
5878 Acc_Alt : constant Node_Id := Parent (N);
5879 Sel_Acc : constant Node_Id := Parent (Acc_Alt);
5883 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
5884 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
5886 -- ??? Consider a single label for select statements
5888 if Present (Handled_Statement_Sequence (N)) then
5890 Statements (Handled_Statement_Sequence (N)));
5894 Statements (Handled_Statement_Sequence (N)));
5898 -- Find first accept alternative of the selective accept. A
5899 -- valid selective accept must have at least one accept in it.
5901 Alt := First (Select_Alternatives (Sel_Acc));
5903 while Nkind (Alt) /= N_Accept_Alternative loop
5907 -- If this is the first accept statement, then we have to
5908 -- create the Ann variable, as for the stand alone case, except
5909 -- that it is inserted before the selective accept. Similarly,
5910 -- a label for requeue expansion must be declared.
5912 if N = Accept_Statement (Alt) then
5913 Ann := Make_Temporary (Loc, 'A');
5915 Make_Object_Declaration (Loc,
5916 Defining_Identifier => Ann,
5917 Object_Definition =>
5918 New_Occurrence_Of (RTE (RE_Address), Loc));
5920 Insert_Before_And_Analyze (Sel_Acc, Adecl);
5922 -- If this is not the first accept statement, then find the Ann
5923 -- variable allocated by the first accept and use it.
5927 Node (Last_Elmt (Accept_Address
5928 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
5933 -- Merge here with Ann either created or referenced, and Adecl
5934 -- pointing to the corresponding declaration. Remaining processing
5935 -- is the same for the two cases.
5937 if Present (Ann) then
5938 Append_Elmt (Ann, Accept_Address (Ent));
5939 Set_Debug_Info_Needed (Ann);
5942 -- Create renaming declarations for the entry formals. Each reference
5943 -- to a formal becomes a dereference of a component of the parameter
5944 -- block, whose address is held in Ann. These declarations are
5945 -- eventually inserted into the accept block, and analyzed there so
5946 -- that they have the proper scope for gdb and do not conflict with
5947 -- other declarations.
5949 if Present (Parameter_Specifications (N))
5950 and then Present (Handled_Statement_Sequence (N))
5957 Renamed_Formal : Node_Id;
5961 Formal := First_Formal (Ent);
5963 while Present (Formal) loop
5964 Comp := Entry_Component (Formal);
5965 New_F := Make_Defining_Identifier (Loc, Chars (Formal));
5967 Set_Etype (New_F, Etype (Formal));
5968 Set_Scope (New_F, Ent);
5970 -- Now we set debug info needed on New_F even though it does
5971 -- not come from source, so that the debugger will get the
5972 -- right information for these generated names.
5974 Set_Debug_Info_Needed (New_F);
5976 if Ekind (Formal) = E_In_Parameter then
5977 Set_Ekind (New_F, E_Constant);
5979 Set_Ekind (New_F, E_Variable);
5980 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
5983 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
5986 Make_Selected_Component (Loc,
5988 Unchecked_Convert_To (
5989 Entry_Parameters_Type (Ent),
5990 New_Occurrence_Of (Ann, Loc)),
5992 New_Occurrence_Of (Comp, Loc));
5995 Build_Renamed_Formal_Declaration
5996 (New_F, Formal, Comp, Renamed_Formal);
5998 if No (Declarations (N)) then
5999 Set_Declarations (N, New_List);
6002 Append (Decl, Declarations (N));
6003 Set_Renamed_Object (Formal, New_F);
6004 Next_Formal (Formal);
6011 end Expand_Accept_Declarations;
6013 ---------------------------------------------
6014 -- Expand_Access_Protected_Subprogram_Type --
6015 ---------------------------------------------
6017 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
6018 Loc : constant Source_Ptr := Sloc (N);
6019 T : constant Entity_Id := Defining_Identifier (N);
6020 D_T : constant Entity_Id := Designated_Type (T);
6021 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D');
6022 E_T : constant Entity_Id := Make_Temporary (Loc, 'E');
6023 P_List : constant List_Id :=
6024 Build_Protected_Spec (N, RTE (RE_Address), D_T, False);
6032 -- Create access to subprogram with full signature
6034 if Etype (D_T) /= Standard_Void_Type then
6036 Make_Access_Function_Definition (Loc,
6037 Parameter_Specifications => P_List,
6038 Result_Definition =>
6039 Copy_Result_Type (Result_Definition (Type_Definition (N))));
6043 Make_Access_Procedure_Definition (Loc,
6044 Parameter_Specifications => P_List);
6048 Make_Full_Type_Declaration (Loc,
6049 Defining_Identifier => D_T2,
6050 Type_Definition => Def1);
6052 -- Declare the new types before the original one since the latter will
6053 -- refer to them through the Equivalent_Type slot.
6055 Insert_Before_And_Analyze (N, Decl1);
6057 -- Associate the access to subprogram with its original access to
6058 -- protected subprogram type. Needed by the backend to know that this
6059 -- type corresponds with an access to protected subprogram type.
6061 Set_Original_Access_Type (D_T2, T);
6063 -- Create Equivalent_Type, a record with two components for an access to
6064 -- object and an access to subprogram.
6067 Make_Component_Declaration (Loc,
6068 Defining_Identifier => Make_Temporary (Loc, 'P'),
6069 Component_Definition =>
6070 Make_Component_Definition (Loc,
6071 Aliased_Present => False,
6072 Subtype_Indication =>
6073 New_Occurrence_Of (RTE (RE_Address), Loc))),
6075 Make_Component_Declaration (Loc,
6076 Defining_Identifier => Make_Temporary (Loc, 'S'),
6077 Component_Definition =>
6078 Make_Component_Definition (Loc,
6079 Aliased_Present => False,
6080 Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
6083 Make_Full_Type_Declaration (Loc,
6084 Defining_Identifier => E_T,
6086 Make_Record_Definition (Loc,
6088 Make_Component_List (Loc, Component_Items => Comps)));
6090 Insert_Before_And_Analyze (N, Decl2);
6091 Set_Equivalent_Type (T, E_T);
6092 end Expand_Access_Protected_Subprogram_Type;
6094 --------------------------
6095 -- Expand_Entry_Barrier --
6096 --------------------------
6098 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
6099 Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N));
6100 Prot : constant Entity_Id := Scope (Ent);
6101 Spec_Decl : constant Node_Id := Parent (Prot);
6103 Func_Id : Entity_Id := Empty;
6104 -- The entity of the barrier function
6106 function Is_Global_Entity (N : Node_Id) return Traverse_Result;
6107 -- Check whether entity in Barrier is external to protected type.
6108 -- If so, barrier may not be properly synchronized.
6110 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
6111 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6114 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean;
6115 -- Check whether entity name N denotes a component of the protected
6116 -- object. This is used to check the Simple_Barrier restriction.
6118 ----------------------
6119 -- Is_Global_Entity --
6120 ----------------------
6122 function Is_Global_Entity (N : Node_Id) return Traverse_Result is
6127 if Is_Entity_Name (N) and then Present (Entity (N)) then
6131 if Ekind (E) = E_Variable then
6133 -- If the variable is local to the barrier function generated
6134 -- during expansion, it is ok. If expansion is not performed,
6135 -- then Func is Empty so this test cannot succeed.
6137 if Scope (E) = Func_Id then
6140 -- A protected call from a barrier to another object is ok
6142 elsif Ekind (Etype (E)) = E_Protected_Type then
6145 -- If the variable is within the package body we consider
6146 -- this safe. This is a common (if dubious) idiom.
6148 elsif S = Scope (Prot)
6149 and then Ekind_In (S, E_Package, E_Generic_Package)
6150 and then Nkind (Parent (E)) = N_Object_Declaration
6151 and then Nkind (Parent (Parent (E))) = N_Package_Body
6156 Error_Msg_N ("potentially unsynchronized barrier??", N);
6157 Error_Msg_N ("\& should be private component of type??", N);
6163 end Is_Global_Entity;
6165 procedure Check_Unprotected_Barrier is
6166 new Traverse_Proc (Is_Global_Entity);
6168 ----------------------------
6169 -- Is_Simple_Barrier_Name --
6170 ----------------------------
6172 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
6176 -- Check if the name is a component of the protected object. If
6177 -- the expander is active, the component has been transformed into a
6178 -- renaming of _object.all.component. Original_Node is needed in case
6179 -- validity checking is enabled, in which case the simple object
6180 -- reference will have been rewritten.
6182 if Expander_Active then
6184 -- The expanded name may have been constant folded in which case
6185 -- the original node is not necessarily an entity name (e.g. an
6186 -- indexed component).
6188 if not Is_Entity_Name (Original_Node (N)) then
6192 Renamed := Renamed_Object (Entity (Original_Node (N)));
6196 and then Nkind (Renamed) = N_Selected_Component
6197 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
6199 return Is_Protected_Component (Entity (N));
6201 end Is_Simple_Barrier_Name;
6203 ---------------------
6204 -- Is_Pure_Barrier --
6205 ---------------------
6207 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
6210 when N_Expanded_Name
6213 if No (Entity (N)) then
6216 elsif Is_Universal_Numeric_Type (Entity (N)) then
6220 case Ekind (Entity (N)) is
6223 | E_Enumeration_Literal
6233 if Is_Simple_Barrier_Name (N) then
6239 -- The count attribute has been transformed into run-time
6242 if Is_RTE (Entity (N), RE_Protected_Count)
6243 or else Is_RTE (Entity (N), RE_Protected_Count_Entry)
6252 when N_Function_Call =>
6254 -- Function call checks are carried out as part of the analysis
6255 -- of the function call name.
6259 when N_Character_Literal
6268 if Ekind (Entity (N)) = E_Operator then
6272 when N_Short_Circuit =>
6275 when N_Indexed_Component
6276 | N_Selected_Component
6278 if not Is_Access_Type (Etype (Prefix (N))) then
6282 when N_Type_Conversion =>
6284 -- Conversions to Universal_Integer will not raise constraint
6287 if Cannot_Raise_Constraint_Error (N)
6288 or else Etype (N) = Universal_Integer
6293 when N_Unchecked_Type_Conversion =>
6301 end Is_Pure_Barrier;
6303 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier);
6307 Cond_Id : Entity_Id;
6308 Entry_Body : Node_Id;
6309 Func_Body : Node_Id := Empty;
6311 -- Start of processing for Expand_Entry_Barrier
6314 if No_Run_Time_Mode then
6315 Error_Msg_CRT ("entry barrier", N);
6319 -- The body of the entry barrier must be analyzed in the context of the
6320 -- protected object, but its scope is external to it, just as any other
6321 -- unprotected version of a protected operation. The specification has
6322 -- been produced when the protected type declaration was elaborated. We
6323 -- build the body, insert it in the enclosing scope, but analyze it in
6324 -- the current context. A more uniform approach would be to treat the
6325 -- barrier just as a protected function, and discard the protected
6326 -- version of it because it is never called.
6328 if Expander_Active then
6329 Func_Body := Build_Barrier_Function (N, Ent, Prot);
6330 Func_Id := Barrier_Function (Ent);
6331 Set_Corresponding_Spec (Func_Body, Func_Id);
6333 Entry_Body := Parent (Corresponding_Body (Spec_Decl));
6335 if Nkind (Parent (Entry_Body)) = N_Subunit then
6336 Entry_Body := Corresponding_Stub (Parent (Entry_Body));
6339 Insert_Before_And_Analyze (Entry_Body, Func_Body);
6341 Set_Discriminals (Spec_Decl);
6342 Set_Scope (Func_Id, Scope (Prot));
6345 Analyze_And_Resolve (Cond, Any_Boolean);
6348 -- Check Pure_Barriers restriction
6350 if Check_Pure_Barriers (Cond) = Abandon then
6351 Check_Restriction (Pure_Barriers, Cond);
6354 -- The Ravenscar profile restricts barriers to simple variables declared
6355 -- within the protected object. We also allow Boolean constants, since
6356 -- these appear in several published examples and are also allowed by
6359 -- Note that after analysis variables in this context will be replaced
6360 -- by the corresponding prival, that is to say a renaming of a selected
6361 -- component of the form _Object.Var. If expansion is disabled, as
6362 -- within a generic, we check that the entity appears in the current
6365 if Is_Entity_Name (Cond) then
6366 Cond_Id := Entity (Cond);
6368 -- Perform a small optimization of simple barrier functions. If the
6369 -- scope of the condition's entity is not the barrier function, then
6370 -- the condition does not depend on any of the generated renamings.
6371 -- If this is the case, eliminate the renamings as they are useless.
6372 -- This optimization is not performed when the condition was folded
6373 -- and validity checks are in effect because the original condition
6374 -- may have produced at least one check that depends on the generated
6378 and then Scope (Cond_Id) /= Func_Id
6379 and then not Validity_Check_Operands
6381 Set_Declarations (Func_Body, Empty_List);
6384 if Cond_Id = Standard_False or else Cond_Id = Standard_True then
6387 elsif Is_Simple_Barrier_Name (Cond) then
6392 -- It is not a boolean variable or literal, so check the restriction.
6393 -- Note that it is safe to be calling Check_Restriction from here, even
6394 -- though this is part of the expander, since Expand_Entry_Barrier is
6395 -- called from Sem_Ch9 even in -gnatc mode.
6397 Check_Restriction (Simple_Barriers, Cond);
6399 -- Emit warning if barrier contains global entities and is thus
6400 -- potentially unsynchronized.
6402 Check_Unprotected_Barrier (Cond);
6403 end Expand_Entry_Barrier;
6405 ------------------------------
6406 -- Expand_N_Abort_Statement --
6407 ------------------------------
6409 -- Expand abort T1, T2, .. Tn; into:
6410 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6412 procedure Expand_N_Abort_Statement (N : Node_Id) is
6413 Loc : constant Source_Ptr := Sloc (N);
6414 Tlist : constant List_Id := Names (N);
6420 Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
6423 Tasknm := First (Tlist);
6425 while Present (Tasknm) loop
6428 -- A task interface class-wide type object is being aborted. Retrieve
6429 -- its _task_id by calling a dispatching routine.
6431 if Ada_Version >= Ada_2005
6432 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
6433 and then Is_Interface (Etype (Tasknm))
6434 and then Is_Task_Interface (Etype (Tasknm))
6436 Append_To (Component_Associations (Aggr),
6437 Make_Component_Association (Loc,
6438 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6441 -- Task_Id (Tasknm._disp_get_task_id)
6443 Make_Unchecked_Type_Conversion (Loc,
6445 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6447 Make_Selected_Component (Loc,
6448 Prefix => New_Copy_Tree (Tasknm),
6450 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
6453 Append_To (Component_Associations (Aggr),
6454 Make_Component_Association (Loc,
6455 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6456 Expression => Concurrent_Ref (Tasknm)));
6463 Make_Procedure_Call_Statement (Loc,
6464 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc),
6465 Parameter_Associations => New_List (
6466 Make_Qualified_Expression (Loc,
6467 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc),
6468 Expression => Aggr))));
6471 end Expand_N_Abort_Statement;
6473 -------------------------------
6474 -- Expand_N_Accept_Statement --
6475 -------------------------------
6477 -- This procedure handles expansion of accept statements that stand alone,
6478 -- i.e. they are not part of an accept alternative. The expansion of
6479 -- accept statement in accept alternatives is handled by the routines
6480 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6481 -- following description applies only to stand alone accept statements.
6483 -- If there is no handled statement sequence, or only null statements, then
6484 -- this is called a trivial accept, and the expansion is:
6486 -- Accept_Trivial (entry-index)
6488 -- If there is a handled statement sequence, then the expansion is:
6495 -- Accept_Call (entry-index, Ann);
6496 -- Renaming_Declarations for formals
6497 -- <statement sequence from N_Accept_Statement node>
6498 -- Complete_Rendezvous;
6503 -- <exception handler from N_Accept_Statement node>
6504 -- Complete_Rendezvous;
6506 -- <exception handler from N_Accept_Statement node>
6507 -- Complete_Rendezvous;
6512 -- when all others =>
6513 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6516 -- The first three declarations were already inserted ahead of the accept
6517 -- statement by the Expand_Accept_Declarations procedure, which was called
6518 -- directly from the semantics during analysis of the accept statement,
6519 -- before analyzing its contained statements.
6521 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6522 -- from possible expansion activity (the original source of course does
6523 -- not have any declarations associated with the accept statement, since
6524 -- an accept statement has no declarative part). In particular, if the
6525 -- expander is active, the first such declaration is the declaration of
6526 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6528 -- The two blocks are merged into a single block if the inner block has
6529 -- no exception handlers, but otherwise two blocks are required, since
6530 -- exceptions might be raised in the exception handlers of the inner
6531 -- block, and Exceptional_Complete_Rendezvous must be called.
6533 procedure Expand_N_Accept_Statement (N : Node_Id) is
6534 Loc : constant Source_Ptr := Sloc (N);
6535 Stats : constant Node_Id := Handled_Statement_Sequence (N);
6536 Ename : constant Node_Id := Entry_Direct_Name (N);
6537 Eindx : constant Node_Id := Entry_Index (N);
6538 Eent : constant Entity_Id := Entity (Ename);
6539 Acstack : constant Elist_Id := Accept_Address (Eent);
6540 Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
6541 Ttyp : constant Entity_Id := Etype (Scope (Eent));
6547 -- If the accept statement is not part of a list, then its parent must
6548 -- be an accept alternative, and, as described above, we do not do any
6549 -- expansion for such accept statements at this level.
6551 if not Is_List_Member (N) then
6552 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
6555 -- Trivial accept case (no statement sequence, or null statements).
6556 -- If the accept statement has declarations, then just insert them
6557 -- before the procedure call.
6559 elsif Trivial_Accept_OK
6560 and then (No (Stats) or else Null_Statements (Statements (Stats)))
6562 -- Remove declarations for renamings, because the parameter block
6563 -- will not be assigned.
6570 D := First (Declarations (N));
6571 while Present (D) loop
6573 if Nkind (D) = N_Object_Renaming_Declaration then
6581 if Present (Declarations (N)) then
6582 Insert_Actions (N, Declarations (N));
6586 Make_Procedure_Call_Statement (Loc,
6587 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc),
6588 Parameter_Associations => New_List (
6589 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
6593 -- Discard Entry_Address that was created for it, so it will not be
6594 -- emitted if this accept statement is in the statement part of a
6595 -- delay alternative.
6597 if Present (Stats) then
6598 Remove_Last_Elmt (Acstack);
6601 -- Case of statement sequence present
6604 -- Construct the block, using the declarations from the accept
6605 -- statement if any to initialize the declarations of the block.
6607 Blkent := Make_Temporary (Loc, 'A');
6608 Set_Ekind (Blkent, E_Block);
6609 Set_Etype (Blkent, Standard_Void_Type);
6610 Set_Scope (Blkent, Current_Scope);
6613 Make_Block_Statement (Loc,
6614 Identifier => New_Occurrence_Of (Blkent, Loc),
6615 Declarations => Declarations (N),
6616 Handled_Statement_Sequence => Build_Accept_Body (N));
6618 -- For the analysis of the generated declarations, the parent node
6619 -- must be properly set.
6621 Set_Parent (Block, Parent (N));
6623 -- Prepend call to Accept_Call to main statement sequence If the
6624 -- accept has exception handlers, the statement sequence is wrapped
6625 -- in a block. Insert call and renaming declarations in the
6626 -- declarations of the block, so they are elaborated before the
6630 Make_Procedure_Call_Statement (Loc,
6631 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc),
6632 Parameter_Associations => New_List (
6633 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
6634 New_Occurrence_Of (Ann, Loc)));
6636 if Parent (Stats) = N then
6637 Prepend (Call, Statements (Stats));
6639 Set_Declarations (Parent (Stats), New_List (Call));
6644 Push_Scope (Blkent);
6652 D := First (Declarations (N));
6653 while Present (D) loop
6656 if Nkind (D) = N_Object_Renaming_Declaration then
6658 -- The renaming declarations for the formals were created
6659 -- during analysis of the accept statement, and attached to
6660 -- the list of declarations. Place them now in the context
6661 -- of the accept block or subprogram.
6664 Typ := Entity (Subtype_Mark (D));
6665 Insert_After (Call, D);
6668 -- If the formal is class_wide, it does not have an actual
6669 -- subtype. The analysis of the renaming declaration creates
6670 -- one, but we need to retain the class-wide nature of the
6673 if Is_Class_Wide_Type (Typ) then
6674 Set_Etype (Defining_Identifier (D), Typ);
6685 -- Replace the accept statement by the new block
6690 -- Last step is to unstack the Accept_Address value
6692 Remove_Last_Elmt (Acstack);
6694 end Expand_N_Accept_Statement;
6696 ----------------------------------
6697 -- Expand_N_Asynchronous_Select --
6698 ----------------------------------
6700 -- This procedure assumes that the trigger statement is an entry call or
6701 -- a dispatching procedure call. A delay alternative should already have
6702 -- been expanded into an entry call to the appropriate delay object Wait
6705 -- If the trigger is a task entry call, the select is implemented with
6706 -- a Task_Entry_Call:
6711 -- P : parms := (parm, parm, parm);
6713 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6715 -- procedure _clean is
6718 -- Cancel_Task_Entry_Call (C);
6725 -- (<acceptor-task>, -- Acceptor
6726 -- <entry-index>, -- E
6727 -- P'Address, -- Uninterpreted_Data
6728 -- Asynchronous_Call, -- Mode
6729 -- B); -- Rendezvous_Successful
6736 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6739 -- when Abort_Signal => Abort_Undefer;
6746 -- <triggered-statements>
6750 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6751 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6755 -- P : parms := (parm, parm, parm);
6757 -- Call_Simple (acceptor-task, entry-index, P'Address);
6763 -- so the task at hand is to convert the latter expansion into the former
6765 -- If the trigger is a protected entry call, the select is implemented
6766 -- with Protected_Entry_Call:
6769 -- P : E1_Params := (param, param, param);
6770 -- Bnn : Communications_Block;
6775 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6777 -- procedure _clean is
6780 -- if Enqueued (Bnn) then
6781 -- Cancel_Protected_Entry_Call (Bnn);
6788 -- Protected_Entry_Call
6789 -- (po._object'Access, -- Object
6790 -- <entry index>, -- E
6791 -- P'Address, -- Uninterpreted_Data
6792 -- Asynchronous_Call, -- Mode
6795 -- if Enqueued (Bnn) then
6799 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6802 -- when Abort_Signal => Abort_Undefer;
6805 -- if not Cancelled (Bnn) then
6806 -- <triggered-statements>
6810 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6814 -- P : E1_Params := (param, param, param);
6815 -- Bnn : Communications_Block;
6818 -- Protected_Entry_Call
6819 -- (po._object'Access, -- Object
6820 -- <entry index>, -- E
6821 -- P'Address, -- Uninterpreted_Data
6822 -- Simple_Call, -- Mode
6829 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6833 -- B : Boolean := False;
6834 -- Bnn : Communication_Block;
6835 -- C : Ada.Tags.Prim_Op_Kind;
6836 -- D : System.Storage_Elements.Dummy_Communication_Block;
6837 -- K : Ada.Tags.Tagged_Kind :=
6838 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6839 -- P : Parameters := (Param1 .. ParamN);
6844 -- if K = Ada.Tags.TK_Limited_Tagged
6845 -- or else K = Ada.Tags.TK_Tagged
6847 -- <dispatching-call>;
6848 -- <triggering-statements>;
6852 -- Ada.Tags.Get_Offset_Index
6853 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6855 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6857 -- if C = POK_Protected_Entry then
6859 -- procedure _clean is
6861 -- if Enqueued (Bnn) then
6862 -- Cancel_Protected_Entry_Call (Bnn);
6868 -- _Disp_Asynchronous_Select
6869 -- (<object>, S, P'Address, D, B);
6870 -- Bnn := Communication_Block (D);
6872 -- Param1 := P.Param1;
6874 -- ParamN := P.ParamN;
6876 -- if Enqueued (Bnn) then
6877 -- <abortable-statements>
6880 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6883 -- when Abort_Signal => Abort_Undefer;
6886 -- if not Cancelled (Bnn) then
6887 -- <triggering-statements>
6890 -- elsif C = POK_Task_Entry then
6892 -- procedure _clean is
6894 -- Cancel_Task_Entry_Call (U);
6900 -- _Disp_Asynchronous_Select
6901 -- (<object>, S, P'Address, D, B);
6902 -- Bnn := Communication_Bloc (D);
6904 -- Param1 := P.Param1;
6906 -- ParamN := P.ParamN;
6911 -- <abortable-statements>
6913 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6916 -- when Abort_Signal => Abort_Undefer;
6920 -- <triggering-statements>
6925 -- <dispatching-call>;
6926 -- <triggering-statements>
6931 -- The job is to convert this to the asynchronous form
6933 -- If the trigger is a delay statement, it will have been expanded into
6934 -- a call to one of the GNARL delay procedures. This routine will convert
6935 -- this into a protected entry call on a delay object and then continue
6936 -- processing as for a protected entry call trigger. This requires
6937 -- declaring a Delay_Block object and adding a pointer to this object to
6938 -- the parameter list of the delay procedure to form the parameter list of
6939 -- the entry call. This object is used by the runtime to queue the delay
6942 -- For a description of the use of P and the assignments after the call,
6943 -- see Expand_N_Entry_Call_Statement.
6945 procedure Expand_N_Asynchronous_Select (N : Node_Id) is
6946 Loc : constant Source_Ptr := Sloc (N);
6947 Abrt : constant Node_Id := Abortable_Part (N);
6948 Trig : constant Node_Id := Triggering_Alternative (N);
6950 Abort_Block_Ent : Entity_Id;
6951 Abortable_Block : Node_Id;
6954 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A');
6955 Blk_Typ : Entity_Id;
6957 Call_Ent : Entity_Id;
6958 Cancel_Param : Entity_Id;
6959 Cleanup_Block : Node_Id;
6960 Cleanup_Block_Ent : Entity_Id;
6961 Cleanup_Stmts : List_Id;
6962 Conc_Typ_Stmts : List_Id;
6964 Dblock_Ent : Entity_Id;
6969 Enqueue_Call : Node_Id;
6972 Handler_Stmt : Node_Id;
6974 Lim_Typ_Stmts : List_Id;
6980 ProtE_Stmts : List_Id;
6981 ProtP_Stmts : List_Id;
6984 TaskE_Stmts : List_Id;
6987 B : Entity_Id; -- Call status flag
6988 Bnn : Entity_Id; -- Communication block
6989 C : Entity_Id; -- Call kind
6990 K : Entity_Id; -- Tagged kind
6991 P : Entity_Id; -- Parameter block
6992 S : Entity_Id; -- Primitive operation slot
6993 T : Entity_Id; -- Additional status flag
6995 procedure Rewrite_Abortable_Part;
6996 -- If the trigger is a dispatching call, the expansion inserts multiple
6997 -- copies of the abortable part. This is both inefficient, and may lead
6998 -- to duplicate definitions that the back-end will reject, when the
6999 -- abortable part includes loops. This procedure rewrites the abortable
7000 -- part into a call to a generated procedure.
7002 ----------------------------
7003 -- Rewrite_Abortable_Part --
7004 ----------------------------
7006 procedure Rewrite_Abortable_Part is
7007 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
7012 Make_Subprogram_Body (Loc,
7014 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
7015 Declarations => New_List,
7016 Handled_Statement_Sequence =>
7017 Make_Handled_Sequence_Of_Statements (Loc, Astats));
7018 Insert_Before (N, Decl);
7021 -- Rewrite abortable part into a call to this procedure
7025 Make_Procedure_Call_Statement (Loc,
7026 Name => New_Occurrence_Of (Proc, Loc)));
7027 end Rewrite_Abortable_Part;
7029 -- Start of processing for Expand_N_Asynchronous_Select
7032 -- Asynchronous select is not supported on restricted runtimes. Don't
7035 if Restricted_Profile then
7039 Process_Statements_For_Controlled_Objects (Trig);
7040 Process_Statements_For_Controlled_Objects (Abrt);
7042 Ecall := Triggering_Statement (Trig);
7044 Ensure_Statement_Present (Sloc (Ecall), Trig);
7046 -- Retrieve Astats and Tstats now because the finalization machinery may
7047 -- wrap them in blocks.
7049 Astats := Statements (Abrt);
7050 Tstats := Statements (Trig);
7052 -- The arguments in the call may require dynamic allocation, and the
7053 -- call statement may have been transformed into a block. The block
7054 -- may contain additional declarations for internal entities, and the
7055 -- original call is found by sequential search.
7057 if Nkind (Ecall) = N_Block_Statement then
7058 Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
7059 while not Nkind_In (Ecall, N_Procedure_Call_Statement,
7060 N_Entry_Call_Statement)
7066 -- This is either a dispatching call or a delay statement used as a
7067 -- trigger which was expanded into a procedure call.
7069 if Nkind (Ecall) = N_Procedure_Call_Statement then
7070 if Ada_Version >= Ada_2005
7072 (No (Original_Node (Ecall))
7073 or else not Nkind_In (Original_Node (Ecall),
7074 N_Delay_Relative_Statement,
7075 N_Delay_Until_Statement))
7077 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
7079 Rewrite_Abortable_Part;
7083 -- Call status flag processing, generate:
7084 -- B : Boolean := False;
7086 B := Build_B (Loc, Decls);
7088 -- Communication block processing, generate:
7089 -- Bnn : Communication_Block;
7091 Bnn := Make_Temporary (Loc, 'B');
7093 Make_Object_Declaration (Loc,
7094 Defining_Identifier => Bnn,
7095 Object_Definition =>
7096 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
7098 -- Call kind processing, generate:
7099 -- C : Ada.Tags.Prim_Op_Kind;
7101 C := Build_C (Loc, Decls);
7103 -- Tagged kind processing, generate:
7104 -- K : Ada.Tags.Tagged_Kind :=
7105 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7107 -- Dummy communication block, generate:
7108 -- D : Dummy_Communication_Block;
7111 Make_Object_Declaration (Loc,
7112 Defining_Identifier =>
7113 Make_Defining_Identifier (Loc, Name_uD),
7114 Object_Definition =>
7116 (RTE (RE_Dummy_Communication_Block), Loc)));
7118 K := Build_K (Loc, Decls, Obj);
7120 -- Parameter block processing
7122 Blk_Typ := Build_Parameter_Block
7123 (Loc, Actuals, Formals, Decls);
7124 P := Parameter_Block_Pack
7125 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
7127 -- Dispatch table slot processing, generate:
7130 S := Build_S (Loc, Decls);
7132 -- Additional status flag processing, generate:
7135 T := Make_Temporary (Loc, 'T');
7137 Make_Object_Declaration (Loc,
7138 Defining_Identifier => T,
7139 Object_Definition =>
7140 New_Occurrence_Of (Standard_Boolean, Loc)));
7142 ------------------------------
7143 -- Protected entry handling --
7144 ------------------------------
7147 -- Param1 := P.Param1;
7149 -- ParamN := P.ParamN;
7151 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7154 -- Bnn := Communication_Block (D);
7156 Prepend_To (Cleanup_Stmts,
7157 Make_Assignment_Statement (Loc,
7158 Name => New_Occurrence_Of (Bnn, Loc),
7160 Make_Unchecked_Type_Conversion (Loc,
7162 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7163 Expression => Make_Identifier (Loc, Name_uD))));
7166 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7168 Prepend_To (Cleanup_Stmts,
7169 Make_Procedure_Call_Statement (Loc,
7173 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select),
7175 Parameter_Associations =>
7177 New_Copy_Tree (Obj), -- <object>
7178 New_Occurrence_Of (S, Loc), -- S
7179 Make_Attribute_Reference (Loc, -- P'Address
7180 Prefix => New_Occurrence_Of (P, Loc),
7181 Attribute_Name => Name_Address),
7182 Make_Identifier (Loc, Name_uD), -- D
7183 New_Occurrence_Of (B, Loc)))); -- B
7186 -- if Enqueued (Bnn) then
7187 -- <abortable-statements>
7190 Append_To (Cleanup_Stmts,
7191 Make_Implicit_If_Statement (N,
7193 Make_Function_Call (Loc,
7195 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7196 Parameter_Associations =>
7197 New_List (New_Occurrence_Of (Bnn, Loc))),
7200 New_Copy_List_Tree (Astats)));
7202 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7203 -- will then generate a _clean for the communication block Bnn.
7207 -- procedure _clean is
7209 -- if Enqueued (Bnn) then
7210 -- Cancel_Protected_Entry_Call (Bnn);
7219 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7221 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
7223 -- Wrap the cleanup block in an exception handling block
7229 -- when Abort_Signal => Abort_Undefer;
7232 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7235 Make_Implicit_Label_Declaration (Loc,
7236 Defining_Identifier => Abort_Block_Ent),
7239 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7242 -- if not Cancelled (Bnn) then
7243 -- <triggering-statements>
7246 Append_To (ProtE_Stmts,
7247 Make_Implicit_If_Statement (N,
7251 Make_Function_Call (Loc,
7253 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7254 Parameter_Associations =>
7255 New_List (New_Occurrence_Of (Bnn, Loc)))),
7258 New_Copy_List_Tree (Tstats)));
7260 -------------------------
7261 -- Task entry handling --
7262 -------------------------
7265 -- Param1 := P.Param1;
7267 -- ParamN := P.ParamN;
7269 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7272 -- Bnn := Communication_Block (D);
7274 Append_To (TaskE_Stmts,
7275 Make_Assignment_Statement (Loc,
7277 New_Occurrence_Of (Bnn, Loc),
7279 Make_Unchecked_Type_Conversion (Loc,
7281 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7282 Expression => Make_Identifier (Loc, Name_uD))));
7285 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7287 Prepend_To (TaskE_Stmts,
7288 Make_Procedure_Call_Statement (Loc,
7291 Find_Prim_Op (Etype (Etype (Obj)),
7292 Name_uDisp_Asynchronous_Select),
7295 Parameter_Associations => New_List (
7296 New_Copy_Tree (Obj), -- <object>
7297 New_Occurrence_Of (S, Loc), -- S
7298 Make_Attribute_Reference (Loc, -- P'Address
7299 Prefix => New_Occurrence_Of (P, Loc),
7300 Attribute_Name => Name_Address),
7301 Make_Identifier (Loc, Name_uD), -- D
7302 New_Occurrence_Of (B, Loc)))); -- B
7307 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7311 -- <abortable-statements>
7313 Cleanup_Stmts := New_Copy_List_Tree (Astats);
7316 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7318 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7319 -- will generate a _clean for the additional status flag.
7323 -- procedure _clean is
7325 -- Cancel_Task_Entry_Call (U);
7333 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7335 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
7337 -- Wrap the cleanup block in an exception handling block
7343 -- when Abort_Signal => Abort_Undefer;
7346 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7348 Append_To (TaskE_Stmts,
7349 Make_Implicit_Label_Declaration (Loc,
7350 Defining_Identifier => Abort_Block_Ent));
7352 Append_To (TaskE_Stmts,
7354 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7358 -- <triggering-statements>
7361 Append_To (TaskE_Stmts,
7362 Make_Implicit_If_Statement (N,
7364 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)),
7367 New_Copy_List_Tree (Tstats)));
7369 ----------------------------------
7370 -- Protected procedure handling --
7371 ----------------------------------
7374 -- <dispatching-call>;
7375 -- <triggering-statements>
7377 ProtP_Stmts := New_Copy_List_Tree (Tstats);
7378 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
7381 -- S := Ada.Tags.Get_Offset_Index
7382 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7385 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
7388 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7390 Append_To (Conc_Typ_Stmts,
7391 Make_Procedure_Call_Statement (Loc,
7394 (Find_Prim_Op (Etype (Etype (Obj)),
7395 Name_uDisp_Get_Prim_Op_Kind),
7397 Parameter_Associations =>
7399 New_Copy_Tree (Obj),
7400 New_Occurrence_Of (S, Loc),
7401 New_Occurrence_Of (C, Loc))));
7404 -- if C = POK_Procedure_Entry then
7406 -- elsif C = POK_Task_Entry then
7412 Append_To (Conc_Typ_Stmts,
7413 Make_Implicit_If_Statement (N,
7417 New_Occurrence_Of (C, Loc),
7419 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
7426 Make_Elsif_Part (Loc,
7430 New_Occurrence_Of (C, Loc),
7432 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)),
7441 -- <dispatching-call>;
7442 -- <triggering-statements>
7444 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
7445 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
7448 -- if K = Ada.Tags.TK_Limited_Tagged
7449 -- or else K = Ada.Tags.TK_Tagged
7457 Make_Implicit_If_Statement (N,
7458 Condition => Build_Dispatching_Tag_Check (K, N),
7459 Then_Statements => Lim_Typ_Stmts,
7460 Else_Statements => Conc_Typ_Stmts));
7463 Make_Block_Statement (Loc,
7466 Handled_Statement_Sequence =>
7467 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7472 -- Delay triggering statement processing
7475 -- Add a Delay_Block object to the parameter list of the delay
7476 -- procedure to form the parameter list of the Wait entry call.
7478 Dblock_Ent := Make_Temporary (Loc, 'D');
7480 Pdef := Entity (Name (Ecall));
7482 if Is_RTE (Pdef, RO_CA_Delay_For) then
7484 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc);
7486 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
7488 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc);
7490 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
7491 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc);
7494 Append_To (Parameter_Associations (Ecall),
7495 Make_Attribute_Reference (Loc,
7496 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7497 Attribute_Name => Name_Unchecked_Access));
7499 -- Create the inner block to protect the abortable part
7501 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7503 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7506 Make_Block_Statement (Loc,
7507 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7508 Handled_Statement_Sequence =>
7509 Make_Handled_Sequence_Of_Statements (Loc,
7510 Statements => Astats),
7511 Has_Created_Identifier => True,
7512 Is_Asynchronous_Call_Block => True);
7514 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7517 Make_Implicit_If_Statement (N,
7519 Make_Function_Call (Loc,
7520 Name => Enqueue_Call,
7521 Parameter_Associations => Parameter_Associations (Ecall)),
7523 New_List (Make_Block_Statement (Loc,
7524 Handled_Statement_Sequence =>
7525 Make_Handled_Sequence_Of_Statements (Loc,
7526 Statements => New_List (
7527 Make_Implicit_Label_Declaration (Loc,
7528 Defining_Identifier => Blk_Ent,
7529 Label_Construct => Abortable_Block),
7531 Exception_Handlers => Hdle)))));
7533 Stmts := New_List (Ecall);
7535 -- Construct statement sequence for new block
7538 Make_Implicit_If_Statement (N,
7540 Make_Function_Call (Loc,
7541 Name => New_Occurrence_Of (
7542 RTE (RE_Timed_Out), Loc),
7543 Parameter_Associations => New_List (
7544 Make_Attribute_Reference (Loc,
7545 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7546 Attribute_Name => Name_Unchecked_Access))),
7547 Then_Statements => Tstats));
7549 -- The result is the new block
7551 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
7554 Make_Block_Statement (Loc,
7555 Declarations => New_List (
7556 Make_Object_Declaration (Loc,
7557 Defining_Identifier => Dblock_Ent,
7558 Aliased_Present => True,
7559 Object_Definition =>
7560 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))),
7562 Handled_Statement_Sequence =>
7563 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7573 Extract_Entry (Ecall, Concval, Ename, Index);
7574 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
7576 Stmts := Statements (Handled_Statement_Sequence (Ecall));
7577 Decls := Declarations (Ecall);
7579 if Is_Protected_Type (Etype (Concval)) then
7581 -- Get the declarations of the block expanded from the entry call
7583 Decl := First (Decls);
7584 while Present (Decl)
7585 and then (Nkind (Decl) /= N_Object_Declaration
7586 or else not Is_RTE (Etype (Object_Definition (Decl)),
7587 RE_Communication_Block))
7592 pragma Assert (Present (Decl));
7593 Cancel_Param := Defining_Identifier (Decl);
7595 -- Change the mode of the Protected_Entry_Call call
7597 -- Protected_Entry_Call (
7598 -- Object => po._object'Access,
7599 -- E => <entry index>;
7600 -- Uninterpreted_Data => P'Address;
7601 -- Mode => Asynchronous_Call;
7604 -- Skip assignments to temporaries created for in-out parameters
7606 -- This makes unwarranted assumptions about the shape of the expanded
7607 -- tree for the call, and should be cleaned up ???
7609 Stmt := First (Stmts);
7610 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7616 Param := First (Parameter_Associations (Call));
7617 while Present (Param)
7618 and then not Is_RTE (Etype (Param), RE_Call_Modes)
7623 pragma Assert (Present (Param));
7624 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7627 -- Append an if statement to execute the abortable part
7630 -- if Enqueued (Bnn) then
7633 Make_Implicit_If_Statement (N,
7635 Make_Function_Call (Loc,
7636 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7637 Parameter_Associations => New_List (
7638 New_Occurrence_Of (Cancel_Param, Loc))),
7639 Then_Statements => Astats));
7642 Make_Block_Statement (Loc,
7643 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7644 Handled_Statement_Sequence =>
7645 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts),
7646 Has_Created_Identifier => True,
7647 Is_Asynchronous_Call_Block => True);
7649 -- Aborts are not deferred at beginning of exception handlers in
7652 if ZCX_Exceptions then
7653 Handler_Stmt := Make_Null_Statement (Loc);
7656 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer);
7660 Make_Block_Statement (Loc,
7661 Handled_Statement_Sequence =>
7662 Make_Handled_Sequence_Of_Statements (Loc,
7663 Statements => New_List (
7664 Make_Implicit_Label_Declaration (Loc,
7665 Defining_Identifier => Blk_Ent,
7666 Label_Construct => Abortable_Block),
7671 Exception_Handlers => New_List (
7672 Make_Implicit_Exception_Handler (Loc,
7674 -- when Abort_Signal =>
7675 -- Abort_Undefer.all;
7677 Exception_Choices =>
7678 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
7679 Statements => New_List (Handler_Stmt))))),
7681 -- if not Cancelled (Bnn) then
7682 -- triggered statements
7685 Make_Implicit_If_Statement (N,
7686 Condition => Make_Op_Not (Loc,
7688 Make_Function_Call (Loc,
7689 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7690 Parameter_Associations => New_List (
7691 New_Occurrence_Of (Cancel_Param, Loc)))),
7692 Then_Statements => Tstats));
7694 -- Asynchronous task entry call
7701 B := Make_Defining_Identifier (Loc, Name_uB);
7703 -- Insert declaration of B in declarations of existing block
7706 Make_Object_Declaration (Loc,
7707 Defining_Identifier => B,
7708 Object_Definition =>
7709 New_Occurrence_Of (Standard_Boolean, Loc)));
7711 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
7713 -- Insert the declaration of C in the declarations of the existing
7714 -- block. The variable is initialized to something (True or False,
7715 -- does not matter) to prevent CodePeer from complaining about a
7716 -- possible read of an uninitialized variable.
7719 Make_Object_Declaration (Loc,
7720 Defining_Identifier => Cancel_Param,
7721 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
7722 Expression => New_Occurrence_Of (Standard_False, Loc),
7723 Has_Init_Expression => True));
7725 -- Remove and save the call to Call_Simple
7727 Stmt := First (Stmts);
7729 -- Skip assignments to temporaries created for in-out parameters.
7730 -- This makes unwarranted assumptions about the shape of the expanded
7731 -- tree for the call, and should be cleaned up ???
7733 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7739 -- Create the inner block to protect the abortable part
7741 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7743 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7746 Make_Block_Statement (Loc,
7747 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7748 Handled_Statement_Sequence =>
7749 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats),
7750 Has_Created_Identifier => True,
7751 Is_Asynchronous_Call_Block => True);
7754 Make_Block_Statement (Loc,
7755 Handled_Statement_Sequence =>
7756 Make_Handled_Sequence_Of_Statements (Loc,
7757 Statements => New_List (
7758 Make_Implicit_Label_Declaration (Loc,
7759 Defining_Identifier => Blk_Ent,
7760 Label_Construct => Abortable_Block),
7762 Exception_Handlers => Hdle)));
7764 -- Create new call statement
7766 Params := Parameter_Associations (Call);
7769 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7770 Append_To (Params, New_Occurrence_Of (B, Loc));
7773 Make_Procedure_Call_Statement (Loc,
7774 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
7775 Parameter_Associations => Params));
7777 -- Construct statement sequence for new block
7780 Make_Implicit_If_Statement (N,
7782 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)),
7783 Then_Statements => Tstats));
7785 -- Protected the call against abort
7787 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7790 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
7792 -- The result is the new block
7795 Make_Block_Statement (Loc,
7796 Declarations => Decls,
7797 Handled_Statement_Sequence =>
7798 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7801 end Expand_N_Asynchronous_Select;
7803 -------------------------------------
7804 -- Expand_N_Conditional_Entry_Call --
7805 -------------------------------------
7807 -- The conditional task entry call is converted to a call to
7812 -- P : parms := (parm, parm, parm);
7816 -- (<acceptor-task>, -- Acceptor
7817 -- <entry-index>, -- E
7818 -- P'Address, -- Uninterpreted_Data
7819 -- Conditional_Call, -- Mode
7820 -- B); -- Rendezvous_Successful
7825 -- normal-statements
7831 -- For a description of the use of P and the assignments after the call,
7832 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7833 -- conditional entry call has already been expanded (by the Expand_N_Entry
7834 -- _Call_Statement procedure) as follows:
7837 -- P : parms := (parm, parm, parm);
7839 -- ... info for in-out parameters
7840 -- Call_Simple (acceptor-task, entry-index, P'Address);
7846 -- so the task at hand is to convert the latter expansion into the former
7848 -- The conditional protected entry call is converted to a call to
7849 -- Protected_Entry_Call:
7852 -- P : parms := (parm, parm, parm);
7853 -- Bnn : Communications_Block;
7856 -- Protected_Entry_Call
7857 -- (po._object'Access, -- Object
7858 -- <entry index>, -- E
7859 -- P'Address, -- Uninterpreted_Data
7860 -- Conditional_Call, -- Mode
7865 -- if Cancelled (Bnn) then
7868 -- normal-statements
7872 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7876 -- B : Boolean := False;
7877 -- C : Ada.Tags.Prim_Op_Kind;
7878 -- K : Ada.Tags.Tagged_Kind :=
7879 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7880 -- P : Parameters := (Param1 .. ParamN);
7884 -- if K = Ada.Tags.TK_Limited_Tagged
7885 -- or else K = Ada.Tags.TK_Tagged
7887 -- <dispatching-call>;
7888 -- <triggering-statements>
7892 -- Ada.Tags.Get_Offset_Index
7893 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7895 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7897 -- if C = POK_Protected_Entry
7898 -- or else C = POK_Task_Entry
7900 -- Param1 := P.Param1;
7902 -- ParamN := P.ParamN;
7906 -- if C = POK_Procedure
7907 -- or else C = POK_Protected_Procedure
7908 -- or else C = POK_Task_Procedure
7910 -- <dispatching-call>;
7913 -- <triggering-statements>
7915 -- <else-statements>
7920 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
7921 Loc : constant Source_Ptr := Sloc (N);
7922 Alt : constant Node_Id := Entry_Call_Alternative (N);
7923 Blk : Node_Id := Entry_Call_Statement (Alt);
7926 Blk_Typ : Entity_Id;
7928 Call_Ent : Entity_Id;
7929 Conc_Typ_Stmts : List_Id;
7933 Lim_Typ_Stmts : List_Id;
7940 Transient_Blk : Node_Id;
7943 B : Entity_Id; -- Call status flag
7944 C : Entity_Id; -- Call kind
7945 K : Entity_Id; -- Tagged kind
7946 P : Entity_Id; -- Parameter block
7947 S : Entity_Id; -- Primitive operation slot
7950 Process_Statements_For_Controlled_Objects (N);
7952 if Ada_Version >= Ada_2005
7953 and then Nkind (Blk) = N_Procedure_Call_Statement
7955 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
7960 -- Call status flag processing, generate:
7961 -- B : Boolean := False;
7963 B := Build_B (Loc, Decls);
7965 -- Call kind processing, generate:
7966 -- C : Ada.Tags.Prim_Op_Kind;
7968 C := Build_C (Loc, Decls);
7970 -- Tagged kind processing, generate:
7971 -- K : Ada.Tags.Tagged_Kind :=
7972 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7974 K := Build_K (Loc, Decls, Obj);
7976 -- Parameter block processing
7978 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
7979 P := Parameter_Block_Pack
7980 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
7982 -- Dispatch table slot processing, generate:
7985 S := Build_S (Loc, Decls);
7988 -- S := Ada.Tags.Get_Offset_Index
7989 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7992 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
7995 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7997 Append_To (Conc_Typ_Stmts,
7998 Make_Procedure_Call_Statement (Loc,
8001 Find_Prim_Op (Etype (Etype (Obj)),
8002 Name_uDisp_Conditional_Select),
8004 Parameter_Associations =>
8006 New_Copy_Tree (Obj), -- <object>
8007 New_Occurrence_Of (S, Loc), -- S
8008 Make_Attribute_Reference (Loc, -- P'Address
8009 Prefix => New_Occurrence_Of (P, Loc),
8010 Attribute_Name => Name_Address),
8011 New_Occurrence_Of (C, Loc), -- C
8012 New_Occurrence_Of (B, Loc)))); -- B
8015 -- if C = POK_Protected_Entry
8016 -- or else C = POK_Task_Entry
8018 -- Param1 := P.Param1;
8020 -- ParamN := P.ParamN;
8023 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
8025 -- Generate the if statement only when the packed parameters need
8026 -- explicit assignments to their corresponding actuals.
8028 if Present (Unpack) then
8029 Append_To (Conc_Typ_Stmts,
8030 Make_Implicit_If_Statement (N,
8036 New_Occurrence_Of (C, Loc),
8038 New_Occurrence_Of (RTE (
8039 RE_POK_Protected_Entry), Loc)),
8044 New_Occurrence_Of (C, Loc),
8046 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
8048 Then_Statements => Unpack));
8053 -- if C = POK_Procedure
8054 -- or else C = POK_Protected_Procedure
8055 -- or else C = POK_Task_Procedure
8057 -- <dispatching-call>
8059 -- <normal-statements>
8061 -- <else-statements>
8064 N_Stats := New_Copy_List_Tree (Statements (Alt));
8066 Prepend_To (N_Stats,
8067 Make_Implicit_If_Statement (N,
8073 New_Occurrence_Of (C, Loc),
8075 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
8082 New_Occurrence_Of (C, Loc),
8084 New_Occurrence_Of (RTE (
8085 RE_POK_Protected_Procedure), Loc)),
8090 New_Occurrence_Of (C, Loc),
8092 New_Occurrence_Of (RTE (
8093 RE_POK_Task_Procedure), Loc)))),
8098 Append_To (Conc_Typ_Stmts,
8099 Make_Implicit_If_Statement (N,
8100 Condition => New_Occurrence_Of (B, Loc),
8101 Then_Statements => N_Stats,
8102 Else_Statements => Else_Statements (N)));
8105 -- <dispatching-call>;
8106 -- <triggering-statements>
8108 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
8109 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
8112 -- if K = Ada.Tags.TK_Limited_Tagged
8113 -- or else K = Ada.Tags.TK_Tagged
8121 Make_Implicit_If_Statement (N,
8122 Condition => Build_Dispatching_Tag_Check (K, N),
8123 Then_Statements => Lim_Typ_Stmts,
8124 Else_Statements => Conc_Typ_Stmts));
8127 Make_Block_Statement (Loc,
8130 Handled_Statement_Sequence =>
8131 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8133 -- As described above, the entry alternative is transformed into a
8134 -- block that contains the gnulli call, and possibly assignment
8135 -- statements for in-out parameters. The gnulli call may itself be
8136 -- rewritten into a transient block if some unconstrained parameters
8137 -- require it. We need to retrieve the call to complete its parameter
8142 First_Real_Statement (Handled_Statement_Sequence (Blk));
8144 if Present (Transient_Blk)
8145 and then Nkind (Transient_Blk) = N_Block_Statement
8147 Blk := Transient_Blk;
8150 Stmts := Statements (Handled_Statement_Sequence (Blk));
8151 Stmt := First (Stmts);
8152 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
8157 Params := Parameter_Associations (Call);
8159 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
8161 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8163 Param := First (Params);
8164 while Present (Param)
8165 and then not Is_RTE (Etype (Param), RE_Call_Modes)
8170 pragma Assert (Present (Param));
8172 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8176 -- Find the Communication_Block parameter for the call to the
8177 -- Cancelled function.
8179 Decl := First (Declarations (Blk));
8180 while Present (Decl)
8181 and then not Is_RTE (Etype (Object_Definition (Decl)),
8182 RE_Communication_Block)
8187 -- Add an if statement to execute the else part if the call
8188 -- does not succeed (as indicated by the Cancelled predicate).
8191 Make_Implicit_If_Statement (N,
8192 Condition => Make_Function_Call (Loc,
8193 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
8194 Parameter_Associations => New_List (
8195 New_Occurrence_Of (Defining_Identifier (Decl), Loc))),
8196 Then_Statements => Else_Statements (N),
8197 Else_Statements => Statements (Alt)));
8200 B := Make_Defining_Identifier (Loc, Name_uB);
8202 -- Insert declaration of B in declarations of existing block
8204 if No (Declarations (Blk)) then
8205 Set_Declarations (Blk, New_List);
8208 Prepend_To (Declarations (Blk),
8209 Make_Object_Declaration (Loc,
8210 Defining_Identifier => B,
8211 Object_Definition =>
8212 New_Occurrence_Of (Standard_Boolean, Loc)));
8214 -- Create new call statement
8217 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8218 Append_To (Params, New_Occurrence_Of (B, Loc));
8221 Make_Procedure_Call_Statement (Loc,
8222 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
8223 Parameter_Associations => Params));
8225 -- Construct statement sequence for new block
8228 Make_Implicit_If_Statement (N,
8229 Condition => New_Occurrence_Of (B, Loc),
8230 Then_Statements => Statements (Alt),
8231 Else_Statements => Else_Statements (N)));
8234 -- The result is the new block
8237 Make_Block_Statement (Loc,
8238 Declarations => Declarations (Blk),
8239 Handled_Statement_Sequence =>
8240 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8245 Reset_Scopes_To (N, Entity (Identifier (N)));
8246 end Expand_N_Conditional_Entry_Call;
8248 ---------------------------------------
8249 -- Expand_N_Delay_Relative_Statement --
8250 ---------------------------------------
8252 -- Delay statement is implemented as a procedure call to Delay_For
8253 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8254 -- simple delays imposed by the use of Protected Objects.
8256 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
8257 Loc : constant Source_Ptr := Sloc (N);
8261 -- Try to use Ada.Calendar.Delays.Delay_For if available.
8263 if RTE_Available (RO_CA_Delay_For) then
8264 Proc := RTE (RO_CA_Delay_For);
8266 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error
8267 -- message if not available. This is the implementation used on
8268 -- restricted platforms when Ada.Calendar is not available.
8271 Proc := RTE (RO_RD_Delay_For);
8275 Make_Procedure_Call_Statement (Loc,
8276 Name => New_Occurrence_Of (Proc, Loc),
8277 Parameter_Associations => New_List (Expression (N))));
8279 end Expand_N_Delay_Relative_Statement;
8281 ------------------------------------
8282 -- Expand_N_Delay_Until_Statement --
8283 ------------------------------------
8285 -- Delay Until statement is implemented as a procedure call to
8286 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8288 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
8289 Loc : constant Source_Ptr := Sloc (N);
8293 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
8294 Typ := RTE (RO_CA_Delay_Until);
8296 Typ := RTE (RO_RT_Delay_Until);
8300 Make_Procedure_Call_Statement (Loc,
8301 Name => New_Occurrence_Of (Typ, Loc),
8302 Parameter_Associations => New_List (Expression (N))));
8305 end Expand_N_Delay_Until_Statement;
8307 -------------------------
8308 -- Expand_N_Entry_Body --
8309 -------------------------
8311 procedure Expand_N_Entry_Body (N : Node_Id) is
8313 -- Associate discriminals with the next protected operation body to be
8316 if Present (Next_Protected_Operation (N)) then
8317 Set_Discriminals (Parent (Current_Scope));
8319 end Expand_N_Entry_Body;
8321 -----------------------------------
8322 -- Expand_N_Entry_Call_Statement --
8323 -----------------------------------
8325 -- An entry call is expanded into GNARLI calls to implement a simple entry
8326 -- call (see Build_Simple_Entry_Call).
8328 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
8334 if No_Run_Time_Mode then
8335 Error_Msg_CRT ("entry call", N);
8339 -- If this entry call is part of an asynchronous select, don't expand it
8340 -- here; it will be expanded with the select statement. Don't expand
8341 -- timed entry calls either, as they are translated into asynchronous
8344 -- ??? This whole approach is questionable; it may be better to go back
8345 -- to allowing the expansion to take place and then attempting to fix it
8346 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8347 -- whether the expanded call is on a task or protected entry.
8349 if (Nkind (Parent (N)) /= N_Triggering_Alternative
8350 or else N /= Triggering_Statement (Parent (N)))
8351 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
8352 or else N /= Entry_Call_Statement (Parent (N))
8353 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
8355 Extract_Entry (N, Concval, Ename, Index);
8356 Build_Simple_Entry_Call (N, Concval, Ename, Index);
8358 end Expand_N_Entry_Call_Statement;
8360 --------------------------------
8361 -- Expand_N_Entry_Declaration --
8362 --------------------------------
8364 -- If there are parameters, then first, each of the formals is marked by
8365 -- setting Is_Entry_Formal. Next a record type is built which is used to
8366 -- hold the parameter values. The name of this record type is entryP where
8367 -- entry is the name of the entry, with an additional corresponding access
8368 -- type called entryPA. The record type has matching components for each
8369 -- formal (the component names are the same as the formal names). For
8370 -- elementary types, the component type matches the formal type. For
8371 -- composite types, an access type is declared (with the name formalA)
8372 -- which designates the formal type, and the type of the component is this
8373 -- access type. Finally the Entry_Component of each formal is set to
8374 -- reference the corresponding record component.
8376 procedure Expand_N_Entry_Declaration (N : Node_Id) is
8377 Loc : constant Source_Ptr := Sloc (N);
8378 Entry_Ent : constant Entity_Id := Defining_Identifier (N);
8379 Components : List_Id;
8382 Last_Decl : Node_Id;
8383 Component : Entity_Id;
8386 Rec_Ent : Entity_Id;
8387 Acc_Ent : Entity_Id;
8390 Formal := First_Formal (Entry_Ent);
8393 -- Most processing is done only if parameters are present
8395 if Present (Formal) then
8396 Components := New_List;
8398 -- Loop through formals
8400 while Present (Formal) loop
8401 Set_Is_Entry_Formal (Formal);
8403 Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
8404 Set_Entry_Component (Formal, Component);
8405 Set_Entry_Formal (Component, Formal);
8406 Ftype := Etype (Formal);
8408 -- Declare new access type and then append
8410 Ctype := Make_Temporary (Loc, 'A');
8411 Set_Is_Param_Block_Component_Type (Ctype);
8414 Make_Full_Type_Declaration (Loc,
8415 Defining_Identifier => Ctype,
8417 Make_Access_To_Object_Definition (Loc,
8418 All_Present => True,
8419 Constant_Present => Ekind (Formal) = E_In_Parameter,
8420 Subtype_Indication => New_Occurrence_Of (Ftype, Loc)));
8422 Insert_After (Last_Decl, Decl);
8425 Append_To (Components,
8426 Make_Component_Declaration (Loc,
8427 Defining_Identifier => Component,
8428 Component_Definition =>
8429 Make_Component_Definition (Loc,
8430 Aliased_Present => False,
8431 Subtype_Indication => New_Occurrence_Of (Ctype, Loc))));
8433 Next_Formal_With_Extras (Formal);
8436 -- Create the Entry_Parameter_Record declaration
8438 Rec_Ent := Make_Temporary (Loc, 'P');
8441 Make_Full_Type_Declaration (Loc,
8442 Defining_Identifier => Rec_Ent,
8444 Make_Record_Definition (Loc,
8446 Make_Component_List (Loc,
8447 Component_Items => Components)));
8449 Insert_After (Last_Decl, Decl);
8452 -- Construct and link in the corresponding access type
8454 Acc_Ent := Make_Temporary (Loc, 'A');
8456 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
8459 Make_Full_Type_Declaration (Loc,
8460 Defining_Identifier => Acc_Ent,
8462 Make_Access_To_Object_Definition (Loc,
8463 All_Present => True,
8464 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc)));
8466 Insert_After (Last_Decl, Decl);
8468 end Expand_N_Entry_Declaration;
8470 -----------------------------
8471 -- Expand_N_Protected_Body --
8472 -----------------------------
8474 -- Protected bodies are expanded to the completion of the subprograms
8475 -- created for the corresponding protected type. These are a protected and
8476 -- unprotected version of each protected subprogram in the object, a
8477 -- function to calculate each entry barrier, and a procedure to execute the
8478 -- sequence of statements of each protected entry body. For example, for
8479 -- protected type ptype:
8482 -- (O : System.Address;
8483 -- E : Protected_Entry_Index)
8486 -- <discriminant renamings>
8487 -- <private object renamings>
8489 -- return <barrier expression>;
8492 -- procedure pprocN (_object : in out poV;...) is
8493 -- <discriminant renamings>
8494 -- <private object renamings>
8496 -- <sequence of statements>
8499 -- procedure pprocP (_object : in out poV;...) is
8500 -- procedure _clean is
8503 -- ptypeS (_object, Pn);
8504 -- Unlock (_object._object'Access);
8505 -- Abort_Undefer.all;
8510 -- Lock (_object._object'Access);
8511 -- pprocN (_object;...);
8516 -- function pfuncN (_object : poV;...) return Return_Type is
8517 -- <discriminant renamings>
8518 -- <private object renamings>
8520 -- <sequence of statements>
8523 -- function pfuncP (_object : poV) return Return_Type is
8524 -- procedure _clean is
8526 -- Unlock (_object._object'Access);
8527 -- Abort_Undefer.all;
8532 -- Lock (_object._object'Access);
8533 -- return pfuncN (_object);
8540 -- (O : System.Address;
8541 -- P : System.Address;
8542 -- E : Protected_Entry_Index)
8544 -- <discriminant renamings>
8545 -- <private object renamings>
8546 -- type poVP is access poV;
8547 -- _Object : ptVP := ptVP!(O);
8551 -- <statement sequence>
8552 -- Complete_Entry_Body (_Object._Object);
8554 -- when all others =>
8555 -- Exceptional_Complete_Entry_Body (
8556 -- _Object._Object, Get_GNAT_Exception);
8560 -- The type poV is the record created for the protected type to hold
8561 -- the state of the protected object.
8563 procedure Expand_N_Protected_Body (N : Node_Id) is
8564 Loc : constant Source_Ptr := Sloc (N);
8565 Pid : constant Entity_Id := Corresponding_Spec (N);
8567 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid);
8568 -- This flag indicates whether the lock free implementation is active
8570 Current_Node : Node_Id;
8571 Disp_Op_Body : Node_Id;
8572 New_Op_Body : Node_Id;
8576 function Build_Dispatching_Subprogram_Body
8579 Prot_Bod : Node_Id) return Node_Id;
8580 -- Build a dispatching version of the protected subprogram body. The
8581 -- newly generated subprogram contains a call to the original protected
8582 -- body. The following code is generated:
8584 -- function <protected-function-name> (Param1 .. ParamN) return
8587 -- return <protected-function-name>P (Param1 .. ParamN);
8588 -- end <protected-function-name>;
8592 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8594 -- <protected-procedure-name>P (Param1 .. ParamN);
8595 -- end <protected-procedure-name>
8597 ---------------------------------------
8598 -- Build_Dispatching_Subprogram_Body --
8599 ---------------------------------------
8601 function Build_Dispatching_Subprogram_Body
8604 Prot_Bod : Node_Id) return Node_Id
8606 Loc : constant Source_Ptr := Sloc (N);
8613 -- Generate a specification without a letter suffix in order to
8614 -- override an interface function or procedure.
8616 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
8618 -- The formal parameters become the actuals of the protected function
8619 -- or procedure call.
8621 Actuals := New_List;
8622 Formal := First (Parameter_Specifications (Spec));
8623 while Present (Formal) loop
8625 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
8629 if Nkind (Spec) = N_Procedure_Specification then
8632 Make_Procedure_Call_Statement (Loc,
8634 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8635 Parameter_Associations => Actuals));
8638 pragma Assert (Nkind (Spec) = N_Function_Specification);
8642 Make_Simple_Return_Statement (Loc,
8644 Make_Function_Call (Loc,
8646 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8647 Parameter_Associations => Actuals)));
8651 Make_Subprogram_Body (Loc,
8652 Declarations => Empty_List,
8653 Specification => Spec,
8654 Handled_Statement_Sequence =>
8655 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8656 end Build_Dispatching_Subprogram_Body;
8658 -- Start of processing for Expand_N_Protected_Body
8661 if No_Run_Time_Mode then
8662 Error_Msg_CRT ("protected body", N);
8666 -- This is the proper body corresponding to a stub. The declarations
8667 -- must be inserted at the point of the stub, which in turn is in the
8668 -- declarative part of the parent unit.
8670 if Nkind (Parent (N)) = N_Subunit then
8671 Current_Node := Corresponding_Stub (Parent (N));
8676 Op_Body := First (Declarations (N));
8678 -- The protected body is replaced with the bodies of its protected
8679 -- operations, and the declarations for internal objects that may
8680 -- have been created for entry family bounds.
8682 Rewrite (N, Make_Null_Statement (Sloc (N)));
8685 while Present (Op_Body) loop
8686 case Nkind (Op_Body) is
8687 when N_Subprogram_Declaration =>
8690 when N_Subprogram_Body =>
8692 -- Do not create bodies for eliminated operations
8694 if not Is_Eliminated (Defining_Entity (Op_Body))
8695 and then not Is_Eliminated (Corresponding_Spec (Op_Body))
8697 if Lock_Free_Active then
8699 Build_Lock_Free_Unprotected_Subprogram_Body
8703 Build_Unprotected_Subprogram_Body (Op_Body, Pid);
8706 Insert_After (Current_Node, New_Op_Body);
8707 Current_Node := New_Op_Body;
8708 Analyze (New_Op_Body);
8710 -- Build the corresponding protected operation. It may
8711 -- appear that this is needed only if this is a visible
8712 -- operation of the type, or if it is an interrupt handler,
8713 -- and this was the strategy used previously in GNAT.
8715 -- However, the operation may be exported through a 'Access
8716 -- to an external caller. This is the common idiom in code
8717 -- that uses the Ada 2005 Timing_Events package. As a result
8718 -- we need to produce the protected body for both visible
8719 -- and private operations, as well as operations that only
8720 -- have a body in the source, and for which we create a
8721 -- declaration in the protected body itself.
8723 if Present (Corresponding_Spec (Op_Body)) then
8724 if Lock_Free_Active then
8726 Build_Lock_Free_Protected_Subprogram_Body
8727 (Op_Body, Pid, Specification (New_Op_Body));
8730 Build_Protected_Subprogram_Body
8731 (Op_Body, Pid, Specification (New_Op_Body));
8734 Insert_After (Current_Node, New_Op_Body);
8735 Analyze (New_Op_Body);
8737 Current_Node := New_Op_Body;
8739 -- Generate an overriding primitive operation body for
8740 -- this subprogram if the protected type implements an
8743 if Ada_Version >= Ada_2005
8745 Present (Interfaces (Corresponding_Record_Type (Pid)))
8748 Build_Dispatching_Subprogram_Body
8749 (Op_Body, Pid, New_Op_Body);
8751 Insert_After (Current_Node, Disp_Op_Body);
8752 Analyze (Disp_Op_Body);
8754 Current_Node := Disp_Op_Body;
8759 when N_Entry_Body =>
8760 Op_Id := Defining_Identifier (Op_Body);
8761 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
8763 Insert_After (Current_Node, New_Op_Body);
8764 Current_Node := New_Op_Body;
8765 Analyze (New_Op_Body);
8767 when N_Implicit_Label_Declaration =>
8773 New_Op_Body := New_Copy (Op_Body);
8774 Insert_After (Current_Node, New_Op_Body);
8775 Current_Node := New_Op_Body;
8777 when N_Freeze_Entity =>
8778 New_Op_Body := New_Copy (Op_Body);
8780 if Present (Entity (Op_Body))
8781 and then Freeze_Node (Entity (Op_Body)) = Op_Body
8783 Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
8786 Insert_After (Current_Node, New_Op_Body);
8787 Current_Node := New_Op_Body;
8788 Analyze (New_Op_Body);
8791 New_Op_Body := New_Copy (Op_Body);
8792 Insert_After (Current_Node, New_Op_Body);
8793 Current_Node := New_Op_Body;
8794 Analyze (New_Op_Body);
8796 when N_Object_Declaration =>
8797 pragma Assert (not Comes_From_Source (Op_Body));
8798 New_Op_Body := New_Copy (Op_Body);
8799 Insert_After (Current_Node, New_Op_Body);
8800 Current_Node := New_Op_Body;
8801 Analyze (New_Op_Body);
8804 raise Program_Error;
8810 -- Finally, create the body of the function that maps an entry index
8811 -- into the corresponding body index, except when there is no entry, or
8812 -- in a Ravenscar-like profile.
8814 if Corresponding_Runtime_Package (Pid) =
8815 System_Tasking_Protected_Objects_Entries
8817 New_Op_Body := Build_Find_Body_Index (Pid);
8818 Insert_After (Current_Node, New_Op_Body);
8819 Current_Node := New_Op_Body;
8820 Analyze (New_Op_Body);
8823 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8824 -- protected body. At this point all wrapper specs have been created,
8825 -- frozen and included in the dispatch table for the protected type.
8827 if Ada_Version >= Ada_2005 then
8828 Build_Wrapper_Bodies (Loc, Pid, Current_Node);
8830 end Expand_N_Protected_Body;
8832 -----------------------------------------
8833 -- Expand_N_Protected_Type_Declaration --
8834 -----------------------------------------
8836 -- First we create a corresponding record type declaration used to
8837 -- represent values of this protected type.
8838 -- The general form of this type declaration is
8840 -- type poV (discriminants) is record
8841 -- _Object : aliased <kind>Protection
8842 -- [(<entry count> [, <handler count>])];
8843 -- [entry_family : array (bounds) of Void;]
8844 -- <private data fields>
8847 -- The discriminants are present only if the corresponding protected type
8848 -- has discriminants, and they exactly mirror the protected type
8849 -- discriminants. The private data fields similarly mirror the private
8850 -- declarations of the protected type.
8852 -- The Object field is always present. It contains RTS specific data used
8853 -- to control the protected object. It is declared as Aliased so that it
8854 -- can be passed as a pointer to the RTS. This allows the protected record
8855 -- to be referenced within RTS data structures. An appropriate Protection
8856 -- type and discriminant are generated.
8858 -- The Service field is present for protected objects with entries. It
8859 -- contains sufficient information to allow the entry service procedure for
8860 -- this object to be called when the object is not known till runtime.
8862 -- One entry_family component is present for each entry family in the
8863 -- task definition (see Expand_N_Task_Type_Declaration).
8865 -- When a protected object is declared, an instance of the protected type
8866 -- value record is created. The elaboration of this declaration creates the
8867 -- correct bounds for the entry families, and also evaluates the priority
8868 -- expression if needed. The initialization routine for the protected type
8869 -- itself then calls Initialize_Protection with appropriate parameters to
8870 -- initialize the value of the Task_Id field. Install_Handlers may be also
8871 -- called if a pragma Attach_Handler applies.
8873 -- Note: this record is passed to the subprograms created by the expansion
8874 -- of protected subprograms and entries. It is an in parameter to protected
8875 -- functions and an in out parameter to procedures and entry bodies. The
8876 -- Entity_Id for this created record type is placed in the
8877 -- Corresponding_Record_Type field of the associated protected type entity.
8879 -- Next we create a procedure specifications for protected subprograms and
8880 -- entry bodies. For each protected subprograms two subprograms are
8881 -- created, an unprotected and a protected version. The unprotected version
8882 -- is called from within other operations of the same protected object.
8884 -- We also build the call to register the procedure if a pragma
8885 -- Interrupt_Handler applies.
8887 -- A single subprogram is created to service all entry bodies; it has an
8888 -- additional boolean out parameter indicating that the previous entry call
8889 -- made by the current task was serviced immediately, i.e. not by proxy.
8890 -- The O parameter contains a pointer to a record object of the type
8891 -- described above. An untyped interface is used here to allow this
8892 -- procedure to be called in places where the type of the object to be
8893 -- serviced is not known. This must be done, for example, when a call that
8894 -- may have been requeued is cancelled; the corresponding object must be
8895 -- serviced, but which object that is not known till runtime.
8898 -- (O : System.Address; P : out Boolean);
8899 -- procedure pprocN (_object : in out poV);
8900 -- procedure pproc (_object : in out poV);
8901 -- function pfuncN (_object : poV);
8902 -- function pfunc (_object : poV);
8905 -- Note that this must come after the record type declaration, since
8906 -- the specs refer to this type.
8908 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
8909 Discr_Map : constant Elist_Id := New_Elmt_List;
8910 Loc : constant Source_Ptr := Sloc (N);
8911 Prot_Typ : constant Entity_Id := Defining_Identifier (N);
8913 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ);
8914 -- This flag indicates whether the lock free implementation is active
8916 Pdef : constant Node_Id := Protected_Definition (N);
8917 -- This contains two lists; one for visible and one for private decls
8919 Current_Node : Node_Id := N;
8921 Entries_Aggr : Node_Id;
8923 procedure Check_Inlining (Subp : Entity_Id);
8924 -- If the original operation has a pragma Inline, propagate the flag
8925 -- to the internal body, for possible inlining later on. The source
8926 -- operation is invisible to the back-end and is never actually called.
8928 procedure Expand_Entry_Declaration (Decl : Node_Id);
8929 -- Create the entry barrier and the procedure body for entry declaration
8930 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
8932 function Static_Component_Size (Comp : Entity_Id) return Boolean;
8933 -- When compiling under the Ravenscar profile, private components must
8934 -- have a static size, or else a protected object will require heap
8935 -- allocation, violating the corresponding restriction. It is preferable
8936 -- to make this check here, because it provides a better error message
8937 -- than the back-end, which refers to the object as a whole.
8939 procedure Register_Handler;
8940 -- For a protected operation that is an interrupt handler, add the
8941 -- freeze action that will register it as such.
8943 --------------------
8944 -- Check_Inlining --
8945 --------------------
8947 procedure Check_Inlining (Subp : Entity_Id) is
8949 if Is_Inlined (Subp) then
8950 Set_Is_Inlined (Protected_Body_Subprogram (Subp));
8951 Set_Is_Inlined (Subp, False);
8954 if Has_Pragma_No_Inline (Subp) then
8955 Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp));
8959 ---------------------------
8960 -- Static_Component_Size --
8961 ---------------------------
8963 function Static_Component_Size (Comp : Entity_Id) return Boolean is
8964 Typ : constant Entity_Id := Etype (Comp);
8968 if Is_Scalar_Type (Typ) then
8971 elsif Is_Array_Type (Typ) then
8972 return Compile_Time_Known_Bounds (Typ);
8974 elsif Is_Record_Type (Typ) then
8975 C := First_Component (Typ);
8976 while Present (C) loop
8977 if not Static_Component_Size (C) then
8986 -- Any other type will be checked by the back-end
8991 end Static_Component_Size;
8993 ------------------------------
8994 -- Expand_Entry_Declaration --
8995 ------------------------------
8997 procedure Expand_Entry_Declaration (Decl : Node_Id) is
8998 Ent_Id : constant Entity_Id := Defining_Entity (Decl);
9004 E_Count := E_Count + 1;
9006 -- Create the protected body subprogram
9009 Make_Defining_Identifier (Loc,
9010 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E'));
9011 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id);
9014 Make_Subprogram_Declaration (Loc,
9016 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id));
9018 Insert_After (Current_Node, Subp);
9019 Current_Node := Subp;
9023 -- Build a wrapper procedure to handle contract cases, preconditions,
9024 -- and postconditions.
9026 Build_Contract_Wrapper (Ent_Id, N);
9028 -- Create the barrier function
9031 Make_Defining_Identifier (Loc,
9032 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B'));
9033 Set_Barrier_Function (Ent_Id, Bar_Id);
9036 Make_Subprogram_Declaration (Loc,
9038 Build_Barrier_Function_Specification (Loc, Bar_Id));
9039 Set_Is_Entry_Barrier_Function (Subp);
9041 Insert_After (Current_Node, Subp);
9042 Current_Node := Subp;
9046 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id);
9047 Set_Scope (Bar_Id, Scope (Ent_Id));
9049 -- Collect pointers to the protected subprogram and the barrier
9050 -- of the current entry, for insertion into Entry_Bodies_Array.
9052 Append_To (Expressions (Entries_Aggr),
9053 Make_Aggregate (Loc,
9054 Expressions => New_List (
9055 Make_Attribute_Reference (Loc,
9056 Prefix => New_Occurrence_Of (Bar_Id, Loc),
9057 Attribute_Name => Name_Unrestricted_Access),
9058 Make_Attribute_Reference (Loc,
9059 Prefix => New_Occurrence_Of (Bod_Id, Loc),
9060 Attribute_Name => Name_Unrestricted_Access))));
9061 end Expand_Entry_Declaration;
9063 ----------------------
9064 -- Register_Handler --
9065 ----------------------
9067 procedure Register_Handler is
9069 -- All semantic checks already done in Sem_Prag
9071 Prot_Proc : constant Entity_Id :=
9072 Defining_Unit_Name (Specification (Current_Node));
9074 Proc_Address : constant Node_Id :=
9075 Make_Attribute_Reference (Loc,
9077 New_Occurrence_Of (Prot_Proc, Loc),
9078 Attribute_Name => Name_Address);
9080 RTS_Call : constant Entity_Id :=
9081 Make_Procedure_Call_Statement (Loc,
9084 (RTE (RE_Register_Interrupt_Handler), Loc),
9085 Parameter_Associations => New_List (Proc_Address));
9087 Append_Freeze_Action (Prot_Proc, RTS_Call);
9088 end Register_Handler;
9093 Body_Id : Entity_Id;
9099 Object_Comp : Node_Id;
9104 -- Start of processing for Expand_N_Protected_Type_Declaration
9107 if Present (Corresponding_Record_Type (Prot_Typ)) then
9110 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
9113 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
9115 Qualify_Entity_Names (N);
9117 -- If the type has discriminants, their occurrences in the declaration
9118 -- have been replaced by the corresponding discriminals. For components
9119 -- that are constrained by discriminants, their homologues in the
9120 -- corresponding record type must refer to the discriminants of that
9121 -- record, so we must apply a new renaming to subtypes_indications:
9123 -- protected discriminant => discriminal => record discriminant
9125 -- This replacement is not applied to default expressions, for which
9126 -- the discriminal is correct.
9128 if Has_Discriminants (Prot_Typ) then
9134 Disc := First_Discriminant (Prot_Typ);
9135 Decl := First (Discriminant_Specifications (Rec_Decl));
9136 while Present (Disc) loop
9137 Append_Elmt (Discriminal (Disc), Discr_Map);
9138 Append_Elmt (Defining_Identifier (Decl), Discr_Map);
9139 Next_Discriminant (Disc);
9145 -- Fill in the component declarations
9147 -- Add components for entry families. For each entry family, create an
9148 -- anonymous type declaration with the same size, and analyze the type.
9150 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
9152 pragma Assert (Present (Pdef));
9154 Insert_After (Current_Node, Rec_Decl);
9155 Current_Node := Rec_Decl;
9157 -- Add private field components
9159 if Present (Private_Declarations (Pdef)) then
9160 Priv := First (Private_Declarations (Pdef));
9161 while Present (Priv) loop
9162 if Nkind (Priv) = N_Component_Declaration then
9163 if not Static_Component_Size (Defining_Identifier (Priv)) then
9165 -- When compiling for a restricted profile, the private
9166 -- components must have a static size. If not, this is an
9167 -- error for a single protected declaration, and rates a
9168 -- warning on a protected type declaration.
9170 if not Comes_From_Source (Prot_Typ) then
9172 -- It's ok to be checking this restriction at expansion
9173 -- time, because this is only for the restricted profile,
9174 -- which is not subject to strict RM conformance, so it
9175 -- is OK to miss this check in -gnatc mode.
9177 Check_Restriction (No_Implicit_Heap_Allocations, Priv);
9179 (No_Implicit_Protected_Object_Allocations, Priv);
9181 elsif Restriction_Active (No_Implicit_Heap_Allocations) then
9182 if not Discriminated_Size (Defining_Identifier (Priv))
9184 -- Any object of the type will be non-static
9186 Error_Msg_N ("component has non-static size??", Priv);
9188 ("\creation of protected object of type& will "
9189 & "violate restriction "
9190 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
9192 -- Object will be non-static if discriminants are
9195 ("creation of protected object of type& with "
9196 & "non-static discriminants will violate "
9197 & "restriction No_Implicit_Heap_Allocations??",
9201 -- Likewise for No_Implicit_Protected_Object_Allocations
9203 elsif Restriction_Active
9204 (No_Implicit_Protected_Object_Allocations)
9206 if not Discriminated_Size (Defining_Identifier (Priv))
9208 -- Any object of the type will be non-static
9210 Error_Msg_N ("component has non-static size??", Priv);
9212 ("\creation of protected object of type& will "
9213 & "violate restriction "
9214 & "No_Implicit_Protected_Object_Allocations??",
9217 -- Object will be non-static if discriminants are
9220 ("creation of protected object of type& with "
9221 & "non-static discriminants will violate "
9223 & "No_Implicit_Protected_Object_Allocations??",
9229 -- The component definition consists of a subtype indication,
9230 -- or (in Ada 2005) an access definition. Make a copy of the
9231 -- proper definition.
9234 Old_Comp : constant Node_Id := Component_Definition (Priv);
9235 Oent : constant Entity_Id := Defining_Identifier (Priv);
9236 Nent : constant Entity_Id :=
9237 Make_Defining_Identifier (Sloc (Oent),
9238 Chars => Chars (Oent));
9242 if Present (Subtype_Indication (Old_Comp)) then
9244 Make_Component_Definition (Sloc (Oent),
9245 Aliased_Present => False,
9246 Subtype_Indication =>
9248 (Subtype_Indication (Old_Comp), Discr_Map));
9251 Make_Component_Definition (Sloc (Oent),
9252 Aliased_Present => False,
9253 Access_Definition =>
9255 (Access_Definition (Old_Comp), Discr_Map));
9259 Make_Component_Declaration (Loc,
9260 Defining_Identifier => Nent,
9261 Component_Definition => New_Comp,
9262 Expression => Expression (Priv));
9264 Set_Has_Per_Object_Constraint (Nent,
9265 Has_Per_Object_Constraint (Oent));
9267 Append_To (Cdecls, New_Priv);
9270 elsif Nkind (Priv) = N_Subprogram_Declaration then
9272 -- Make the unprotected version of the subprogram available
9273 -- for expansion of intra object calls. There is need for
9274 -- a protected version only if the subprogram is an interrupt
9275 -- handler, otherwise this operation can only be called from
9279 Make_Subprogram_Declaration (Loc,
9281 Build_Protected_Sub_Specification
9282 (Priv, Prot_Typ, Unprotected_Mode));
9284 Insert_After (Current_Node, Sub);
9287 Set_Protected_Body_Subprogram
9288 (Defining_Unit_Name (Specification (Priv)),
9289 Defining_Unit_Name (Specification (Sub)));
9290 Check_Inlining (Defining_Unit_Name (Specification (Priv)));
9291 Current_Node := Sub;
9294 Make_Subprogram_Declaration (Loc,
9296 Build_Protected_Sub_Specification
9297 (Priv, Prot_Typ, Protected_Mode));
9299 Insert_After (Current_Node, Sub);
9301 Current_Node := Sub;
9303 if Is_Interrupt_Handler
9304 (Defining_Unit_Name (Specification (Priv)))
9306 if not Restricted_Profile then
9316 -- Except for the lock-free implementation, append the _Object field
9317 -- with the right type to the component list. We need to compute the
9318 -- number of entries, and in some cases the number of Attach_Handler
9321 if not Lock_Free_Active then
9323 Entry_Count_Expr : constant Node_Id :=
9324 Build_Entry_Count_Expression
9325 (Prot_Typ, Cdecls, Loc);
9326 Num_Attach_Handler : Nat := 0;
9327 Protection_Subtype : Node_Id;
9331 if Has_Attach_Handler (Prot_Typ) then
9332 Ritem := First_Rep_Item (Prot_Typ);
9333 while Present (Ritem) loop
9334 if Nkind (Ritem) = N_Pragma
9335 and then Pragma_Name (Ritem) = Name_Attach_Handler
9337 Num_Attach_Handler := Num_Attach_Handler + 1;
9340 Next_Rep_Item (Ritem);
9344 -- Determine the proper protection type. There are two special
9345 -- cases: 1) when the protected type has dynamic interrupt
9346 -- handlers, and 2) when it has static handlers and we use a
9347 -- restricted profile.
9349 if Has_Attach_Handler (Prot_Typ)
9350 and then not Restricted_Profile
9352 Protection_Subtype :=
9353 Make_Subtype_Indication (Loc,
9356 (RTE (RE_Static_Interrupt_Protection), Loc),
9358 Make_Index_Or_Discriminant_Constraint (Loc,
9359 Constraints => New_List (
9361 Make_Integer_Literal (Loc, Num_Attach_Handler))));
9363 elsif Has_Interrupt_Handler (Prot_Typ)
9364 and then not Restriction_Active (No_Dynamic_Attachment)
9366 Protection_Subtype :=
9367 Make_Subtype_Indication (Loc,
9370 (RTE (RE_Dynamic_Interrupt_Protection), Loc),
9372 Make_Index_Or_Discriminant_Constraint (Loc,
9373 Constraints => New_List (Entry_Count_Expr)));
9376 case Corresponding_Runtime_Package (Prot_Typ) is
9377 when System_Tasking_Protected_Objects_Entries =>
9378 Protection_Subtype :=
9379 Make_Subtype_Indication (Loc,
9382 (RTE (RE_Protection_Entries), Loc),
9384 Make_Index_Or_Discriminant_Constraint (Loc,
9385 Constraints => New_List (Entry_Count_Expr)));
9387 when System_Tasking_Protected_Objects_Single_Entry =>
9388 Protection_Subtype :=
9389 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc);
9391 when System_Tasking_Protected_Objects =>
9392 Protection_Subtype :=
9393 New_Occurrence_Of (RTE (RE_Protection), Loc);
9396 raise Program_Error;
9401 Make_Component_Declaration (Loc,
9402 Defining_Identifier =>
9403 Make_Defining_Identifier (Loc, Name_uObject),
9404 Component_Definition =>
9405 Make_Component_Definition (Loc,
9406 Aliased_Present => True,
9407 Subtype_Indication => Protection_Subtype));
9410 -- Put the _Object component after the private component so that it
9411 -- be finalized early as required by 9.4 (20)
9413 Append_To (Cdecls, Object_Comp);
9416 -- Analyze the record declaration immediately after construction,
9417 -- because the initialization procedure is needed for single object
9418 -- declarations before the next entity is analyzed (the freeze call
9419 -- that generates this initialization procedure is found below).
9421 Analyze (Rec_Decl, Suppress => All_Checks);
9423 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9424 -- the corresponding record is frozen. If any wrappers are generated,
9425 -- Current_Node is updated accordingly.
9427 if Ada_Version >= Ada_2005 then
9428 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
9431 -- Collect pointers to entry bodies and their barriers, to be placed
9432 -- in the Entry_Bodies_Array for the type. For each entry/family we
9433 -- add an expression to the aggregate which is the initial value of
9434 -- this array. The array is declared after all protected subprograms.
9436 if Has_Entries (Prot_Typ) then
9437 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
9439 Entries_Aggr := Empty;
9442 -- Build two new procedure specifications for each protected subprogram;
9443 -- one to call from outside the object and one to call from inside.
9444 -- Build a barrier function and an entry body action procedure
9445 -- specification for each protected entry. Initialize the entry body
9446 -- array. If subprogram is flagged as eliminated, do not generate any
9447 -- internal operations.
9450 Comp := First (Visible_Declarations (Pdef));
9451 while Present (Comp) loop
9452 if Nkind (Comp) = N_Subprogram_Declaration then
9454 Make_Subprogram_Declaration (Loc,
9456 Build_Protected_Sub_Specification
9457 (Comp, Prot_Typ, Unprotected_Mode));
9459 Insert_After (Current_Node, Sub);
9462 Set_Protected_Body_Subprogram
9463 (Defining_Unit_Name (Specification (Comp)),
9464 Defining_Unit_Name (Specification (Sub)));
9465 Check_Inlining (Defining_Unit_Name (Specification (Comp)));
9467 -- Make the protected version of the subprogram available for
9468 -- expansion of external calls.
9470 Current_Node := Sub;
9473 Make_Subprogram_Declaration (Loc,
9475 Build_Protected_Sub_Specification
9476 (Comp, Prot_Typ, Protected_Mode));
9478 Insert_After (Current_Node, Sub);
9481 Current_Node := Sub;
9483 -- Generate an overriding primitive operation specification for
9484 -- this subprogram if the protected type implements an interface
9485 -- and Build_Wrapper_Spec did not generate its wrapper.
9487 if Ada_Version >= Ada_2005
9489 Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
9492 Found : Boolean := False;
9493 Prim_Elmt : Elmt_Id;
9499 (Primitive_Operations
9500 (Corresponding_Record_Type (Prot_Typ)));
9502 while Present (Prim_Elmt) loop
9503 Prim_Op := Node (Prim_Elmt);
9505 if Is_Primitive_Wrapper (Prim_Op)
9506 and then Wrapped_Entity (Prim_Op) =
9507 Defining_Entity (Specification (Comp))
9513 Next_Elmt (Prim_Elmt);
9518 Make_Subprogram_Declaration (Loc,
9520 Build_Protected_Sub_Specification
9521 (Comp, Prot_Typ, Dispatching_Mode));
9523 Insert_After (Current_Node, Sub);
9526 Current_Node := Sub;
9531 -- If a pragma Interrupt_Handler applies, build and add a call to
9532 -- Register_Interrupt_Handler to the freezing actions of the
9533 -- protected version (Current_Node) of the subprogram:
9535 -- system.interrupts.register_interrupt_handler
9536 -- (prot_procP'address);
9538 if not Restricted_Profile
9539 and then Is_Interrupt_Handler
9540 (Defining_Unit_Name (Specification (Comp)))
9545 elsif Nkind (Comp) = N_Entry_Declaration then
9546 Expand_Entry_Declaration (Comp);
9552 -- If there are some private entry declarations, expand it as if they
9553 -- were visible entries.
9555 if Present (Private_Declarations (Pdef)) then
9556 Comp := First (Private_Declarations (Pdef));
9557 while Present (Comp) loop
9558 if Nkind (Comp) = N_Entry_Declaration then
9559 Expand_Entry_Declaration (Comp);
9566 -- Create the declaration of an array object which contains the values
9567 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9568 -- type. This object is later passed to the appropriate protected object
9569 -- initialization routine.
9571 if Has_Entries (Prot_Typ)
9572 and then Corresponding_Runtime_Package (Prot_Typ) =
9573 System_Tasking_Protected_Objects_Entries
9580 Maxes_Id : Entity_Id;
9581 Need_Array : Boolean := False;
9584 -- First check if there is any Max_Queue_Length pragma
9586 Item := First_Entity (Prot_Typ);
9587 while Present (Item) loop
9588 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then
9596 -- Gather the Max_Queue_Length values of all entries in a list. A
9597 -- value of zero indicates that the entry has no limitation on its
9602 Item := First_Entity (Prot_Typ);
9604 while Present (Item) loop
9605 if Is_Entry (Item) then
9608 Make_Integer_Literal
9609 (Loc, Get_Max_Queue_Length (Item)));
9615 -- Create the declaration of the array object. Generate:
9617 -- Maxes_Id : aliased constant
9618 -- Protected_Entry_Queue_Max_Array
9619 -- (1 .. Count) := (..., ...);
9622 Make_Defining_Identifier (Loc,
9623 Chars => New_External_Name (Chars (Prot_Typ), 'B'));
9626 Make_Object_Declaration (Loc,
9627 Defining_Identifier => Maxes_Id,
9628 Aliased_Present => True,
9629 Constant_Present => True,
9630 Object_Definition =>
9631 Make_Subtype_Indication (Loc,
9634 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
9636 Make_Index_Or_Discriminant_Constraint (Loc,
9637 Constraints => New_List (
9639 Make_Integer_Literal (Loc, 1),
9640 Make_Integer_Literal (Loc, Count))))),
9641 Expression => Make_Aggregate (Loc, Maxes));
9643 -- A pointer to this array will be placed in the corresponding
9644 -- record by its initialization procedure so this needs to be
9647 Insert_After (Current_Node, Max_Vals);
9648 Current_Node := Max_Vals;
9651 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id);
9656 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9657 -- all protected subprograms have been collected.
9659 if Has_Entries (Prot_Typ) then
9661 Make_Defining_Identifier (Sloc (Prot_Typ),
9662 Chars => New_External_Name (Chars (Prot_Typ), 'A'));
9664 case Corresponding_Runtime_Package (Prot_Typ) is
9665 when System_Tasking_Protected_Objects_Entries =>
9666 Expr := Entries_Aggr;
9668 Make_Subtype_Indication (Loc,
9671 (RTE (RE_Protected_Entry_Body_Array), Loc),
9673 Make_Index_Or_Discriminant_Constraint (Loc,
9674 Constraints => New_List (
9676 Make_Integer_Literal (Loc, 1),
9677 Make_Integer_Literal (Loc, E_Count)))));
9679 when System_Tasking_Protected_Objects_Single_Entry =>
9680 Expr := Remove_Head (Expressions (Entries_Aggr));
9681 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc);
9684 raise Program_Error;
9688 Make_Object_Declaration (Loc,
9689 Defining_Identifier => Body_Id,
9690 Aliased_Present => True,
9691 Constant_Present => True,
9692 Object_Definition => Obj_Def,
9693 Expression => Expr);
9695 -- A pointer to this array will be placed in the corresponding record
9696 -- by its initialization procedure so this needs to be analyzed here.
9698 Insert_After (Current_Node, Body_Arr);
9699 Current_Node := Body_Arr;
9702 Set_Entry_Bodies_Array (Prot_Typ, Body_Id);
9704 -- Finally, build the function that maps an entry index into the
9705 -- corresponding body. A pointer to this function is placed in each
9706 -- object of the type. Except for a ravenscar-like profile (no abort,
9707 -- no entry queue, 1 entry)
9709 if Corresponding_Runtime_Package (Prot_Typ) =
9710 System_Tasking_Protected_Objects_Entries
9713 Make_Subprogram_Declaration (Loc,
9714 Specification => Build_Find_Body_Index_Spec (Prot_Typ));
9716 Insert_After (Current_Node, Sub);
9720 end Expand_N_Protected_Type_Declaration;
9722 --------------------------------
9723 -- Expand_N_Requeue_Statement --
9724 --------------------------------
9726 -- A nondispatching requeue statement is expanded into one of four GNARLI
9727 -- operations, depending on the source and destination (task or protected
9728 -- object). A dispatching requeue statement is expanded into a call to the
9729 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9730 -- jump around the remainder of processing for the original entry and, if
9731 -- the destination is (different) protected object, to attempt to service
9732 -- it. The following illustrates the various cases:
9735 -- (O : System.Address;
9736 -- P : System.Address;
9737 -- E : Protected_Entry_Index)
9739 -- <discriminant renamings>
9740 -- <private object renamings>
9741 -- type poVP is access poV;
9742 -- _object : ptVP := ptVP!(O);
9746 -- <start of statement sequence for entry>
9748 -- -- Requeue from one protected entry body to another protected
9751 -- Requeue_Protected_Entry (
9752 -- _object._object'Access,
9753 -- new._object'Access,
9758 -- <some more of the statement sequence for entry>
9760 -- -- Requeue from an entry body to a task entry
9762 -- Requeue_Protected_To_Task_Entry (
9768 -- <rest of statement sequence for entry>
9769 -- Complete_Entry_Body (_object._object);
9772 -- when all others =>
9773 -- Exceptional_Complete_Entry_Body (
9774 -- _object._object, Get_GNAT_Exception);
9778 -- Requeue of a task entry call to a task entry
9780 -- Accept_Call (E, Ann);
9781 -- <start of statement sequence for accept statement>
9782 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9784 -- <rest of statement sequence for accept statement>
9786 -- Complete_Rendezvous;
9789 -- when all others =>
9790 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9792 -- Requeue of a task entry call to a protected entry
9794 -- Accept_Call (E, Ann);
9795 -- <start of statement sequence for accept statement>
9796 -- Requeue_Task_To_Protected_Entry (
9797 -- new._object'Access,
9802 -- <rest of statement sequence for accept statement>
9804 -- Complete_Rendezvous;
9807 -- when all others =>
9808 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9810 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9811 -- marked by pragma Implemented (XXX, By_Entry).
9813 -- The requeue is inside a protected entry:
9816 -- (O : System.Address;
9817 -- P : System.Address;
9818 -- E : Protected_Entry_Index)
9820 -- <discriminant renamings>
9821 -- <private object renamings>
9822 -- type poVP is access poV;
9823 -- _object : ptVP := ptVP!(O);
9827 -- <start of statement sequence for entry>
9830 -- (<interface class-wide object>,
9833 -- Ada.Tags.Get_Offset_Index
9835 -- <interface dispatch table index of target entry>),
9839 -- <rest of statement sequence for entry>
9840 -- Complete_Entry_Body (_object._object);
9843 -- when all others =>
9844 -- Exceptional_Complete_Entry_Body (
9845 -- _object._object, Get_GNAT_Exception);
9849 -- The requeue is inside a task entry:
9851 -- Accept_Call (E, Ann);
9852 -- <start of statement sequence for accept statement>
9854 -- (<interface class-wide object>,
9857 -- Ada.Tags.Get_Offset_Index
9859 -- <interface dispatch table index of target entrt>),
9863 -- <rest of statement sequence for accept statement>
9865 -- Complete_Rendezvous;
9868 -- when all others =>
9869 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9871 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9872 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9873 -- statement is replaced by a dispatching call with actual parameters taken
9874 -- from the inner-most accept statement or entry body.
9876 -- Target.Primitive (Param1, ..., ParamN);
9878 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9879 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9883 -- S : constant Offset_Index :=
9884 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9885 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9888 -- if C = POK_Protected_Entry
9889 -- or else C = POK_Task_Entry
9891 -- <statements for dispatching requeue>
9893 -- elsif C = POK_Protected_Procedure then
9894 -- <dispatching call equivalent>
9897 -- raise Program_Error;
9901 procedure Expand_N_Requeue_Statement (N : Node_Id) is
9902 Loc : constant Source_Ptr := Sloc (N);
9903 Conc_Typ : Entity_Id;
9907 Old_Typ : Entity_Id;
9909 function Build_Dispatching_Call_Equivalent return Node_Id;
9910 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9911 -- the form Concval.Ename. It is statically known that Ename is allowed
9912 -- to be implemented by a protected procedure. Create a dispatching call
9913 -- equivalent of Concval.Ename taking the actual parameters from the
9914 -- inner-most accept statement or entry body.
9916 function Build_Dispatching_Requeue return Node_Id;
9917 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9918 -- the form Concval.Ename. It is statically known that Ename is allowed
9919 -- to be implemented by a protected or a task entry. Create a call to
9920 -- primitive _Disp_Requeue which handles the low-level actions.
9922 function Build_Dispatching_Requeue_To_Any return Node_Id;
9923 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9924 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9925 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9926 -- determines at runtime whether Ename denotes an entry or a procedure
9927 -- and perform the appropriate kind of dispatching select.
9929 function Build_Normal_Requeue return Node_Id;
9930 -- N denotes a nondispatching requeue statement to either a task or a
9931 -- protected entry. Build the appropriate runtime call to perform the
9934 function Build_Skip_Statement (Search : Node_Id) return Node_Id;
9935 -- For a protected entry, create a return statement to skip the rest of
9936 -- the entry body. Otherwise, create a goto statement to skip the rest
9937 -- of a task accept statement. The lookup for the enclosing entry body
9938 -- or accept statement starts from Search.
9940 ---------------------------------------
9941 -- Build_Dispatching_Call_Equivalent --
9942 ---------------------------------------
9944 function Build_Dispatching_Call_Equivalent return Node_Id is
9945 Call_Ent : constant Entity_Id := Entity (Ename);
9946 Obj : constant Node_Id := Original_Node (Concval);
9953 -- Climb the parent chain looking for the inner-most entry body or
9954 -- accept statement.
9957 while Present (Acc_Ent)
9958 and then not Nkind_In (Acc_Ent, N_Accept_Statement,
9961 Acc_Ent := Parent (Acc_Ent);
9964 -- A requeue statement should be housed inside an entry body or an
9965 -- accept statement at some level. If this is not the case, then the
9966 -- tree is malformed.
9968 pragma Assert (Present (Acc_Ent));
9970 -- Recover the list of formal parameters
9972 if Nkind (Acc_Ent) = N_Entry_Body then
9973 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
9976 Formals := Parameter_Specifications (Acc_Ent);
9978 -- Create the actual parameters for the dispatching call. These are
9979 -- simply copies of the entry body or accept statement formals in the
9980 -- same order as they appear.
9984 if Present (Formals) then
9985 Actuals := New_List;
9986 Formal := First (Formals);
9987 while Present (Formal) loop
9989 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
9995 -- Obj.Call_Ent (Actuals);
9998 Make_Procedure_Call_Statement (Loc,
10000 Make_Selected_Component (Loc,
10001 Prefix => Make_Identifier (Loc, Chars (Obj)),
10002 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))),
10004 Parameter_Associations => Actuals);
10005 end Build_Dispatching_Call_Equivalent;
10007 -------------------------------
10008 -- Build_Dispatching_Requeue --
10009 -------------------------------
10011 function Build_Dispatching_Requeue return Node_Id is
10012 Params : constant List_Id := New_List;
10015 -- Process the "with abort" parameter
10017 Prepend_To (Params,
10018 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10020 -- Process the entry wrapper's position in the primary dispatch
10021 -- table parameter. Generate:
10023 -- Ada.Tags.Get_Entry_Index
10024 -- (T => To_Tag_Ptr (Obj'Address).all,
10026 -- Ada.Tags.Get_Offset_Index
10027 -- (Ada.Tags.Tag (Concval),
10028 -- <interface dispatch table position of Ename>));
10030 -- Note that Obj'Address is recursively expanded into a call to
10031 -- Base_Address (Obj).
10033 if Tagged_Type_Expansion then
10034 Prepend_To (Params,
10035 Make_Function_Call (Loc,
10036 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10037 Parameter_Associations => New_List (
10039 Make_Explicit_Dereference (Loc,
10040 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
10041 Make_Attribute_Reference (Loc,
10042 Prefix => New_Copy_Tree (Concval),
10043 Attribute_Name => Name_Address))),
10045 Make_Function_Call (Loc,
10046 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10047 Parameter_Associations => New_List (
10048 Unchecked_Convert_To (RTE (RE_Tag), Concval),
10049 Make_Integer_Literal (Loc,
10050 DT_Position (Entity (Ename))))))));
10055 Prepend_To (Params,
10056 Make_Function_Call (Loc,
10057 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10058 Parameter_Associations => New_List (
10060 Make_Attribute_Reference (Loc,
10062 Attribute_Name => Name_Tag),
10064 Make_Function_Call (Loc,
10065 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10067 Parameter_Associations => New_List (
10071 Make_Attribute_Reference (Loc,
10073 Attribute_Name => Name_Tag),
10077 Make_Attribute_Reference (Loc,
10078 Prefix => New_Occurrence_Of (Etype (Concval), Loc),
10079 Attribute_Name => Name_Tag),
10083 Make_Integer_Literal (Loc,
10084 DT_Position (Entity (Ename))))))));
10087 -- Specific actuals for protected to XXX requeue
10089 if Is_Protected_Type (Old_Typ) then
10090 Prepend_To (Params,
10091 Make_Attribute_Reference (Loc, -- _object'Address
10093 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10094 Attribute_Name => Name_Address));
10096 Prepend_To (Params, -- True
10097 New_Occurrence_Of (Standard_True, Loc));
10099 -- Specific actuals for task to XXX requeue
10102 pragma Assert (Is_Task_Type (Old_Typ));
10104 Prepend_To (Params, -- null
10105 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
10107 Prepend_To (Params, -- False
10108 New_Occurrence_Of (Standard_False, Loc));
10111 -- Add the object parameter
10113 Prepend_To (Params, New_Copy_Tree (Concval));
10116 -- _Disp_Requeue (<Params>);
10118 -- Find entity for Disp_Requeue operation, which belongs to
10119 -- the type and may not be directly visible.
10124 pragma Warnings (Off, Op);
10127 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
10128 while Present (Elmt) loop
10130 exit when Chars (Op) = Name_uDisp_Requeue;
10135 Make_Procedure_Call_Statement (Loc,
10136 Name => New_Occurrence_Of (Op, Loc),
10137 Parameter_Associations => Params);
10139 end Build_Dispatching_Requeue;
10141 --------------------------------------
10142 -- Build_Dispatching_Requeue_To_Any --
10143 --------------------------------------
10145 function Build_Dispatching_Requeue_To_Any return Node_Id is
10146 Call_Ent : constant Entity_Id := Entity (Ename);
10147 Obj : constant Node_Id := Original_Node (Concval);
10148 Skip : constant Node_Id := Build_Skip_Statement (N);
10158 -- Dispatch table slot processing, generate:
10161 S := Build_S (Loc, Decls);
10163 -- Call kind processing, generate:
10164 -- C : Ada.Tags.Prim_Op_Kind;
10166 C := Build_C (Loc, Decls);
10169 -- S := Ada.Tags.Get_Offset_Index
10170 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10172 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
10175 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10178 Make_Procedure_Call_Statement (Loc,
10180 New_Occurrence_Of (
10181 Find_Prim_Op (Etype (Etype (Obj)),
10182 Name_uDisp_Get_Prim_Op_Kind),
10184 Parameter_Associations => New_List (
10185 New_Copy_Tree (Obj),
10186 New_Occurrence_Of (S, Loc),
10187 New_Occurrence_Of (C, Loc))));
10191 -- if C = POK_Protected_Entry
10192 -- or else C = POK_Task_Entry
10195 Make_Implicit_If_Statement (N,
10201 New_Occurrence_Of (C, Loc),
10203 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
10208 New_Occurrence_Of (C, Loc),
10210 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
10212 -- Dispatching requeue equivalent
10214 Then_Statements => New_List (
10215 Build_Dispatching_Requeue,
10218 -- elsif C = POK_Protected_Procedure then
10220 Elsif_Parts => New_List (
10221 Make_Elsif_Part (Loc,
10225 New_Occurrence_Of (C, Loc),
10227 New_Occurrence_Of (
10228 RTE (RE_POK_Protected_Procedure), Loc)),
10230 -- Dispatching call equivalent
10232 Then_Statements => New_List (
10233 Build_Dispatching_Call_Equivalent))),
10236 -- raise Program_Error;
10239 Else_Statements => New_List (
10240 Make_Raise_Program_Error (Loc,
10241 Reason => PE_Explicit_Raise))));
10243 -- Wrap everything into a block
10246 Make_Block_Statement (Loc,
10247 Declarations => Decls,
10248 Handled_Statement_Sequence =>
10249 Make_Handled_Sequence_Of_Statements (Loc,
10250 Statements => Stmts));
10251 end Build_Dispatching_Requeue_To_Any;
10253 --------------------------
10254 -- Build_Normal_Requeue --
10255 --------------------------
10257 function Build_Normal_Requeue return Node_Id is
10258 Params : constant List_Id := New_List;
10263 -- Process the "with abort" parameter
10265 Prepend_To (Params,
10266 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10268 -- Add the index expression to the parameters. It is common among all
10271 Prepend_To (Params,
10272 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
10274 if Is_Protected_Type (Old_Typ) then
10276 Self_Param : Node_Id;
10280 Make_Attribute_Reference (Loc,
10282 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10284 Name_Unchecked_Access);
10286 -- Protected to protected requeue
10288 if Is_Protected_Type (Conc_Typ) then
10290 New_Occurrence_Of (
10291 RTE (RE_Requeue_Protected_Entry), Loc);
10294 Make_Attribute_Reference (Loc,
10296 Concurrent_Ref (Concval),
10298 Name_Unchecked_Access);
10300 -- Protected to task requeue
10302 else pragma Assert (Is_Task_Type (Conc_Typ));
10304 New_Occurrence_Of (
10305 RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
10307 Param := Concurrent_Ref (Concval);
10310 Prepend_To (Params, Param);
10311 Prepend_To (Params, Self_Param);
10314 else pragma Assert (Is_Task_Type (Old_Typ));
10316 -- Task to protected requeue
10318 if Is_Protected_Type (Conc_Typ) then
10320 New_Occurrence_Of (
10321 RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
10324 Make_Attribute_Reference (Loc,
10326 Concurrent_Ref (Concval),
10328 Name_Unchecked_Access);
10330 -- Task to task requeue
10332 else pragma Assert (Is_Task_Type (Conc_Typ));
10334 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc);
10336 Param := Concurrent_Ref (Concval);
10339 Prepend_To (Params, Param);
10343 Make_Procedure_Call_Statement (Loc,
10345 Parameter_Associations => Params);
10346 end Build_Normal_Requeue;
10348 --------------------------
10349 -- Build_Skip_Statement --
10350 --------------------------
10352 function Build_Skip_Statement (Search : Node_Id) return Node_Id is
10353 Skip_Stmt : Node_Id;
10356 -- Build a return statement to skip the rest of the entire body
10358 if Is_Protected_Type (Old_Typ) then
10359 Skip_Stmt := Make_Simple_Return_Statement (Loc);
10361 -- If the requeue is within a task, find the end label of the
10362 -- enclosing accept statement and create a goto statement to it.
10370 -- Climb the parent chain looking for the enclosing accept
10373 Acc := Parent (Search);
10374 while Present (Acc)
10375 and then Nkind (Acc) /= N_Accept_Statement
10377 Acc := Parent (Acc);
10380 -- The last statement is the second label used for completing
10381 -- the rendezvous the usual way. The label we are looking for
10382 -- is right before it.
10385 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
10387 pragma Assert (Nkind (Label) = N_Label);
10389 -- Generate a goto statement to skip the rest of the accept
10392 Make_Goto_Statement (Loc,
10394 New_Occurrence_Of (Entity (Identifier (Label)), Loc));
10398 Set_Analyzed (Skip_Stmt);
10401 end Build_Skip_Statement;
10403 -- Start of processing for Expand_N_Requeue_Statement
10406 -- Extract the components of the entry call
10408 Extract_Entry (N, Concval, Ename, Index);
10409 Conc_Typ := Etype (Concval);
10411 -- If the prefix is an access to class-wide type, dereference to get
10412 -- object and entry type.
10414 if Is_Access_Type (Conc_Typ) then
10415 Conc_Typ := Designated_Type (Conc_Typ);
10417 Make_Explicit_Dereference (Loc, Relocate_Node (Concval)));
10418 Analyze_And_Resolve (Concval, Conc_Typ);
10421 -- Examine the scope stack in order to find nearest enclosing protected
10422 -- or task type. This will constitute our invocation source.
10424 Old_Typ := Current_Scope;
10425 while Present (Old_Typ)
10426 and then not Is_Protected_Type (Old_Typ)
10427 and then not Is_Task_Type (Old_Typ)
10429 Old_Typ := Scope (Old_Typ);
10432 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10433 -- Concval.Ename where the type of Concval is class-wide concurrent
10436 if Ada_Version >= Ada_2012
10437 and then Present (Concval)
10438 and then Is_Class_Wide_Type (Conc_Typ)
10439 and then Is_Concurrent_Interface (Conc_Typ)
10442 Has_Impl : Boolean := False;
10443 Impl_Kind : Name_Id := No_Name;
10446 -- Check whether the Ename is flagged by pragma Implemented
10448 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
10450 Impl_Kind := Implementation_Kind (Entity (Ename));
10453 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10454 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10456 if Has_Impl and then Impl_Kind = Name_By_Entry then
10457 Rewrite (N, Build_Dispatching_Requeue);
10459 Insert_After (N, Build_Skip_Statement (N));
10461 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10462 -- a protected procedure. In this case the requeue is transformed
10463 -- into a dispatching call.
10466 and then Impl_Kind = Name_By_Protected_Procedure
10468 Rewrite (N, Build_Dispatching_Call_Equivalent);
10471 -- The procedure_or_entry_NAME's implementation kind is either
10472 -- By_Any, Optional, or pragma Implemented was not applied at all.
10473 -- In this case a runtime test determines whether Ename denotes an
10474 -- entry or a protected procedure and performs the appropriate
10478 Rewrite (N, Build_Dispatching_Requeue_To_Any);
10483 -- Processing for regular (nondispatching) requeues
10486 Rewrite (N, Build_Normal_Requeue);
10488 Insert_After (N, Build_Skip_Statement (N));
10490 end Expand_N_Requeue_Statement;
10492 -------------------------------
10493 -- Expand_N_Selective_Accept --
10494 -------------------------------
10496 procedure Expand_N_Selective_Accept (N : Node_Id) is
10497 Loc : constant Source_Ptr := Sloc (N);
10498 Alts : constant List_Id := Select_Alternatives (N);
10500 -- Note: in the below declarations a lot of new lists are allocated
10501 -- unconditionally which may well not end up being used. That's not
10502 -- a good idea since it wastes space gratuitously ???
10504 Accept_Case : List_Id;
10505 Accept_List : constant List_Id := New_List;
10508 Alt_List : constant List_Id := New_List;
10509 Alt_Stats : List_Id;
10510 Ann : Entity_Id := Empty;
10512 Check_Guard : Boolean := True;
10514 Decls : constant List_Id := New_List;
10515 Stats : constant List_Id := New_List;
10516 Body_List : constant List_Id := New_List;
10517 Trailing_List : constant List_Id := New_List;
10520 Else_Present : Boolean := False;
10521 Terminate_Alt : Node_Id := Empty;
10522 Select_Mode : Node_Id;
10524 Delay_Case : List_Id;
10525 Delay_Count : Integer := 0;
10526 Delay_Val : Entity_Id;
10527 Delay_Index : Entity_Id;
10528 Delay_Min : Entity_Id;
10529 Delay_Num : Pos := 1;
10530 Delay_Alt_List : List_Id := New_List;
10531 Delay_List : constant List_Id := New_List;
10535 First_Delay : Boolean := True;
10536 Guard_Open : Entity_Id;
10542 Num_Accept : Nat := 0;
10544 Time_Type : Entity_Id;
10545 Select_Call : Node_Id;
10547 Qnam : constant Entity_Id :=
10548 Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
10550 Xnam : constant Entity_Id :=
10551 Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
10553 -----------------------
10554 -- Local subprograms --
10555 -----------------------
10557 function Accept_Or_Raise return List_Id;
10558 -- For the rare case where delay alternatives all have guards, and
10559 -- all of them are closed, it is still possible that there were open
10560 -- accept alternatives with no callers. We must reexamine the
10561 -- Accept_List, and execute a selective wait with no else if some
10562 -- accept is open. If none, we raise program_error.
10564 procedure Add_Accept (Alt : Node_Id);
10565 -- Process a single accept statement in a select alternative. Build
10566 -- procedure for body of accept, and add entry to dispatch table with
10567 -- expression for guard, in preparation for call to run time select.
10569 function Make_And_Declare_Label (Num : Int) return Node_Id;
10570 -- Manufacture a label using Num as a serial number and declare it.
10571 -- The declaration is appended to Decls. The label marks the trailing
10572 -- statements of an accept or delay alternative.
10574 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
10575 -- Build call to Selective_Wait runtime routine
10577 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
10578 -- Add code to compare value of delay with previous values, and
10579 -- generate case entry for trailing statements.
10581 procedure Process_Accept_Alternative
10585 -- Add code to call corresponding procedure, and branch to
10586 -- trailing statements, if any.
10588 ---------------------
10589 -- Accept_Or_Raise --
10590 ---------------------
10592 function Accept_Or_Raise return List_Id is
10595 J : constant Entity_Id := Make_Temporary (Loc, 'J');
10598 -- We generate the following:
10600 -- for J in q'range loop
10601 -- if q(J).S /=null_task_entry then
10602 -- selective_wait (simple_mode,...);
10608 -- if no rendez_vous then
10609 -- raise program_error;
10612 -- Note that the code needs to know that the selector name
10613 -- in an Accept_Alternative is named S.
10615 Cond := Make_Op_Ne (Loc,
10617 Make_Selected_Component (Loc,
10619 Make_Indexed_Component (Loc,
10620 Prefix => New_Occurrence_Of (Qnam, Loc),
10621 Expressions => New_List (New_Occurrence_Of (J, Loc))),
10622 Selector_Name => Make_Identifier (Loc, Name_S)),
10624 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc));
10626 Stats := New_List (
10627 Make_Implicit_Loop_Statement (N,
10628 Iteration_Scheme =>
10629 Make_Iteration_Scheme (Loc,
10630 Loop_Parameter_Specification =>
10631 Make_Loop_Parameter_Specification (Loc,
10632 Defining_Identifier => J,
10633 Discrete_Subtype_Definition =>
10634 Make_Attribute_Reference (Loc,
10635 Prefix => New_Occurrence_Of (Qnam, Loc),
10636 Attribute_Name => Name_Range,
10637 Expressions => New_List (
10638 Make_Integer_Literal (Loc, 1))))),
10640 Statements => New_List (
10641 Make_Implicit_If_Statement (N,
10643 Then_Statements => New_List (
10645 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)),
10646 Make_Exit_Statement (Loc))))));
10649 Make_Raise_Program_Error (Loc,
10650 Condition => Make_Op_Eq (Loc,
10651 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
10653 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
10654 Reason => PE_All_Guards_Closed));
10657 end Accept_Or_Raise;
10663 procedure Add_Accept (Alt : Node_Id) is
10664 Acc_Stm : constant Node_Id := Accept_Statement (Alt);
10665 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm);
10666 Eloc : constant Source_Ptr := Sloc (Ename);
10667 Eent : constant Entity_Id := Entity (Ename);
10668 Index : constant Node_Id := Entry_Index (Acc_Stm);
10672 Null_Body : Node_Id;
10673 PB_Ent : Entity_Id;
10674 Proc_Body : Node_Id;
10676 -- Start of processing for Add_Accept
10680 Ann := Node (Last_Elmt (Accept_Address (Eent)));
10683 if Present (Condition (Alt)) then
10685 Make_If_Expression (Eloc, New_List (
10687 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
10688 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc)));
10690 Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent));
10693 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
10694 Null_Body := New_Occurrence_Of (Standard_False, Eloc);
10696 -- Always add call to Abort_Undefer when generating code, since
10697 -- this is what the runtime expects (abort deferred in
10698 -- Selective_Wait). In CodePeer mode this only confuses the
10699 -- analysis with unknown calls, so don't do it.
10701 if not CodePeer_Mode then
10702 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
10704 (First (Statements (Handled_Statement_Sequence
10705 (Accept_Statement (Alt)))),
10711 Make_Defining_Identifier (Eloc,
10712 New_External_Name (Chars (Ename), 'A', Num_Accept));
10714 -- Link the acceptor to the original receiving entry
10716 Set_Ekind (PB_Ent, E_Procedure);
10717 Set_Receiving_Entry (PB_Ent, Eent);
10719 if Comes_From_Source (Alt) then
10720 Set_Debug_Info_Needed (PB_Ent);
10724 Make_Subprogram_Body (Eloc,
10726 Make_Procedure_Specification (Eloc,
10727 Defining_Unit_Name => PB_Ent),
10728 Declarations => Declarations (Acc_Stm),
10729 Handled_Statement_Sequence =>
10730 Build_Accept_Body (Accept_Statement (Alt)));
10732 Reset_Scopes_To (Proc_Body, PB_Ent);
10734 -- During the analysis of the body of the accept statement, any
10735 -- zero cost exception handler records were collected in the
10736 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10737 -- This is where we move them to where they belong, namely the
10738 -- newly created procedure.
10740 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
10741 Append (Proc_Body, Body_List);
10744 Null_Body := New_Occurrence_Of (Standard_True, Eloc);
10746 -- if accept statement has declarations, insert above, given that
10747 -- we are not creating a body for the accept.
10749 if Present (Declarations (Acc_Stm)) then
10750 Insert_Actions (N, Declarations (Acc_Stm));
10754 Append_To (Accept_List,
10755 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr)));
10757 Num_Accept := Num_Accept + 1;
10760 ----------------------------
10761 -- Make_And_Declare_Label --
10762 ----------------------------
10764 function Make_And_Declare_Label (Num : Int) return Node_Id is
10768 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
10770 Make_Label (Loc, Lab_Id);
10773 Make_Implicit_Label_Declaration (Loc,
10774 Defining_Identifier =>
10775 Make_Defining_Identifier (Loc, Chars (Lab_Id)),
10776 Label_Construct => Lab));
10779 end Make_And_Declare_Label;
10781 ----------------------
10782 -- Make_Select_Call --
10783 ----------------------
10785 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
10786 Params : constant List_Id := New_List;
10790 Make_Attribute_Reference (Loc,
10791 Prefix => New_Occurrence_Of (Qnam, Loc),
10792 Attribute_Name => Name_Unchecked_Access));
10793 Append_To (Params, Select_Mode);
10794 Append_To (Params, New_Occurrence_Of (Ann, Loc));
10795 Append_To (Params, New_Occurrence_Of (Xnam, Loc));
10798 Make_Procedure_Call_Statement (Loc,
10799 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc),
10800 Parameter_Associations => Params);
10801 end Make_Select_Call;
10803 --------------------------------
10804 -- Process_Accept_Alternative --
10805 --------------------------------
10807 procedure Process_Accept_Alternative
10812 Astmt : constant Node_Id := Accept_Statement (Alt);
10813 Alt_Stats : List_Id;
10816 Adjust_Condition (Condition (Alt));
10818 -- Accept with body
10820 if Present (Handled_Statement_Sequence (Astmt)) then
10823 Make_Procedure_Call_Statement (Sloc (Proc),
10826 (Defining_Unit_Name (Specification (Proc)),
10829 -- Accept with no body (followed by trailing statements)
10832 Alt_Stats := Empty_List;
10835 Ensure_Statement_Present (Sloc (Astmt), Alt);
10837 -- After the call, if any, branch to trailing statements, if any.
10838 -- We create a label for each, as well as the corresponding label
10841 if not Is_Empty_List (Statements (Alt)) then
10842 Lab := Make_And_Declare_Label (Index);
10843 Append (Lab, Trailing_List);
10844 Append_List (Statements (Alt), Trailing_List);
10845 Append_To (Trailing_List,
10846 Make_Goto_Statement (Loc,
10847 Name => New_Copy (Identifier (End_Lab))));
10853 Append_To (Alt_Stats,
10854 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab))));
10856 Append_To (Alt_List,
10857 Make_Case_Statement_Alternative (Loc,
10858 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)),
10859 Statements => Alt_Stats));
10860 end Process_Accept_Alternative;
10862 -------------------------------
10863 -- Process_Delay_Alternative --
10864 -------------------------------
10866 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
10867 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt));
10869 Delay_Alt : List_Id;
10872 -- Deal with C/Fortran boolean as delay condition
10874 Adjust_Condition (Condition (Alt));
10876 -- Determine the smallest specified delay
10878 -- for each delay alternative generate:
10880 -- if guard-expression then
10881 -- Delay_Val := delay-expression;
10882 -- Guard_Open := True;
10883 -- if Delay_Val < Delay_Min then
10884 -- Delay_Min := Delay_Val;
10885 -- Delay_Index := Index;
10889 -- The enclosing if-statement is omitted if there is no guard
10891 if Delay_Count = 1 or else First_Delay then
10892 First_Delay := False;
10894 Delay_Alt := New_List (
10895 Make_Assignment_Statement (Loc,
10896 Name => New_Occurrence_Of (Delay_Min, Loc),
10897 Expression => Expression (Delay_Statement (Alt))));
10899 if Delay_Count > 1 then
10900 Append_To (Delay_Alt,
10901 Make_Assignment_Statement (Loc,
10902 Name => New_Occurrence_Of (Delay_Index, Loc),
10903 Expression => Make_Integer_Literal (Loc, Index)));
10907 Delay_Alt := New_List (
10908 Make_Assignment_Statement (Loc,
10909 Name => New_Occurrence_Of (Delay_Val, Loc),
10910 Expression => Expression (Delay_Statement (Alt))));
10912 if Time_Type = Standard_Duration then
10915 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc),
10916 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc));
10919 -- The scope of the time type must define a comparison
10920 -- operator. The scope itself may not be visible, so we
10921 -- construct a node with entity information to insure that
10922 -- semantic analysis can find the proper operator.
10925 Make_Function_Call (Loc,
10926 Name => Make_Selected_Component (Loc,
10928 New_Occurrence_Of (Scope (Time_Type), Loc),
10930 Make_Operator_Symbol (Loc,
10931 Chars => Name_Op_Lt,
10932 Strval => No_String)),
10933 Parameter_Associations =>
10935 New_Occurrence_Of (Delay_Val, Loc),
10936 New_Occurrence_Of (Delay_Min, Loc)));
10938 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
10941 Append_To (Delay_Alt,
10942 Make_Implicit_If_Statement (N,
10944 Then_Statements => New_List (
10945 Make_Assignment_Statement (Loc,
10946 Name => New_Occurrence_Of (Delay_Min, Loc),
10947 Expression => New_Occurrence_Of (Delay_Val, Loc)),
10949 Make_Assignment_Statement (Loc,
10950 Name => New_Occurrence_Of (Delay_Index, Loc),
10951 Expression => Make_Integer_Literal (Loc, Index)))));
10954 if Check_Guard then
10955 Append_To (Delay_Alt,
10956 Make_Assignment_Statement (Loc,
10957 Name => New_Occurrence_Of (Guard_Open, Loc),
10958 Expression => New_Occurrence_Of (Standard_True, Loc)));
10961 if Present (Condition (Alt)) then
10962 Delay_Alt := New_List (
10963 Make_Implicit_If_Statement (N,
10964 Condition => Condition (Alt),
10965 Then_Statements => Delay_Alt));
10968 Append_List (Delay_Alt, Delay_List);
10970 Ensure_Statement_Present (Dloc, Alt);
10972 -- If the delay alternative has a statement part, add choice to the
10973 -- case statements for delays.
10975 if not Is_Empty_List (Statements (Alt)) then
10977 if Delay_Count = 1 then
10978 Append_List (Statements (Alt), Delay_Alt_List);
10981 Append_To (Delay_Alt_List,
10982 Make_Case_Statement_Alternative (Loc,
10983 Discrete_Choices => New_List (
10984 Make_Integer_Literal (Loc, Index)),
10985 Statements => Statements (Alt)));
10988 elsif Delay_Count = 1 then
10990 -- If the single delay has no trailing statements, add a branch
10991 -- to the exit label to the selective wait.
10993 Delay_Alt_List := New_List (
10994 Make_Goto_Statement (Loc,
10995 Name => New_Copy (Identifier (End_Lab))));
10998 end Process_Delay_Alternative;
11000 -- Start of processing for Expand_N_Selective_Accept
11003 Process_Statements_For_Controlled_Objects (N);
11005 -- First insert some declarations before the select. The first is:
11009 -- This variable holds the parameters passed to the accept body. This
11010 -- declaration has already been inserted by the time we get here by
11011 -- a call to Expand_Accept_Declarations made from the semantics when
11012 -- processing the first accept statement contained in the select. We
11013 -- can find this entity as Accept_Address (E), where E is any of the
11014 -- entries references by contained accept statements.
11016 -- The first step is to scan the list of Selective_Accept_Statements
11017 -- to find this entity, and also count the number of accepts, and
11018 -- determine if terminated, delay or else is present:
11022 Alt := First (Alts);
11023 while Present (Alt) loop
11024 Process_Statements_For_Controlled_Objects (Alt);
11026 if Nkind (Alt) = N_Accept_Alternative then
11029 elsif Nkind (Alt) = N_Delay_Alternative then
11030 Delay_Count := Delay_Count + 1;
11032 -- If the delays are relative delays, the delay expressions have
11033 -- type Standard_Duration. Otherwise they must have some time type
11034 -- recognized by GNAT.
11036 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
11037 Time_Type := Standard_Duration;
11039 Time_Type := Etype (Expression (Delay_Statement (Alt)));
11041 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
11042 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
11047 "& is not a time type (RM 9.6(6))",
11048 Expression (Delay_Statement (Alt)), Time_Type);
11049 Time_Type := Standard_Duration;
11050 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
11054 if No (Condition (Alt)) then
11056 -- This guard will always be open
11058 Check_Guard := False;
11061 elsif Nkind (Alt) = N_Terminate_Alternative then
11062 Adjust_Condition (Condition (Alt));
11063 Terminate_Alt := Alt;
11066 Num_Alts := Num_Alts + 1;
11070 Else_Present := Present (Else_Statements (N));
11072 -- At the same time (see procedure Add_Accept) we build the accept list:
11074 -- Qnn : Accept_List (1 .. num-select) := (
11075 -- (null-body, entry-index),
11076 -- (null-body, entry-index),
11078 -- (null_body, entry-index));
11080 -- In the above declaration, null-body is True if the corresponding
11081 -- accept has no body, and false otherwise. The entry is either the
11082 -- entry index expression if there is no guard, or if a guard is
11083 -- present, then an if expression of the form:
11085 -- (if guard then entry-index else Null_Task_Entry)
11087 -- If a guard is statically known to be false, the entry can simply
11088 -- be omitted from the accept list.
11091 Make_Object_Declaration (Loc,
11092 Defining_Identifier => Qnam,
11093 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11094 Aliased_Present => True,
11096 Make_Qualified_Expression (Loc,
11098 New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11100 Make_Aggregate (Loc, Expressions => Accept_List))));
11102 -- Then we declare the variable that holds the index for the accept
11103 -- that will be selected for service:
11105 -- Xnn : Select_Index;
11108 Make_Object_Declaration (Loc,
11109 Defining_Identifier => Xnam,
11110 Object_Definition =>
11111 New_Occurrence_Of (RTE (RE_Select_Index), Loc),
11113 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)));
11115 -- After this follow procedure declarations for each accept body
11117 -- procedure Pnn is
11122 -- where the ... are statements from the corresponding procedure body.
11123 -- No parameters are involved, since the parameters are passed via Ann
11124 -- and the parameter references have already been expanded to be direct
11125 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11126 -- any embedded tasking statements (which would normally be illegal in
11127 -- procedures), have been converted to calls to the tasking runtime so
11128 -- there is no problem in putting them into procedures.
11130 -- The original accept statement has been expanded into a block in
11131 -- the same fashion as for simple accepts (see Build_Accept_Body).
11133 -- Note: we don't really need to build these procedures for the case
11134 -- where no delay statement is present, but it is just as easy to
11135 -- build them unconditionally, and not significantly inefficient,
11136 -- since if they are short they will be inlined anyway.
11138 -- The procedure declarations have been assembled in Body_List
11140 -- If delays are present, we must compute the required delay.
11141 -- We first generate the declarations:
11143 -- Delay_Index : Boolean := 0;
11144 -- Delay_Min : Some_Time_Type.Time;
11145 -- Delay_Val : Some_Time_Type.Time;
11147 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11148 -- active delay that is actually chosen as the basis for the possible
11149 -- delay if an immediate rendez-vous is not possible.
11151 -- In the most common case there is a single delay statement, and this
11152 -- is handled specially.
11154 if Delay_Count > 0 then
11156 -- Generate the required declarations
11159 Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
11161 Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
11163 Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
11166 Make_Object_Declaration (Loc,
11167 Defining_Identifier => Delay_Val,
11168 Object_Definition => New_Occurrence_Of (Time_Type, Loc)));
11171 Make_Object_Declaration (Loc,
11172 Defining_Identifier => Delay_Index,
11173 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
11174 Expression => Make_Integer_Literal (Loc, 0)));
11177 Make_Object_Declaration (Loc,
11178 Defining_Identifier => Delay_Min,
11179 Object_Definition => New_Occurrence_Of (Time_Type, Loc),
11181 Unchecked_Convert_To (Time_Type,
11182 Make_Attribute_Reference (Loc,
11184 New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
11185 Attribute_Name => Name_Last))));
11187 -- Create Duration and Delay_Mode objects used for passing a delay
11190 D := Make_Temporary (Loc, 'D');
11191 M := Make_Temporary (Loc, 'M');
11197 -- Note that these values are defined in s-osprim.ads and must
11198 -- be kept in sync:
11200 -- Relative : constant := 0;
11201 -- Absolute_Calendar : constant := 1;
11202 -- Absolute_RT : constant := 2;
11204 if Time_Type = Standard_Duration then
11205 Discr := Make_Integer_Literal (Loc, 0);
11207 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11208 Discr := Make_Integer_Literal (Loc, 1);
11212 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11213 Discr := Make_Integer_Literal (Loc, 2);
11217 Make_Object_Declaration (Loc,
11218 Defining_Identifier => D,
11219 Object_Definition =>
11220 New_Occurrence_Of (Standard_Duration, Loc)));
11223 Make_Object_Declaration (Loc,
11224 Defining_Identifier => M,
11225 Object_Definition =>
11226 New_Occurrence_Of (Standard_Integer, Loc),
11227 Expression => Discr));
11230 if Check_Guard then
11232 Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
11235 Make_Object_Declaration (Loc,
11236 Defining_Identifier => Guard_Open,
11237 Object_Definition =>
11238 New_Occurrence_Of (Standard_Boolean, Loc),
11240 New_Occurrence_Of (Standard_False, Loc)));
11243 -- Delay_Count is zero, don't need M and D set (suppress warning)
11250 if Present (Terminate_Alt) then
11252 -- If the terminate alternative guard is False, use
11253 -- Simple_Mode; otherwise use Terminate_Mode.
11255 if Present (Condition (Terminate_Alt)) then
11256 Select_Mode := Make_If_Expression (Loc,
11257 New_List (Condition (Terminate_Alt),
11258 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc),
11259 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)));
11261 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc);
11264 elsif Else_Present or Delay_Count > 0 then
11265 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc);
11268 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc);
11271 Select_Call := Make_Select_Call (Select_Mode);
11272 Append (Select_Call, Stats);
11274 -- Now generate code to act on the result. There is an entry
11275 -- in this case for each accept statement with a non-null body,
11276 -- followed by a branch to the statements that follow the Accept.
11277 -- In the absence of delay alternatives, we generate:
11280 -- when No_Rendezvous => -- omitted if simple mode
11295 -- Lab0: Else_Statements;
11298 -- Lab1: Trailing_Statements1;
11301 -- Lab2: Trailing_Statements2;
11306 -- Generate label for common exit
11308 End_Lab := Make_And_Declare_Label (Num_Alts + 1);
11310 -- First entry is the default case, when no rendezvous is possible
11312 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc));
11314 if Else_Present then
11316 -- If no rendezvous is possible, the else part is executed
11318 Lab := Make_And_Declare_Label (0);
11319 Alt_Stats := New_List (
11320 Make_Goto_Statement (Loc,
11321 Name => New_Copy (Identifier (Lab))));
11323 Append (Lab, Trailing_List);
11324 Append_List (Else_Statements (N), Trailing_List);
11325 Append_To (Trailing_List,
11326 Make_Goto_Statement (Loc,
11327 Name => New_Copy (Identifier (End_Lab))));
11329 Alt_Stats := New_List (
11330 Make_Goto_Statement (Loc,
11331 Name => New_Copy (Identifier (End_Lab))));
11334 Append_To (Alt_List,
11335 Make_Case_Statement_Alternative (Loc,
11336 Discrete_Choices => Choices,
11337 Statements => Alt_Stats));
11339 -- We make use of the fact that Accept_Index is an integer type, and
11340 -- generate successive literals for entries for each accept. Only those
11341 -- for which there is a body or trailing statements get a case entry.
11343 Alt := First (Select_Alternatives (N));
11344 Proc := First (Body_List);
11345 while Present (Alt) loop
11347 if Nkind (Alt) = N_Accept_Alternative then
11348 Process_Accept_Alternative (Alt, Index, Proc);
11349 Index := Index + 1;
11352 (Handled_Statement_Sequence (Accept_Statement (Alt)))
11357 elsif Nkind (Alt) = N_Delay_Alternative then
11358 Process_Delay_Alternative (Alt, Delay_Num);
11359 Delay_Num := Delay_Num + 1;
11365 -- An others choice is always added to the main case, as well
11366 -- as the delay case (to satisfy the compiler).
11368 Append_To (Alt_List,
11369 Make_Case_Statement_Alternative (Loc,
11370 Discrete_Choices =>
11371 New_List (Make_Others_Choice (Loc)),
11373 New_List (Make_Goto_Statement (Loc,
11374 Name => New_Copy (Identifier (End_Lab))))));
11376 Accept_Case := New_List (
11377 Make_Case_Statement (Loc,
11378 Expression => New_Occurrence_Of (Xnam, Loc),
11379 Alternatives => Alt_List));
11381 Append_List (Trailing_List, Accept_Case);
11382 Append_List (Body_List, Decls);
11384 -- Construct case statement for trailing statements of delay
11385 -- alternatives, if there are several of them.
11387 if Delay_Count > 1 then
11388 Append_To (Delay_Alt_List,
11389 Make_Case_Statement_Alternative (Loc,
11390 Discrete_Choices =>
11391 New_List (Make_Others_Choice (Loc)),
11393 New_List (Make_Null_Statement (Loc))));
11395 Delay_Case := New_List (
11396 Make_Case_Statement (Loc,
11397 Expression => New_Occurrence_Of (Delay_Index, Loc),
11398 Alternatives => Delay_Alt_List));
11400 Delay_Case := Delay_Alt_List;
11403 -- If there are no delay alternatives, we append the case statement
11404 -- to the statement list.
11406 if Delay_Count = 0 then
11407 Append_List (Accept_Case, Stats);
11409 -- Delay alternatives present
11412 -- If delay alternatives are present we generate:
11414 -- find minimum delay.
11415 -- DX := minimum delay;
11416 -- M := <delay mode>;
11417 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11420 -- if X = No_Rendezvous then
11421 -- case statement for delay statements.
11423 -- case statement for accept alternatives.
11434 -- The type of the delay expression is known to be legal
11436 if Time_Type = Standard_Duration then
11437 Conv := New_Occurrence_Of (Delay_Min, Loc);
11439 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11440 Conv := Make_Function_Call (Loc,
11441 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
11442 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11446 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11448 Conv := Make_Function_Call (Loc,
11449 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
11450 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11453 Stmt := Make_Assignment_Statement (Loc,
11454 Name => New_Occurrence_Of (D, Loc),
11455 Expression => Conv);
11457 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11459 Parms := Parameter_Associations (Select_Call);
11461 Parm := First (Parms);
11462 while Present (Parm) and then Parm /= Select_Mode loop
11466 pragma Assert (Present (Parm));
11467 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc));
11470 -- Prepare two new parameters of Duration and Delay_Mode type
11471 -- which represent the value and the mode of the minimum delay.
11474 Insert_After (Parm, New_Occurrence_Of (M, Loc));
11475 Insert_After (Parm, New_Occurrence_Of (D, Loc));
11477 -- Create a call to RTS
11479 Rewrite (Select_Call,
11480 Make_Procedure_Call_Statement (Loc,
11481 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc),
11482 Parameter_Associations => Parms));
11484 -- This new call should follow the calculation of the minimum
11487 Insert_List_Before (Select_Call, Delay_List);
11489 if Check_Guard then
11491 Make_Implicit_If_Statement (N,
11492 Condition => New_Occurrence_Of (Guard_Open, Loc),
11493 Then_Statements => New_List (
11494 New_Copy_Tree (Stmt),
11495 New_Copy_Tree (Select_Call)),
11496 Else_Statements => Accept_Or_Raise);
11497 Rewrite (Select_Call, Stmt);
11499 Insert_Before (Select_Call, Stmt);
11503 Make_Implicit_If_Statement (N,
11504 Condition => Make_Op_Eq (Loc,
11505 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
11507 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
11509 Then_Statements => Delay_Case,
11510 Else_Statements => Accept_Case);
11512 Append (Cases, Stats);
11516 Append (End_Lab, Stats);
11518 -- Replace accept statement with appropriate block
11521 Make_Block_Statement (Loc,
11522 Declarations => Decls,
11523 Handled_Statement_Sequence =>
11524 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)));
11527 -- Note: have to worry more about abort deferral in above code ???
11529 -- Final step is to unstack the Accept_Address entries for all accept
11530 -- statements appearing in accept alternatives in the select statement
11532 Alt := First (Alts);
11533 while Present (Alt) loop
11534 if Nkind (Alt) = N_Accept_Alternative then
11535 Remove_Last_Elmt (Accept_Address
11536 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
11541 end Expand_N_Selective_Accept;
11543 -------------------------------------------
11544 -- Expand_N_Single_Protected_Declaration --
11545 -------------------------------------------
11547 -- A single protected declaration should never be present after semantic
11548 -- analysis because it is transformed into a protected type declaration
11549 -- and an accompanying anonymous object. This routine ensures that the
11550 -- transformation takes place.
11552 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is
11554 raise Program_Error;
11555 end Expand_N_Single_Protected_Declaration;
11557 --------------------------------------
11558 -- Expand_N_Single_Task_Declaration --
11559 --------------------------------------
11561 -- A single task declaration should never be present after semantic
11562 -- analysis because it is transformed into a task type declaration and
11563 -- an accompanying anonymous object. This routine ensures that the
11564 -- transformation takes place.
11566 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
11568 raise Program_Error;
11569 end Expand_N_Single_Task_Declaration;
11571 ------------------------
11572 -- Expand_N_Task_Body --
11573 ------------------------
11575 -- Given a task body
11577 -- task body tname is
11583 -- This expansion routine converts it into a procedure and sets the
11584 -- elaboration flag for the procedure to true, to represent the fact
11585 -- that the task body is now elaborated:
11587 -- procedure tnameB (_Task : access tnameV) is
11588 -- discriminal : dtype renames _Task.discriminant;
11590 -- procedure _clean is
11592 -- Abort_Defer.all;
11594 -- Abort_Undefer.all;
11599 -- Abort_Undefer.all;
11601 -- System.Task_Stages.Complete_Activation;
11609 -- In addition, if the task body is an activator, then a call to activate
11610 -- tasks is added at the start of the statements, before the call to
11611 -- Complete_Activation, and if in addition the task is a master then it
11612 -- must be established as a master. These calls are inserted and analyzed
11613 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11616 -- There is one discriminal declaration line generated for each
11617 -- discriminant that is present to provide an easy reference point for
11618 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11620 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11621 -- task body procedures have a profile (Arg : System.Address). That is
11622 -- needed because GNARLI has to use the same access-to-subprogram type
11623 -- for all task types. We depend here on knowing that in GNAT, passing
11624 -- an address argument by value is identical to passing a record value
11625 -- by access (in either case a single pointer is passed), so even though
11626 -- this procedure has the wrong profile. In fact it's all OK, since the
11627 -- callings sequence is identical.
11629 procedure Expand_N_Task_Body (N : Node_Id) is
11630 Loc : constant Source_Ptr := Sloc (N);
11631 Ttyp : constant Entity_Id := Corresponding_Spec (N);
11635 Insert_Nod : Node_Id;
11636 -- Used to determine the proper location of wrapper body insertions
11639 -- if no task body procedure, means we had an error in configurable
11640 -- run-time mode, and there is no point in proceeding further.
11642 if No (Task_Body_Procedure (Ttyp)) then
11646 -- Add renaming declarations for discriminals and a declaration for the
11647 -- entry family index (if applicable).
11649 Install_Private_Data_Declarations
11650 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N));
11652 -- Add a call to Abort_Undefer at the very beginning of the task
11653 -- body since this body is called with abort still deferred.
11655 if Abort_Allowed then
11656 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
11658 (First (Statements (Handled_Statement_Sequence (N))), Call);
11662 -- The statement part has already been protected with an at_end and
11663 -- cleanup actions. The call to Complete_Activation must be placed
11664 -- at the head of the sequence of statements of that block. The
11665 -- declarations have been merged in this sequence of statements but
11666 -- the first real statement is accessible from the First_Real_Statement
11667 -- field (which was set for exactly this purpose).
11669 if Restricted_Profile then
11670 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
11672 Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
11676 (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
11680 Make_Subprogram_Body (Loc,
11681 Specification => Build_Task_Proc_Specification (Ttyp),
11682 Declarations => Declarations (N),
11683 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
11684 Set_Is_Task_Body_Procedure (New_N);
11686 -- If the task contains generic instantiations, cleanup actions are
11687 -- delayed until after instantiation. Transfer the activation chain to
11688 -- the subprogram, to insure that the activation call is properly
11689 -- generated. It the task body contains inner tasks, indicate that the
11690 -- subprogram is a task master.
11692 if Delay_Cleanups (Ttyp) then
11693 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
11694 Set_Is_Task_Master (New_N, Is_Task_Master (N));
11697 Rewrite (N, New_N);
11700 -- Set elaboration flag immediately after task body. If the body is a
11701 -- subunit, the flag is set in the declarative part containing the stub.
11703 if Nkind (Parent (N)) /= N_Subunit then
11705 Make_Assignment_Statement (Loc,
11707 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
11708 Expression => New_Occurrence_Of (Standard_True, Loc)));
11711 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11712 -- the task body. At this point all wrapper specs have been created,
11713 -- frozen and included in the dispatch table for the task type.
11715 if Ada_Version >= Ada_2005 then
11716 if Nkind (Parent (N)) = N_Subunit then
11717 Insert_Nod := Corresponding_Stub (Parent (N));
11722 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
11724 end Expand_N_Task_Body;
11726 ------------------------------------
11727 -- Expand_N_Task_Type_Declaration --
11728 ------------------------------------
11730 -- We have several things to do. First we must create a Boolean flag used
11731 -- to mark if the body is elaborated yet. This variable gets set to True
11732 -- when the body of the task is elaborated (we can't rely on the normal
11733 -- ABE mechanism for the task body, since we need to pass an access to
11734 -- this elaboration boolean to the runtime routines).
11736 -- taskE : aliased Boolean := False;
11738 -- Next a variable is declared to hold the task stack size (either the
11739 -- default : Unspecified_Size, or a value that is set by a pragma
11740 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11741 -- the variable is initialized with this value:
11743 -- taskZ : Size_Type := Unspecified_Size;
11745 -- taskZ : Size_Type := Size_Type (size_expression);
11747 -- Note: No variable is needed to hold the task relative deadline since
11748 -- its value would never be static because the parameter is of a private
11749 -- type (Ada.Real_Time.Time_Span).
11751 -- Next we create a corresponding record type declaration used to represent
11752 -- values of this task. The general form of this type declaration is
11754 -- type taskV (discriminants) is record
11755 -- _Task_Id : Task_Id;
11756 -- entry_family : array (bounds) of Void;
11757 -- _Priority : Integer := priority_expression;
11758 -- _Size : Size_Type := size_expression;
11759 -- _Secondary_Stack_Size : Size_Type := size_expression;
11760 -- _Task_Info : Task_Info_Type := task_info_expression;
11761 -- _CPU : Integer := cpu_range_expression;
11762 -- _Relative_Deadline : Time_Span := time_span_expression;
11763 -- _Domain : Dispatching_Domain := dd_expression;
11766 -- The discriminants are present only if the corresponding task type has
11767 -- discriminants, and they exactly mirror the task type discriminants.
11769 -- The Id field is always present. It contains the Task_Id value, as set by
11770 -- the call to Create_Task. Note that although the task is limited, the
11771 -- task value record type is not limited, so there is no problem in passing
11772 -- this field as an out parameter to Create_Task.
11774 -- One entry_family component is present for each entry family in the task
11775 -- definition. The bounds correspond to the bounds of the entry family
11776 -- (which may depend on discriminants). The element type is void, since we
11777 -- only need the bounds information for determining the entry index. Note
11778 -- that the use of an anonymous array would normally be illegal in this
11779 -- context, but this is a parser check, and the semantics is quite prepared
11780 -- to handle such a case.
11782 -- The _Size field is present only if a Storage_Size pragma appears in the
11783 -- task definition. The expression captures the argument that was present
11784 -- in the pragma, and is used to override the task stack size otherwise
11785 -- associated with the task type.
11787 -- The _Secondary_Stack_Size field is present only the task entity has a
11788 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11789 -- when the record init proc is built, to capture the expression of the
11790 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11791 -- be filled here since aspect evaluations are delayed till the freeze
11794 -- The _Priority field is present only if the task entity has a Priority or
11795 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11796 -- definition clause). It will be filled at the freeze point, when the
11797 -- record init proc is built, to capture the expression of the rep item
11798 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11799 -- here since aspect evaluations are delayed till the freeze point.
11801 -- The _Task_Info field is present only if a Task_Info pragma appears in
11802 -- the task definition. The expression captures the argument that was
11803 -- present in the pragma, and is used to provide the Task_Image parameter
11804 -- to the call to Create_Task.
11806 -- The _CPU field is present only if the task entity has a CPU rep item
11807 -- (pragma, aspect specification or attribute definition clause). It will
11808 -- be filled at the freeze point, when the record init proc is built, to
11809 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11810 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11811 -- are delayed till the freeze point.
11813 -- The _Relative_Deadline field is present only if a Relative_Deadline
11814 -- pragma appears in the task definition. The expression captures the
11815 -- argument that was present in the pragma, and is used to provide the
11816 -- Relative_Deadline parameter to the call to Create_Task.
11818 -- The _Domain field is present only if the task entity has a
11819 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11820 -- definition clause). It will be filled at the freeze point, when the
11821 -- record init proc is built, to capture the expression of the rep item
11822 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11823 -- here since aspect evaluations are delayed till the freeze point.
11825 -- When a task is declared, an instance of the task value record is
11826 -- created. The elaboration of this declaration creates the correct bounds
11827 -- for the entry families, and also evaluates the size, priority, and
11828 -- task_Info expressions if needed. The initialization routine for the task
11829 -- type itself then calls Create_Task with appropriate parameters to
11830 -- initialize the value of the Task_Id field.
11832 -- Note: the address of this record is passed as the "Discriminants"
11833 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11834 -- body procedure, it does not matter that it does not quite match the
11835 -- GNARLI model of what is being passed (the record contains more than just
11836 -- the discriminants, but the discriminants can be found from the record
11839 -- The Entity_Id for this created record type is placed in the
11840 -- Corresponding_Record_Type field of the associated task type entity.
11842 -- Next we create a procedure specification for the task body procedure:
11844 -- procedure taskB (_Task : access taskV);
11846 -- Note that this must come after the record type declaration, since
11847 -- the spec refers to this type. It turns out that the initialization
11848 -- procedure for the value type references the task body spec, but that's
11849 -- fine, since it won't be generated till the freeze point for the type,
11850 -- which is certainly after the task body spec declaration.
11852 -- Finally, we set the task index value field of the entry attribute in
11853 -- the case of a simple entry.
11855 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
11856 Loc : constant Source_Ptr := Sloc (N);
11857 TaskId : constant Entity_Id := Defining_Identifier (N);
11858 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
11859 Tasknm : constant Name_Id := Chars (Tasktyp);
11860 Taskdef : constant Node_Id := Task_Definition (N);
11862 Body_Decl : Node_Id;
11864 Decl_Stack : Node_Id;
11866 Elab_Decl : Node_Id;
11867 Ent_Stack : Entity_Id;
11868 Proc_Spec : Node_Id;
11869 Rec_Decl : Node_Id;
11870 Rec_Ent : Entity_Id;
11871 Size_Decl : Entity_Id;
11872 Task_Size : Node_Id;
11874 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id;
11875 -- Searches the task definition T for the first occurrence of the pragma
11876 -- Relative Deadline. The caller has ensured that the pragma is present
11877 -- in the task definition. Note that this routine cannot be implemented
11878 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11879 -- not chained because their expansion into a procedure call statement
11880 -- would cause a break in the chain.
11882 ----------------------------------
11883 -- Get_Relative_Deadline_Pragma --
11884 ----------------------------------
11886 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is
11890 N := First (Visible_Declarations (T));
11891 while Present (N) loop
11892 if Nkind (N) = N_Pragma
11893 and then Pragma_Name (N) = Name_Relative_Deadline
11901 N := First (Private_Declarations (T));
11902 while Present (N) loop
11903 if Nkind (N) = N_Pragma
11904 and then Pragma_Name (N) = Name_Relative_Deadline
11912 raise Program_Error;
11913 end Get_Relative_Deadline_Pragma;
11915 -- Start of processing for Expand_N_Task_Type_Declaration
11918 -- If already expanded, nothing to do
11920 if Present (Corresponding_Record_Type (Tasktyp)) then
11924 -- Here we will do the expansion
11926 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
11928 Rec_Ent := Defining_Identifier (Rec_Decl);
11929 Cdecls := Component_Items (Component_List
11930 (Type_Definition (Rec_Decl)));
11932 Qualify_Entity_Names (N);
11934 -- First create the elaboration variable
11937 Make_Object_Declaration (Loc,
11938 Defining_Identifier =>
11939 Make_Defining_Identifier (Sloc (Tasktyp),
11940 Chars => New_External_Name (Tasknm, 'E')),
11941 Aliased_Present => True,
11942 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
11943 Expression => New_Occurrence_Of (Standard_False, Loc));
11945 Insert_After (N, Elab_Decl);
11947 -- Next create the declaration of the size variable (tasknmZ)
11949 Set_Storage_Size_Variable (Tasktyp,
11950 Make_Defining_Identifier (Sloc (Tasktyp),
11951 Chars => New_External_Name (Tasknm, 'Z')));
11953 if Present (Taskdef)
11954 and then Has_Storage_Size_Pragma (Taskdef)
11956 Is_OK_Static_Expression
11958 (First (Pragma_Argument_Associations
11959 (Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
11962 Make_Object_Declaration (Loc,
11963 Defining_Identifier => Storage_Size_Variable (Tasktyp),
11964 Object_Definition =>
11965 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
11967 Convert_To (RTE (RE_Size_Type),
11969 (Expression (First (Pragma_Argument_Associations
11971 (TaskId, Name_Storage_Size)))))));
11975 Make_Object_Declaration (Loc,
11976 Defining_Identifier => Storage_Size_Variable (Tasktyp),
11977 Object_Definition =>
11978 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
11980 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
11983 Insert_After (Elab_Decl, Size_Decl);
11985 -- Next build the rest of the corresponding record declaration. This is
11986 -- done last, since the corresponding record initialization procedure
11987 -- will reference the previously created entities.
11989 -- Fill in the component declarations -- first the _Task_Id field
11992 Make_Component_Declaration (Loc,
11993 Defining_Identifier =>
11994 Make_Defining_Identifier (Loc, Name_uTask_Id),
11995 Component_Definition =>
11996 Make_Component_Definition (Loc,
11997 Aliased_Present => False,
11998 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id),
12001 -- Declare static ATCB (that is, created by the expander) if we are
12002 -- using the Restricted run time.
12004 if Restricted_Profile then
12006 Make_Component_Declaration (Loc,
12007 Defining_Identifier =>
12008 Make_Defining_Identifier (Loc, Name_uATCB),
12010 Component_Definition =>
12011 Make_Component_Definition (Loc,
12012 Aliased_Present => True,
12013 Subtype_Indication => Make_Subtype_Indication (Loc,
12015 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc),
12018 Make_Index_Or_Discriminant_Constraint (Loc,
12020 New_List (Make_Integer_Literal (Loc, 0)))))));
12024 -- Declare static stack (that is, created by the expander) if we are
12025 -- using the Restricted run time on a bare board configuration.
12027 if Restricted_Profile and then Preallocated_Stacks_On_Target then
12029 -- First we need to extract the appropriate stack size
12031 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
12033 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12035 Expr_N : constant Node_Id :=
12036 Expression (First (
12037 Pragma_Argument_Associations (
12038 Get_Rep_Pragma (TaskId, Name_Storage_Size))));
12039 Etyp : constant Entity_Id := Etype (Expr_N);
12040 P : constant Node_Id := Parent (Expr_N);
12043 -- The stack is defined inside the corresponding record.
12044 -- Therefore if the size of the stack is set by means of
12045 -- a discriminant, we must reference the discriminant of the
12046 -- corresponding record type.
12048 if Nkind (Expr_N) in N_Has_Entity
12049 and then Present (Discriminal_Link (Entity (Expr_N)))
12053 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
12055 Set_Parent (Task_Size, P);
12056 Set_Etype (Task_Size, Etyp);
12057 Set_Analyzed (Task_Size);
12060 Task_Size := New_Copy_Tree (Expr_N);
12066 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc);
12069 Decl_Stack := Make_Component_Declaration (Loc,
12070 Defining_Identifier => Ent_Stack,
12072 Component_Definition =>
12073 Make_Component_Definition (Loc,
12074 Aliased_Present => True,
12075 Subtype_Indication => Make_Subtype_Indication (Loc,
12077 New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
12080 Make_Index_Or_Discriminant_Constraint (Loc,
12081 Constraints => New_List (Make_Range (Loc,
12082 Low_Bound => Make_Integer_Literal (Loc, 1),
12083 High_Bound => Convert_To (RTE (RE_Storage_Offset),
12086 Append_To (Cdecls, Decl_Stack);
12088 -- The appropriate alignment for the stack is ensured by the run-time
12089 -- code in charge of task creation.
12093 -- Declare a static secondary stack if the conditions for a statically
12094 -- generated stack are met.
12096 if Create_Secondary_Stack_For_Task (TaskId) then
12098 Size_Expr : constant Node_Id :=
12099 Expression (First (
12100 Pragma_Argument_Associations (
12101 Get_Rep_Pragma (TaskId,
12102 Name_Secondary_Stack_Size))));
12104 Stack_Size : Node_Id;
12107 -- The secondary stack is defined inside the corresponding
12108 -- record. Therefore if the size of the stack is set by means
12109 -- of a discriminant, we must reference the discriminant of the
12110 -- corresponding record type.
12112 if Nkind (Size_Expr) in N_Has_Entity
12113 and then Present (Discriminal_Link (Entity (Size_Expr)))
12117 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))),
12119 Set_Parent (Stack_Size, Parent (Size_Expr));
12120 Set_Etype (Stack_Size, Etype (Size_Expr));
12121 Set_Analyzed (Stack_Size);
12124 Stack_Size := New_Copy_Tree (Size_Expr);
12127 -- Create the secondary stack for the task
12130 Make_Component_Declaration (Loc,
12131 Defining_Identifier =>
12132 Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
12133 Component_Definition =>
12134 Make_Component_Definition (Loc,
12135 Aliased_Present => True,
12136 Subtype_Indication =>
12137 Make_Subtype_Indication (Loc,
12139 New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
12141 Make_Index_Or_Discriminant_Constraint (Loc,
12142 Constraints => New_List (
12143 Convert_To (RTE (RE_Size_Type),
12146 Append_To (Cdecls, Decl_SS);
12150 -- Add components for entry families
12152 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
12154 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12155 -- item is present.
12157 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then
12159 Make_Component_Declaration (Loc,
12160 Defining_Identifier =>
12161 Make_Defining_Identifier (Loc, Name_uPriority),
12162 Component_Definition =>
12163 Make_Component_Definition (Loc,
12164 Aliased_Present => False,
12165 Subtype_Indication =>
12166 New_Occurrence_Of (Standard_Integer, Loc))));
12169 -- Add the _Size component if a Storage_Size pragma is present
12171 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12173 Make_Component_Declaration (Loc,
12174 Defining_Identifier =>
12175 Make_Defining_Identifier (Loc, Name_uSize),
12177 Component_Definition =>
12178 Make_Component_Definition (Loc,
12179 Aliased_Present => False,
12180 Subtype_Indication =>
12181 New_Occurrence_Of (RTE (RE_Size_Type), Loc)),
12184 Convert_To (RTE (RE_Size_Type),
12186 Expression (First (
12187 Pragma_Argument_Associations (
12188 Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
12191 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
12192 -- pragma is present.
12195 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False)
12198 Make_Component_Declaration (Loc,
12199 Defining_Identifier =>
12200 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size),
12202 Component_Definition =>
12203 Make_Component_Definition (Loc,
12204 Aliased_Present => False,
12205 Subtype_Indication =>
12206 New_Occurrence_Of (RTE (RE_Size_Type), Loc))));
12209 -- Add the _Task_Info component if a Task_Info pragma is present
12211 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then
12213 Make_Component_Declaration (Loc,
12214 Defining_Identifier =>
12215 Make_Defining_Identifier (Loc, Name_uTask_Info),
12217 Component_Definition =>
12218 Make_Component_Definition (Loc,
12219 Aliased_Present => False,
12220 Subtype_Indication =>
12221 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)),
12223 Expression => New_Copy (
12224 Expression (First (
12225 Pragma_Argument_Associations (
12227 (TaskId, Name_Task_Info, Check_Parents => False)))))));
12230 -- Add the _CPU component if a CPU rep item is present
12232 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then
12234 Make_Component_Declaration (Loc,
12235 Defining_Identifier =>
12236 Make_Defining_Identifier (Loc, Name_uCPU),
12238 Component_Definition =>
12239 Make_Component_Definition (Loc,
12240 Aliased_Present => False,
12241 Subtype_Indication =>
12242 New_Occurrence_Of (RTE (RE_CPU_Range), Loc))));
12245 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12246 -- present. If we are using a restricted run time this component will
12247 -- not be added (deadlines are not allowed by the Ravenscar profile),
12248 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
12251 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E')
12252 and then Present (Taskdef)
12253 and then Has_Relative_Deadline_Pragma (Taskdef)
12256 Make_Component_Declaration (Loc,
12257 Defining_Identifier =>
12258 Make_Defining_Identifier (Loc, Name_uRelative_Deadline),
12260 Component_Definition =>
12261 Make_Component_Definition (Loc,
12262 Aliased_Present => False,
12263 Subtype_Indication =>
12264 New_Occurrence_Of (RTE (RE_Time_Span), Loc)),
12267 Convert_To (RTE (RE_Time_Span),
12269 Expression (First (
12270 Pragma_Argument_Associations (
12271 Get_Relative_Deadline_Pragma (Taskdef))))))));
12274 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12275 -- item is present. If we are using a restricted run time this component
12276 -- will not be added (dispatching domains are not allowed by the
12277 -- Ravenscar profile).
12279 if not Restricted_Profile
12282 (TaskId, Name_Dispatching_Domain, Check_Parents => False)
12285 Make_Component_Declaration (Loc,
12286 Defining_Identifier =>
12287 Make_Defining_Identifier (Loc, Name_uDispatching_Domain),
12289 Component_Definition =>
12290 Make_Component_Definition (Loc,
12291 Aliased_Present => False,
12292 Subtype_Indication =>
12294 (RTE (RE_Dispatching_Domain_Access), Loc))));
12297 Insert_After (Size_Decl, Rec_Decl);
12299 -- Analyze the record declaration immediately after construction,
12300 -- because the initialization procedure is needed for single task
12301 -- declarations before the next entity is analyzed.
12303 Analyze (Rec_Decl);
12305 -- Create the declaration of the task body procedure
12307 Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
12309 Make_Subprogram_Declaration (Loc,
12310 Specification => Proc_Spec);
12311 Set_Is_Task_Body_Procedure (Body_Decl);
12313 Insert_After (Rec_Decl, Body_Decl);
12315 -- The subprogram does not comes from source, so we have to indicate the
12316 -- need for debugging information explicitly.
12318 if Comes_From_Source (Original_Node (N)) then
12319 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec));
12322 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12323 -- the corresponding record has been frozen.
12325 if Ada_Version >= Ada_2005 then
12326 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
12329 -- Ada 2005 (AI-345): We must defer freezing to allow further
12330 -- declaration of primitive subprograms covering task interfaces
12332 if Ada_Version <= Ada_95 then
12334 -- Now we can freeze the corresponding record. This needs manually
12335 -- freezing, since it is really part of the task type, and the task
12336 -- type is frozen at this stage. We of course need the initialization
12337 -- procedure for this corresponding record type and we won't get it
12338 -- in time if we don't freeze now.
12341 L : constant List_Id := Freeze_Entity (Rec_Ent, N);
12343 if Is_Non_Empty_List (L) then
12344 Insert_List_After (Body_Decl, L);
12349 -- Complete the expansion of access types to the current task type, if
12350 -- any were declared.
12352 Expand_Previous_Access_Type (Tasktyp);
12354 -- Create wrappers for entries that have contract cases, preconditions
12355 -- and postconditions.
12361 Ent := First_Entity (Tasktyp);
12362 while Present (Ent) loop
12363 if Ekind_In (Ent, E_Entry, E_Entry_Family) then
12364 Build_Contract_Wrapper (Ent, N);
12370 end Expand_N_Task_Type_Declaration;
12372 -------------------------------
12373 -- Expand_N_Timed_Entry_Call --
12374 -------------------------------
12376 -- A timed entry call in normal case is not implemented using ATC mechanism
12377 -- anymore for efficiency reason.
12387 -- is expanded as follows:
12389 -- 1) When T.E is a task entry_call;
12393 -- X : Task_Entry_Index := <entry index>;
12394 -- DX : Duration := To_Duration (D);
12395 -- M : Delay_Mode := <discriminant>;
12396 -- P : parms := (parm, parm, parm);
12399 -- Timed_Protected_Entry_Call
12400 -- (<acceptor-task>, X, P'Address, DX, M, B);
12408 -- 2) When T.E is a protected entry_call;
12412 -- X : Protected_Entry_Index := <entry index>;
12413 -- DX : Duration := To_Duration (D);
12414 -- M : Delay_Mode := <discriminant>;
12415 -- P : parms := (parm, parm, parm);
12418 -- Timed_Protected_Entry_Call
12419 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12427 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12428 -- is no delay and the triggering statements are executed. We first
12429 -- determine the kind of the triggering call and then execute a
12430 -- synchronized operation or a direct call.
12433 -- B : Boolean := False;
12434 -- C : Ada.Tags.Prim_Op_Kind;
12435 -- DX : Duration := To_Duration (D)
12436 -- K : Ada.Tags.Tagged_Kind :=
12437 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12438 -- M : Integer :=...;
12439 -- P : Parameters := (Param1 .. ParamN);
12443 -- if K = Ada.Tags.TK_Limited_Tagged
12444 -- or else K = Ada.Tags.TK_Tagged
12446 -- <dispatching-call>;
12451 -- Ada.Tags.Get_Offset_Index
12452 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12454 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12456 -- if C = POK_Protected_Entry
12457 -- or else C = POK_Task_Entry
12459 -- Param1 := P.Param1;
12461 -- ParamN := P.ParamN;
12465 -- if C = POK_Procedure
12466 -- or else C = POK_Protected_Procedure
12467 -- or else C = POK_Task_Procedure
12469 -- <dispatching-call>;
12475 -- <triggering-statements>
12477 -- <timed-statements>
12481 -- The triggering statement and the sequence of timed statements have not
12482 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12483 -- global references if within an instantiation.
12485 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
12486 Loc : constant Source_Ptr := Sloc (N);
12489 Blk_Typ : Entity_Id;
12491 Call_Ent : Entity_Id;
12492 Conc_Typ_Stmts : List_Id;
12493 Concval : Node_Id := Empty; -- init to avoid warning
12494 D_Alt : constant Node_Id := Delay_Alternative (N);
12497 D_Stat : Node_Id := Delay_Statement (D_Alt);
12499 D_Type : Entity_Id;
12502 E_Alt : constant Node_Id := Entry_Call_Alternative (N);
12503 E_Call : Node_Id := Entry_Call_Statement (E_Alt);
12508 Is_Disp_Select : Boolean;
12509 Lim_Typ_Stmts : List_Id;
12518 B : Entity_Id; -- Call status flag
12519 C : Entity_Id; -- Call kind
12520 D : Entity_Id; -- Delay
12521 K : Entity_Id; -- Tagged kind
12522 M : Entity_Id; -- Delay mode
12523 P : Entity_Id; -- Parameter block
12524 S : Entity_Id; -- Primitive operation slot
12526 -- Start of processing for Expand_N_Timed_Entry_Call
12529 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12530 -- was already reported on spec, so do not attempt to expand the call.
12532 if Restriction_Active (No_Select_Statements) then
12536 Process_Statements_For_Controlled_Objects (E_Alt);
12537 Process_Statements_For_Controlled_Objects (D_Alt);
12539 Ensure_Statement_Present (Sloc (D_Stat), D_Alt);
12541 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12542 -- may wrap them in blocks.
12544 E_Stats := Statements (E_Alt);
12545 D_Stats := Statements (D_Alt);
12547 -- The arguments in the call may require dynamic allocation, and the
12548 -- call statement may have been transformed into a block. The block
12549 -- may contain additional declarations for internal entities, and the
12550 -- original call is found by sequential search.
12552 if Nkind (E_Call) = N_Block_Statement then
12553 E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
12554 while not Nkind_In (E_Call, N_Procedure_Call_Statement,
12555 N_Entry_Call_Statement)
12562 Ada_Version >= Ada_2005
12563 and then Nkind (E_Call) = N_Procedure_Call_Statement;
12565 if Is_Disp_Select then
12566 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
12572 -- B : Boolean := False;
12574 B := Build_B (Loc, Decls);
12577 -- C : Ada.Tags.Prim_Op_Kind;
12579 C := Build_C (Loc, Decls);
12581 -- Because the analysis of all statements was disabled, manually
12582 -- analyze the delay statement.
12585 D_Stat := Original_Node (D_Stat);
12588 -- Build an entry call using Simple_Entry_Call
12590 Extract_Entry (E_Call, Concval, Ename, Index);
12591 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
12593 Decls := Declarations (E_Call);
12594 Stmts := Statements (Handled_Statement_Sequence (E_Call));
12603 B := Make_Defining_Identifier (Loc, Name_uB);
12606 Make_Object_Declaration (Loc,
12607 Defining_Identifier => B,
12608 Object_Definition =>
12609 New_Occurrence_Of (Standard_Boolean, Loc)));
12612 -- Duration and mode processing
12614 D_Type := Base_Type (Etype (Expression (D_Stat)));
12616 -- Use the type of the delay expression (Calendar or Real_Time) to
12617 -- generate the appropriate conversion.
12619 if Nkind (D_Stat) = N_Delay_Relative_Statement then
12620 D_Disc := Make_Integer_Literal (Loc, 0);
12621 D_Conv := Relocate_Node (Expression (D_Stat));
12623 elsif Is_RTE (D_Type, RO_CA_Time) then
12624 D_Disc := Make_Integer_Literal (Loc, 1);
12626 Make_Function_Call (Loc,
12627 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
12628 Parameter_Associations =>
12629 New_List (New_Copy (Expression (D_Stat))));
12631 else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
12632 D_Disc := Make_Integer_Literal (Loc, 2);
12634 Make_Function_Call (Loc,
12635 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
12636 Parameter_Associations =>
12637 New_List (New_Copy (Expression (D_Stat))));
12640 D := Make_Temporary (Loc, 'D');
12646 Make_Object_Declaration (Loc,
12647 Defining_Identifier => D,
12648 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc)));
12650 M := Make_Temporary (Loc, 'M');
12653 -- M : Integer := (0 | 1 | 2);
12656 Make_Object_Declaration (Loc,
12657 Defining_Identifier => M,
12658 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
12659 Expression => D_Disc));
12661 -- Do the assignment at this stage only because the evaluation of the
12662 -- expression must not occur earlier (see ACVC C97302A).
12665 Make_Assignment_Statement (Loc,
12666 Name => New_Occurrence_Of (D, Loc),
12667 Expression => D_Conv));
12669 -- Parameter block processing
12671 -- Manually create the parameter block for dispatching calls. In the
12672 -- case of entries, the block has already been created during the call
12673 -- to Build_Simple_Entry_Call.
12675 if Is_Disp_Select then
12677 -- Tagged kind processing, generate:
12678 -- K : Ada.Tags.Tagged_Kind :=
12679 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12681 K := Build_K (Loc, Decls, Obj);
12683 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
12685 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
12687 -- Dispatch table slot processing, generate:
12690 S := Build_S (Loc, Decls);
12693 -- S := Ada.Tags.Get_Offset_Index
12694 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12697 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
12700 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12702 -- where Obj is the controlling formal parameter, S is the dispatch
12703 -- table slot number of the dispatching operation, P is the wrapped
12704 -- parameter block, D is the duration, M is the duration mode, C is
12705 -- the call kind and B is the call status.
12707 Params := New_List;
12709 Append_To (Params, New_Copy_Tree (Obj));
12710 Append_To (Params, New_Occurrence_Of (S, Loc));
12712 Make_Attribute_Reference (Loc,
12713 Prefix => New_Occurrence_Of (P, Loc),
12714 Attribute_Name => Name_Address));
12715 Append_To (Params, New_Occurrence_Of (D, Loc));
12716 Append_To (Params, New_Occurrence_Of (M, Loc));
12717 Append_To (Params, New_Occurrence_Of (C, Loc));
12718 Append_To (Params, New_Occurrence_Of (B, Loc));
12720 Append_To (Conc_Typ_Stmts,
12721 Make_Procedure_Call_Statement (Loc,
12725 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc),
12726 Parameter_Associations => Params));
12729 -- if C = POK_Protected_Entry
12730 -- or else C = POK_Task_Entry
12732 -- Param1 := P.Param1;
12734 -- ParamN := P.ParamN;
12737 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
12739 -- Generate the if statement only when the packed parameters need
12740 -- explicit assignments to their corresponding actuals.
12742 if Present (Unpack) then
12743 Append_To (Conc_Typ_Stmts,
12744 Make_Implicit_If_Statement (N,
12750 Left_Opnd => New_Occurrence_Of (C, Loc),
12753 (RTE (RE_POK_Protected_Entry), Loc)),
12757 Left_Opnd => New_Occurrence_Of (C, Loc),
12759 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
12761 Then_Statements => Unpack));
12767 -- if C = POK_Procedure
12768 -- or else C = POK_Protected_Procedure
12769 -- or else C = POK_Task_Procedure
12771 -- <dispatching-call>
12775 N_Stats := New_List (
12776 Make_Implicit_If_Statement (N,
12781 Left_Opnd => New_Occurrence_Of (C, Loc),
12783 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
12789 Left_Opnd => New_Occurrence_Of (C, Loc),
12791 New_Occurrence_Of (RTE (
12792 RE_POK_Protected_Procedure), Loc)),
12795 Left_Opnd => New_Occurrence_Of (C, Loc),
12798 (RTE (RE_POK_Task_Procedure), Loc)))),
12800 Then_Statements => New_List (E_Call)));
12802 Append_To (Conc_Typ_Stmts,
12803 Make_Implicit_If_Statement (N,
12804 Condition => New_Occurrence_Of (B, Loc),
12805 Then_Statements => N_Stats));
12808 -- <dispatching-call>;
12812 New_List (New_Copy_Tree (E_Call),
12813 Make_Assignment_Statement (Loc,
12814 Name => New_Occurrence_Of (B, Loc),
12815 Expression => New_Occurrence_Of (Standard_True, Loc)));
12818 -- if K = Ada.Tags.TK_Limited_Tagged
12819 -- or else K = Ada.Tags.TK_Tagged
12827 Make_Implicit_If_Statement (N,
12828 Condition => Build_Dispatching_Tag_Check (K, N),
12829 Then_Statements => Lim_Typ_Stmts,
12830 Else_Statements => Conc_Typ_Stmts));
12835 -- <triggering-statements>
12837 -- <timed-statements>
12841 Make_Implicit_If_Statement (N,
12842 Condition => New_Occurrence_Of (B, Loc),
12843 Then_Statements => E_Stats,
12844 Else_Statements => D_Stats));
12847 -- Simple case of a nondispatching trigger. Skip assignments to
12848 -- temporaries created for in-out parameters.
12850 -- This makes unwarranted assumptions about the shape of the expanded
12851 -- tree for the call, and should be cleaned up ???
12853 Stmt := First (Stmts);
12854 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
12858 -- Do the assignment at this stage only because the evaluation
12859 -- of the expression must not occur earlier (see ACVC C97302A).
12861 Insert_Before (Stmt,
12862 Make_Assignment_Statement (Loc,
12863 Name => New_Occurrence_Of (D, Loc),
12864 Expression => D_Conv));
12867 Params := Parameter_Associations (Call);
12869 -- For a protected type, we build a Timed_Protected_Entry_Call
12871 if Is_Protected_Type (Etype (Concval)) then
12873 -- Create a new call statement
12875 Param := First (Params);
12876 while Present (Param)
12877 and then not Is_RTE (Etype (Param), RE_Call_Modes)
12882 Dummy := Remove_Next (Next (Param));
12884 -- Remove garbage is following the Cancel_Param if present
12886 Dummy := Next (Param);
12888 -- Remove the mode of the Protected_Entry_Call call, then remove
12889 -- the Communication_Block of the Protected_Entry_Call call, and
12890 -- finally add Duration and a Delay_Mode parameter
12892 pragma Assert (Present (Param));
12893 Rewrite (Param, New_Occurrence_Of (D, Loc));
12895 Rewrite (Dummy, New_Occurrence_Of (M, Loc));
12897 -- Add a Boolean flag for successful entry call
12899 Append_To (Params, New_Occurrence_Of (B, Loc));
12901 case Corresponding_Runtime_Package (Etype (Concval)) is
12902 when System_Tasking_Protected_Objects_Entries =>
12904 Make_Procedure_Call_Statement (Loc,
12907 (RTE (RE_Timed_Protected_Entry_Call), Loc),
12908 Parameter_Associations => Params));
12911 raise Program_Error;
12914 -- For the task case, build a Timed_Task_Entry_Call
12917 -- Create a new call statement
12919 Append_To (Params, New_Occurrence_Of (D, Loc));
12920 Append_To (Params, New_Occurrence_Of (M, Loc));
12921 Append_To (Params, New_Occurrence_Of (B, Loc));
12924 Make_Procedure_Call_Statement (Loc,
12926 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
12927 Parameter_Associations => Params));
12931 Make_Implicit_If_Statement (N,
12932 Condition => New_Occurrence_Of (B, Loc),
12933 Then_Statements => E_Stats,
12934 Else_Statements => D_Stats));
12938 Make_Block_Statement (Loc,
12939 Declarations => Decls,
12940 Handled_Statement_Sequence =>
12941 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
12945 -- Some items in Decls used to be in the N_Block in E_Call that
12946 -- is constructed in Expand_Entry_Call, and are now in the new
12947 -- Block into which N has been rewritten. Adjust their scopes
12948 -- to reflect that.
12950 if Nkind (E_Call) = N_Block_Statement then
12951 Obj := First_Entity (Entity (Identifier (E_Call)));
12952 while Present (Obj) loop
12953 Set_Scope (Obj, Entity (Identifier (N)));
12958 Reset_Scopes_To (N, Entity (Identifier (N)));
12959 end Expand_N_Timed_Entry_Call;
12961 ----------------------------------------
12962 -- Expand_Protected_Body_Declarations --
12963 ----------------------------------------
12965 procedure Expand_Protected_Body_Declarations
12967 Spec_Id : Entity_Id)
12970 if No_Run_Time_Mode then
12971 Error_Msg_CRT ("protected body", N);
12974 elsif Expander_Active then
12976 -- Associate discriminals with the first subprogram or entry body to
12979 if Present (First_Protected_Operation (Declarations (N))) then
12980 Set_Discriminals (Parent (Spec_Id));
12983 end Expand_Protected_Body_Declarations;
12985 -------------------------
12986 -- External_Subprogram --
12987 -------------------------
12989 function External_Subprogram (E : Entity_Id) return Entity_Id is
12990 Subp : constant Entity_Id := Protected_Body_Subprogram (E);
12993 -- The internal and external subprograms follow each other on the entity
12994 -- chain. Note that previously private operations had no separate
12995 -- external subprogram. We now create one in all cases, because a
12996 -- private operation may actually appear in an external call, through
12997 -- a 'Access reference used for a callback.
12999 -- If the operation is a function that returns an anonymous access type,
13000 -- the corresponding itype appears before the operation, and must be
13003 -- This mechanism is fragile, there should be a real link between the
13004 -- two versions of the operation, but there is no place to put it ???
13006 if Is_Access_Type (Next_Entity (Subp)) then
13007 return Next_Entity (Next_Entity (Subp));
13009 return Next_Entity (Subp);
13011 end External_Subprogram;
13013 ------------------------------
13014 -- Extract_Dispatching_Call --
13015 ------------------------------
13017 procedure Extract_Dispatching_Call
13019 Call_Ent : out Entity_Id;
13020 Object : out Entity_Id;
13021 Actuals : out List_Id;
13022 Formals : out List_Id)
13024 Call_Nam : Node_Id;
13027 pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
13029 if Present (Original_Node (N)) then
13030 Call_Nam := Name (Original_Node (N));
13032 Call_Nam := Name (N);
13035 -- Retrieve the name of the dispatching procedure. It contains the
13036 -- dispatch table slot number.
13039 case Nkind (Call_Nam) is
13040 when N_Identifier =>
13043 when N_Selected_Component =>
13044 Call_Nam := Selector_Name (Call_Nam);
13047 raise Program_Error;
13051 Actuals := Parameter_Associations (N);
13052 Call_Ent := Entity (Call_Nam);
13053 Formals := Parameter_Specifications (Parent (Call_Ent));
13054 Object := First (Actuals);
13056 if Present (Original_Node (Object)) then
13057 Object := Original_Node (Object);
13060 -- If the type of the dispatching object is an access type then return
13061 -- an explicit dereference of a copy of the object, and note that this
13062 -- is the controlling actual of the call.
13064 if Is_Access_Type (Etype (Object)) then
13066 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object));
13068 Set_Is_Controlling_Actual (Object);
13070 end Extract_Dispatching_Call;
13072 -------------------
13073 -- Extract_Entry --
13074 -------------------
13076 procedure Extract_Entry
13078 Concval : out Node_Id;
13079 Ename : out Node_Id;
13080 Index : out Node_Id)
13082 Nam : constant Node_Id := Name (N);
13085 -- For a simple entry, the name is a selected component, with the
13086 -- prefix being the task value, and the selector being the entry.
13088 if Nkind (Nam) = N_Selected_Component then
13089 Concval := Prefix (Nam);
13090 Ename := Selector_Name (Nam);
13093 -- For a member of an entry family, the name is an indexed component
13094 -- where the prefix is a selected component, whose prefix in turn is
13095 -- the task value, and whose selector is the entry family. The single
13096 -- expression in the expressions list of the indexed component is the
13097 -- subscript for the family.
13099 else pragma Assert (Nkind (Nam) = N_Indexed_Component);
13100 Concval := Prefix (Prefix (Nam));
13101 Ename := Selector_Name (Prefix (Nam));
13102 Index := First (Expressions (Nam));
13105 -- Through indirection, the type may actually be a limited view of a
13106 -- concurrent type. When compiling a call, the non-limited view of the
13107 -- type is visible.
13109 if From_Limited_With (Etype (Concval)) then
13110 Set_Etype (Concval, Non_Limited_View (Etype (Concval)));
13114 -------------------
13115 -- Family_Offset --
13116 -------------------
13118 function Family_Offset
13123 Cap : Boolean) return Node_Id
13129 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
13130 -- If one of the bounds is a reference to a discriminant, replace with
13131 -- corresponding discriminal of type. Within the body of a task retrieve
13132 -- the renamed discriminant by simple visibility, using its generated
13133 -- name. Within a protected object, find the original discriminant and
13134 -- replace it with the discriminal of the current protected operation.
13136 ------------------------------
13137 -- Convert_Discriminant_Ref --
13138 ------------------------------
13140 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
13141 Loc : constant Source_Ptr := Sloc (Bound);
13146 if Is_Entity_Name (Bound)
13147 and then Ekind (Entity (Bound)) = E_Discriminant
13149 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then
13150 B := Make_Identifier (Loc, Chars (Entity (Bound)));
13151 Find_Direct_Name (B);
13153 elsif Is_Protected_Type (Ttyp) then
13154 D := First_Discriminant (Ttyp);
13155 while Chars (D) /= Chars (Entity (Bound)) loop
13156 Next_Discriminant (D);
13159 B := New_Occurrence_Of (Discriminal (D), Loc);
13162 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
13165 elsif Nkind (Bound) = N_Attribute_Reference then
13169 B := New_Copy_Tree (Bound);
13173 Make_Attribute_Reference (Loc,
13174 Attribute_Name => Name_Pos,
13175 Prefix => New_Occurrence_Of (Etype (Bound), Loc),
13176 Expressions => New_List (B));
13177 end Convert_Discriminant_Ref;
13179 -- Start of processing for Family_Offset
13182 Real_Hi := Convert_Discriminant_Ref (Hi);
13183 Real_Lo := Convert_Discriminant_Ref (Lo);
13186 if Is_Task_Type (Ttyp) then
13187 Ityp := RTE (RE_Task_Entry_Index);
13189 Ityp := RTE (RE_Protected_Entry_Index);
13193 Make_Attribute_Reference (Loc,
13194 Prefix => New_Occurrence_Of (Ityp, Loc),
13195 Attribute_Name => Name_Min,
13196 Expressions => New_List (
13198 Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
13201 Make_Attribute_Reference (Loc,
13202 Prefix => New_Occurrence_Of (Ityp, Loc),
13203 Attribute_Name => Name_Max,
13204 Expressions => New_List (
13206 Make_Integer_Literal (Loc, -Entry_Family_Bound)));
13209 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
13216 function Family_Size
13221 Cap : Boolean) return Node_Id
13226 if Is_Task_Type (Ttyp) then
13227 Ityp := RTE (RE_Task_Entry_Index);
13229 Ityp := RTE (RE_Protected_Entry_Index);
13233 Make_Attribute_Reference (Loc,
13234 Prefix => New_Occurrence_Of (Ityp, Loc),
13235 Attribute_Name => Name_Max,
13236 Expressions => New_List (
13238 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
13239 Right_Opnd => Make_Integer_Literal (Loc, 1)),
13240 Make_Integer_Literal (Loc, 0)));
13243 ----------------------------
13244 -- Find_Enclosing_Context --
13245 ----------------------------
13247 procedure Find_Enclosing_Context
13249 Context : out Node_Id;
13250 Context_Id : out Entity_Id;
13251 Context_Decls : out List_Id)
13254 -- Traverse the parent chain looking for an enclosing body, block,
13255 -- package or return statement.
13257 Context := Parent (N);
13258 while Present (Context) loop
13259 if Nkind_In (Context, N_Entry_Body,
13260 N_Extended_Return_Statement,
13262 N_Package_Declaration,
13268 -- Do not consider block created to protect a list of statements with
13269 -- an Abort_Defer / Abort_Undefer_Direct pair.
13271 elsif Nkind (Context) = N_Block_Statement
13272 and then not Is_Abort_Block (Context)
13277 Context := Parent (Context);
13280 pragma Assert (Present (Context));
13282 -- Extract the constituents of the context
13284 if Nkind (Context) = N_Extended_Return_Statement then
13285 Context_Decls := Return_Object_Declarations (Context);
13286 Context_Id := Return_Statement_Entity (Context);
13288 -- Package declarations and bodies use a common library-level activation
13289 -- chain or task master, therefore return the package declaration as the
13290 -- proper carrier for the appropriate flag.
13292 elsif Nkind (Context) = N_Package_Body then
13293 Context_Decls := Declarations (Context);
13294 Context_Id := Corresponding_Spec (Context);
13295 Context := Parent (Context_Id);
13297 if Nkind (Context) = N_Defining_Program_Unit_Name then
13298 Context := Parent (Parent (Context));
13300 Context := Parent (Context);
13303 elsif Nkind (Context) = N_Package_Declaration then
13304 Context_Decls := Visible_Declarations (Specification (Context));
13305 Context_Id := Defining_Unit_Name (Specification (Context));
13307 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13308 Context_Id := Defining_Identifier (Context_Id);
13312 if Nkind (Context) = N_Block_Statement then
13313 Context_Id := Entity (Identifier (Context));
13315 elsif Nkind (Context) = N_Entry_Body then
13316 Context_Id := Defining_Identifier (Context);
13318 elsif Nkind (Context) = N_Subprogram_Body then
13319 if Present (Corresponding_Spec (Context)) then
13320 Context_Id := Corresponding_Spec (Context);
13322 Context_Id := Defining_Unit_Name (Specification (Context));
13324 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13325 Context_Id := Defining_Identifier (Context_Id);
13329 elsif Nkind (Context) = N_Task_Body then
13330 Context_Id := Corresponding_Spec (Context);
13333 raise Program_Error;
13336 Context_Decls := Declarations (Context);
13339 pragma Assert (Present (Context_Id));
13340 pragma Assert (Present (Context_Decls));
13341 end Find_Enclosing_Context;
13343 -----------------------
13344 -- Find_Master_Scope --
13345 -----------------------
13347 function Find_Master_Scope (E : Entity_Id) return Entity_Id is
13351 -- In Ada 2005, the master is the innermost enclosing scope that is not
13352 -- transient. If the enclosing block is the rewriting of a call or the
13353 -- scope is an extended return statement this is valid master. The
13354 -- master in an extended return is only used within the return, and is
13355 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13356 -- now before that overwriting occurs.
13360 if Ada_Version >= Ada_2005 then
13361 while Is_Internal (S) loop
13362 if Nkind (Parent (S)) = N_Block_Statement
13364 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
13368 elsif Ekind (S) = E_Return_Statement then
13378 end Find_Master_Scope;
13380 -------------------------------
13381 -- First_Protected_Operation --
13382 -------------------------------
13384 function First_Protected_Operation (D : List_Id) return Node_Id is
13385 First_Op : Node_Id;
13388 First_Op := First (D);
13389 while Present (First_Op)
13390 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body)
13396 end First_Protected_Operation;
13398 ---------------------------------------
13399 -- Install_Private_Data_Declarations --
13400 ---------------------------------------
13402 procedure Install_Private_Data_Declarations
13404 Spec_Id : Entity_Id;
13405 Conc_Typ : Entity_Id;
13406 Body_Nod : Node_Id;
13408 Barrier : Boolean := False;
13409 Family : Boolean := False)
13411 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ);
13414 Insert_Node : Node_Id := Empty;
13415 Obj_Ent : Entity_Id;
13417 procedure Add (Decl : Node_Id);
13418 -- Add a single declaration after Insert_Node. If this is the first
13419 -- addition, Decl is added to the front of Decls and it becomes the
13422 function Replace_Bound (Bound : Node_Id) return Node_Id;
13423 -- The bounds of an entry index may depend on discriminants, create a
13424 -- reference to the corresponding prival. Otherwise return a duplicate
13425 -- of the original bound.
13431 procedure Add (Decl : Node_Id) is
13433 if No (Insert_Node) then
13434 Prepend_To (Decls, Decl);
13436 Insert_After (Insert_Node, Decl);
13439 Insert_Node := Decl;
13442 -------------------
13443 -- Replace_Bound --
13444 -------------------
13446 function Replace_Bound (Bound : Node_Id) return Node_Id is
13448 if Nkind (Bound) = N_Identifier
13449 and then Is_Discriminal (Entity (Bound))
13451 return Make_Identifier (Loc, Chars (Entity (Bound)));
13453 return Duplicate_Subexpr (Bound);
13457 -- Start of processing for Install_Private_Data_Declarations
13460 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13461 -- formal parameter _O, _object or _task depending on the context.
13463 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ);
13465 -- Special processing of _O for barrier functions, protected entries
13472 (Ekind (Spec_Id) = E_Entry
13473 or else Ekind (Spec_Id) = E_Entry_Family))
13476 Conc_Rec : constant Entity_Id :=
13477 Corresponding_Record_Type (Conc_Typ);
13478 Typ_Id : constant Entity_Id :=
13479 Make_Defining_Identifier (Loc,
13480 New_External_Name (Chars (Conc_Rec), 'P'));
13483 -- type prot_typVP is access prot_typV;
13486 Make_Full_Type_Declaration (Loc,
13487 Defining_Identifier => Typ_Id,
13489 Make_Access_To_Object_Definition (Loc,
13490 Subtype_Indication =>
13491 New_Occurrence_Of (Conc_Rec, Loc)));
13495 -- _object : prot_typVP := prot_typV (_O);
13498 Make_Object_Declaration (Loc,
13499 Defining_Identifier =>
13500 Make_Defining_Identifier (Loc, Name_uObject),
13501 Object_Definition => New_Occurrence_Of (Typ_Id, Loc),
13503 Unchecked_Convert_To (Typ_Id,
13504 New_Occurrence_Of (Obj_Ent, Loc)));
13507 -- Set the reference to the concurrent object
13509 Obj_Ent := Defining_Identifier (Decl);
13513 -- Step 2: Create the Protection object and build its declaration for
13514 -- any protected entry (family) of subprogram. Note for the lock-free
13515 -- implementation, the Protection object is not needed anymore.
13517 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then
13519 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
13523 Set_Protection_Object (Spec_Id, Prot_Ent);
13525 -- Determine the proper protection type
13527 if Has_Attach_Handler (Conc_Typ)
13528 and then not Restricted_Profile
13530 Prot_Typ := RE_Static_Interrupt_Protection;
13532 elsif Has_Interrupt_Handler (Conc_Typ)
13533 and then not Restriction_Active (No_Dynamic_Attachment)
13535 Prot_Typ := RE_Dynamic_Interrupt_Protection;
13538 case Corresponding_Runtime_Package (Conc_Typ) is
13539 when System_Tasking_Protected_Objects_Entries =>
13540 Prot_Typ := RE_Protection_Entries;
13542 when System_Tasking_Protected_Objects_Single_Entry =>
13543 Prot_Typ := RE_Protection_Entry;
13545 when System_Tasking_Protected_Objects =>
13546 Prot_Typ := RE_Protection;
13549 raise Program_Error;
13554 -- conc_typR : protection_typ renames _object._object;
13557 Make_Object_Renaming_Declaration (Loc,
13558 Defining_Identifier => Prot_Ent,
13560 New_Occurrence_Of (RTE (Prot_Typ), Loc),
13562 Make_Selected_Component (Loc,
13563 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13564 Selector_Name => Make_Identifier (Loc, Name_uObject)));
13569 -- Step 3: Add discriminant renamings (if any)
13571 if Has_Discriminants (Conc_Typ) then
13576 D := First_Discriminant (Conc_Typ);
13577 while Present (D) loop
13579 -- Adjust the source location
13581 Set_Sloc (Discriminal (D), Loc);
13584 -- discr_name : discr_typ renames _object.discr_name;
13586 -- discr_name : discr_typ renames _task.discr_name;
13589 Make_Object_Renaming_Declaration (Loc,
13590 Defining_Identifier => Discriminal (D),
13591 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
13593 Make_Selected_Component (Loc,
13594 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13595 Selector_Name => Make_Identifier (Loc, Chars (D))));
13598 -- Set debug info needed on this renaming declaration even
13599 -- though it does not come from source, so that the debugger
13600 -- will get the right information for these generated names.
13602 Set_Debug_Info_Needed (Discriminal (D));
13604 Next_Discriminant (D);
13609 -- Step 4: Add private component renamings (if any)
13611 if Is_Protected then
13612 Def := Protected_Definition (Parent (Conc_Typ));
13614 if Present (Private_Declarations (Def)) then
13617 Comp_Id : Entity_Id;
13618 Decl_Id : Entity_Id;
13621 Comp := First (Private_Declarations (Def));
13622 while Present (Comp) loop
13623 if Nkind (Comp) = N_Component_Declaration then
13624 Comp_Id := Defining_Identifier (Comp);
13626 Make_Defining_Identifier (Loc, Chars (Comp_Id));
13628 -- Minimal decoration
13630 if Ekind (Spec_Id) = E_Function then
13631 Set_Ekind (Decl_Id, E_Constant);
13633 Set_Ekind (Decl_Id, E_Variable);
13636 Set_Prival (Comp_Id, Decl_Id);
13637 Set_Prival_Link (Decl_Id, Comp_Id);
13638 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
13641 -- comp_name : comp_typ renames _object.comp_name;
13644 Make_Object_Renaming_Declaration (Loc,
13645 Defining_Identifier => Decl_Id,
13647 New_Occurrence_Of (Etype (Comp_Id), Loc),
13649 Make_Selected_Component (Loc,
13651 New_Occurrence_Of (Obj_Ent, Loc),
13653 Make_Identifier (Loc, Chars (Comp_Id))));
13663 -- Step 5: Add the declaration of the entry index and the associated
13664 -- type for barrier functions and entry families.
13666 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then
13668 E : constant Entity_Id := Index_Object (Spec_Id);
13669 Index : constant Entity_Id :=
13670 Defining_Identifier
13671 (Entry_Index_Specification
13672 (Entry_Body_Formal_Part (Body_Nod)));
13673 Index_Con : constant Entity_Id :=
13674 Make_Defining_Identifier (Loc, Chars (Index));
13676 Index_Typ : Entity_Id;
13680 -- Minimal decoration
13682 Set_Ekind (Index_Con, E_Constant);
13683 Set_Entry_Index_Constant (Index, Index_Con);
13684 Set_Discriminal_Link (Index_Con, Index);
13686 -- Retrieve the bounds of the entry family
13688 High := Type_High_Bound (Etype (Index));
13689 Low := Type_Low_Bound (Etype (Index));
13691 -- In the simple case the entry family is given by a subtype mark
13692 -- and the index constant has the same type.
13694 if Is_Entity_Name (Original_Node (
13695 Discrete_Subtype_Definition (Parent (Index))))
13697 Index_Typ := Etype (Index);
13699 -- Otherwise a new subtype declaration is required
13702 High := Replace_Bound (High);
13703 Low := Replace_Bound (Low);
13705 Index_Typ := Make_Temporary (Loc, 'J');
13708 -- subtype Jnn is <Etype of Index> range Low .. High;
13711 Make_Subtype_Declaration (Loc,
13712 Defining_Identifier => Index_Typ,
13713 Subtype_Indication =>
13714 Make_Subtype_Indication (Loc,
13716 New_Occurrence_Of (Base_Type (Etype (Index)), Loc),
13718 Make_Range_Constraint (Loc,
13719 Range_Expression =>
13720 Make_Range (Loc, Low, High))));
13724 Set_Etype (Index_Con, Index_Typ);
13726 -- Create the object which designates the index:
13727 -- J : constant Jnn :=
13728 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13730 -- where Jnn is the subtype created above or the original type of
13731 -- the index, _E is a formal of the protected body subprogram and
13732 -- <index expr> is the index of the first family member.
13735 Make_Object_Declaration (Loc,
13736 Defining_Identifier => Index_Con,
13737 Constant_Present => True,
13738 Object_Definition =>
13739 New_Occurrence_Of (Index_Typ, Loc),
13742 Make_Attribute_Reference (Loc,
13744 New_Occurrence_Of (Index_Typ, Loc),
13745 Attribute_Name => Name_Val,
13747 Expressions => New_List (
13751 Make_Op_Subtract (Loc,
13752 Left_Opnd => New_Occurrence_Of (E, Loc),
13754 Entry_Index_Expression (Loc,
13755 Defining_Identifier (Body_Nod),
13759 Make_Attribute_Reference (Loc,
13761 New_Occurrence_Of (Index_Typ, Loc),
13762 Attribute_Name => Name_Pos,
13763 Expressions => New_List (
13764 Make_Attribute_Reference (Loc,
13766 New_Occurrence_Of (Index_Typ, Loc),
13767 Attribute_Name => Name_First)))))));
13771 end Install_Private_Data_Declarations;
13773 ---------------------------------
13774 -- Is_Potentially_Large_Family --
13775 ---------------------------------
13777 function Is_Potentially_Large_Family
13778 (Base_Index : Entity_Id;
13779 Conctyp : Entity_Id;
13781 Hi : Node_Id) return Boolean
13784 return Scope (Base_Index) = Standard_Standard
13785 and then Base_Index = Base_Type (Standard_Integer)
13786 and then Has_Discriminants (Conctyp)
13788 Present (Discriminant_Default_Value (First_Discriminant (Conctyp)))
13790 (Denotes_Discriminant (Lo, True)
13792 Denotes_Discriminant (Hi, True));
13793 end Is_Potentially_Large_Family;
13795 -------------------------------------
13796 -- Is_Private_Primitive_Subprogram --
13797 -------------------------------------
13799 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
13802 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
13803 and then Is_Private_Primitive (Id);
13804 end Is_Private_Primitive_Subprogram;
13810 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is
13811 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id);
13812 Formal : Entity_Id;
13815 Formal := First_Formal (Bod_Subp);
13816 while Present (Formal) loop
13818 -- Look for formal parameter _E
13820 if Chars (Formal) = Name_uE then
13824 Next_Formal (Formal);
13827 -- A protected body subprogram should always have the parameter in
13830 raise Program_Error;
13833 --------------------------------
13834 -- Make_Initialize_Protection --
13835 --------------------------------
13837 function Make_Initialize_Protection
13838 (Protect_Rec : Entity_Id) return List_Id
13840 Loc : constant Source_Ptr := Sloc (Protect_Rec);
13843 Ptyp : constant Node_Id :=
13844 Corresponding_Concurrent_Type (Protect_Rec);
13846 L : constant List_Id := New_List;
13847 Has_Entry : constant Boolean := Has_Entries (Ptyp);
13848 Prio_Type : Entity_Id;
13849 Prio_Var : Entity_Id := Empty;
13850 Restricted : constant Boolean := Restricted_Profile;
13853 -- We may need two calls to properly initialize the object, one to
13854 -- Initialize_Protection, and possibly one to Install_Handlers if we
13855 -- have a pragma Attach_Handler.
13857 -- Get protected declaration. In the case of a task type declaration,
13858 -- this is simply the parent of the protected type entity. In the single
13859 -- protected object declaration, this parent will be the implicit type,
13860 -- and we can find the corresponding single protected object declaration
13861 -- by searching forward in the declaration list in the tree.
13863 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13864 -- of this type should have been removed during semantic analysis.
13866 Pdec := Parent (Ptyp);
13867 while not Nkind_In (Pdec, N_Protected_Type_Declaration,
13868 N_Single_Protected_Declaration)
13873 -- Build the parameter list for the call. Note that _Init is the name
13874 -- of the formal for the object to be initialized, which is the task
13875 -- value record itself.
13879 -- For lock-free implementation, skip initializations of the Protection
13882 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
13884 -- Object parameter. This is a pointer to the object of type
13885 -- Protection used by the GNARL to control the protected object.
13888 Make_Attribute_Reference (Loc,
13890 Make_Selected_Component (Loc,
13891 Prefix => Make_Identifier (Loc, Name_uInit),
13892 Selector_Name => Make_Identifier (Loc, Name_uObject)),
13893 Attribute_Name => Name_Unchecked_Access));
13895 -- Priority parameter. Set to Unspecified_Priority unless there is a
13896 -- Priority rep item, in which case we take the value from the pragma
13897 -- or attribute definition clause, or there is an Interrupt_Priority
13898 -- rep item and no Priority rep item, and we set the ceiling to
13899 -- Interrupt_Priority'Last, an implementation-defined value, see
13902 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then
13904 Prio_Clause : constant Node_Id :=
13906 (Ptyp, Name_Priority, Check_Parents => False);
13913 if Nkind (Prio_Clause) = N_Pragma then
13916 (First (Pragma_Argument_Associations (Prio_Clause)));
13918 -- Get_Rep_Item returns either priority pragma
13920 if Pragma_Name (Prio_Clause) = Name_Priority then
13921 Prio_Type := RTE (RE_Any_Priority);
13923 Prio_Type := RTE (RE_Interrupt_Priority);
13926 -- Attribute definition clause Priority
13929 if Chars (Prio_Clause) = Name_Priority then
13930 Prio_Type := RTE (RE_Any_Priority);
13932 Prio_Type := RTE (RE_Interrupt_Priority);
13935 Prio := Expression (Prio_Clause);
13938 -- Always create a locale variable to capture the priority.
13939 -- The priority is also passed to Install_Restriced_Handlers.
13940 -- Note that it is really necessary to create this variable
13941 -- explicitly. It might be thought that removing side effects
13942 -- would the appropriate approach, but that could generate
13943 -- declarations improperly placed in the enclosing scope.
13945 Prio_Var := Make_Temporary (Loc, 'R', Prio);
13947 Make_Object_Declaration (Loc,
13948 Defining_Identifier => Prio_Var,
13949 Object_Definition => New_Occurrence_Of (Prio_Type, Loc),
13950 Expression => Relocate_Node (Prio)));
13952 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
13955 -- When no priority is specified but an xx_Handler pragma is, we
13956 -- default to System.Interrupts.Default_Interrupt_Priority, see
13959 elsif Has_Attach_Handler (Ptyp)
13960 or else Has_Interrupt_Handler (Ptyp)
13963 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc));
13965 -- Normal case, no priority or xx_Handler specified, default priority
13969 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
13972 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
13974 if Restricted_Profile and Task_Dispatching_Policy = 'E' then
13975 Deadline_Floor : declare
13976 Item : constant Node_Id :=
13978 (Ptyp, Name_Deadline_Floor, Check_Parents => False);
13980 Deadline : Node_Id;
13983 if Present (Item) then
13985 -- Pragma Deadline_Floor
13987 if Nkind (Item) = N_Pragma then
13990 (First (Pragma_Argument_Associations (Item)));
13992 -- Attribute definition clause Deadline_Floor
13996 (Nkind (Item) = N_Attribute_Definition_Clause);
13998 Deadline := Expression (Item);
14001 Append_To (Args, Deadline);
14003 -- Unusual case: default deadline
14007 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14009 end Deadline_Floor;
14012 -- Test for Compiler_Info parameter. This parameter allows entry body
14013 -- procedures and barrier functions to be called from the runtime. It
14014 -- is a pointer to the record generated by the compiler to represent
14015 -- the protected object.
14017 -- A protected type without entries that covers an interface and
14018 -- overrides the abstract routines with protected procedures is
14019 -- considered equivalent to a protected type with entries in the
14020 -- context of dispatching select statements.
14022 -- Protected types with interrupt handlers (when not using a
14023 -- restricted profile) are also considered equivalent to protected
14024 -- types with entries.
14026 -- The types which are used (Static_Interrupt_Protection and
14027 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14030 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
14032 Called_Subp : RE_Id;
14036 when System_Tasking_Protected_Objects_Entries =>
14037 Called_Subp := RE_Initialize_Protection_Entries;
14039 -- Argument Compiler_Info
14042 Make_Attribute_Reference (Loc,
14043 Prefix => Make_Identifier (Loc, Name_uInit),
14044 Attribute_Name => Name_Address));
14046 when System_Tasking_Protected_Objects_Single_Entry =>
14047 Called_Subp := RE_Initialize_Protection_Entry;
14049 -- Argument Compiler_Info
14052 Make_Attribute_Reference (Loc,
14053 Prefix => Make_Identifier (Loc, Name_uInit),
14054 Attribute_Name => Name_Address));
14056 when System_Tasking_Protected_Objects =>
14057 Called_Subp := RE_Initialize_Protection;
14060 raise Program_Error;
14063 -- Entry_Queue_Maxes parameter. This is an access to an array of
14064 -- naturals representing the entry queue maximums for each entry
14065 -- in the protected type. Zero represents no max. The access is
14066 -- null if there is no limit for all entries (usual case).
14069 and then Pkg_Id = System_Tasking_Protected_Objects_Entries
14071 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then
14073 Make_Attribute_Reference (Loc,
14076 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
14077 Attribute_Name => Name_Unrestricted_Access));
14079 Append_To (Args, Make_Null (Loc));
14082 -- Edge cases exist where entry initialization functions are
14083 -- called, but no entries exist, so null is appended.
14085 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
14086 Append_To (Args, Make_Null (Loc));
14089 -- Entry_Bodies parameter. This is a pointer to an array of
14090 -- pointers to the entry body procedures and barrier functions of
14091 -- the object. If the protected type has no entries this object
14092 -- will not exist, in this case, pass a null (it can happen when
14093 -- there are protected interrupt handlers or interfaces).
14096 P_Arr := Entry_Bodies_Array (Ptyp);
14098 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14099 -- multiple entries).
14102 Make_Attribute_Reference (Loc,
14103 Prefix => New_Occurrence_Of (P_Arr, Loc),
14104 Attribute_Name => Name_Unrestricted_Access));
14106 if Pkg_Id = System_Tasking_Protected_Objects_Entries then
14108 -- Find index mapping function (clumsy but ok for now)
14110 while Ekind (P_Arr) /= E_Function loop
14111 Next_Entity (P_Arr);
14115 Make_Attribute_Reference (Loc,
14116 Prefix => New_Occurrence_Of (P_Arr, Loc),
14117 Attribute_Name => Name_Unrestricted_Access));
14120 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
14122 -- This is the case where we have a protected object with
14123 -- interfaces and no entries, and the single entry restriction
14124 -- is in effect. We pass a null pointer for the entry
14125 -- parameter because there is no actual entry.
14127 Append_To (Args, Make_Null (Loc));
14129 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
14131 -- This is the case where we have a protected object with no
14133 -- - either interrupt handlers with non restricted profile,
14135 -- Note that the types which are used for interrupt handlers
14136 -- (Static/Dynamic_Interrupt_Protection) are derived from
14137 -- Protection_Entries. We pass two null pointers because there
14138 -- is no actual entry, and the initialization procedure needs
14139 -- both Entry_Bodies and Find_Body_Index.
14141 Append_To (Args, Make_Null (Loc));
14142 Append_To (Args, Make_Null (Loc));
14146 Make_Procedure_Call_Statement (Loc,
14148 New_Occurrence_Of (RTE (Called_Subp), Loc),
14149 Parameter_Associations => Args));
14153 if Has_Attach_Handler (Ptyp) then
14155 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14156 -- make the following call:
14158 -- Install_Handlers (_object,
14159 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14161 -- or, in the case of Ravenscar:
14163 -- Install_Restricted_Handlers
14164 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14167 Args : constant List_Id := New_List;
14168 Table : constant List_Id := New_List;
14169 Ritem : Node_Id := First_Rep_Item (Ptyp);
14172 -- Build the Priority parameter (only for ravenscar)
14176 -- Priority comes from a pragma
14178 if Present (Prio_Var) then
14179 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
14181 -- Priority is the default one
14186 (RTE (RE_Default_Interrupt_Priority), Loc));
14190 -- Build the Attach_Handler table argument
14192 while Present (Ritem) loop
14193 if Nkind (Ritem) = N_Pragma
14194 and then Pragma_Name (Ritem) = Name_Attach_Handler
14197 Handler : constant Node_Id :=
14198 First (Pragma_Argument_Associations (Ritem));
14200 Interrupt : constant Node_Id := Next (Handler);
14201 Expr : constant Node_Id := Expression (Interrupt);
14205 Make_Aggregate (Loc, Expressions => New_List (
14206 Unchecked_Convert_To
14207 (RTE (RE_System_Interrupt_Id), Expr),
14208 Make_Attribute_Reference (Loc,
14210 Make_Selected_Component (Loc,
14212 Make_Identifier (Loc, Name_uInit),
14214 Duplicate_Subexpr_No_Checks
14215 (Expression (Handler))),
14216 Attribute_Name => Name_Access))));
14220 Next_Rep_Item (Ritem);
14223 -- Append the table argument we just built
14225 Append_To (Args, Make_Aggregate (Loc, Table));
14227 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14228 -- call to the statements.
14231 -- Call a simplified version of Install_Handlers to be used
14232 -- when the Ravenscar restrictions are in effect
14233 -- (Install_Restricted_Handlers).
14236 Make_Procedure_Call_Statement (Loc,
14239 (RTE (RE_Install_Restricted_Handlers), Loc),
14240 Parameter_Associations => Args));
14243 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
14245 -- First, prepends the _object argument
14248 Make_Attribute_Reference (Loc,
14250 Make_Selected_Component (Loc,
14251 Prefix => Make_Identifier (Loc, Name_uInit),
14253 Make_Identifier (Loc, Name_uObject)),
14254 Attribute_Name => Name_Unchecked_Access));
14257 -- Then, insert call to Install_Handlers
14260 Make_Procedure_Call_Statement (Loc,
14262 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc),
14263 Parameter_Associations => Args));
14269 end Make_Initialize_Protection;
14271 ---------------------------
14272 -- Make_Task_Create_Call --
14273 ---------------------------
14275 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
14276 Loc : constant Source_Ptr := Sloc (Task_Rec);
14286 Ttyp := Corresponding_Concurrent_Type (Task_Rec);
14287 Tnam := Chars (Ttyp);
14289 -- Get task declaration. In the case of a task type declaration, this is
14290 -- simply the parent of the task type entity. In the single task
14291 -- declaration, this parent will be the implicit type, and we can find
14292 -- the corresponding single task declaration by searching forward in the
14293 -- declaration list in the tree.
14295 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14296 -- this type should have been removed during semantic analysis.
14298 Tdec := Parent (Ttyp);
14299 while not Nkind_In (Tdec, N_Task_Type_Declaration,
14300 N_Single_Task_Declaration)
14305 -- Now we can find the task definition from this declaration
14307 Tdef := Task_Definition (Tdec);
14309 -- Build the parameter list for the call. Note that _Init is the name
14310 -- of the formal for the object to be initialized, which is the task
14311 -- value record itself.
14315 -- Priority parameter. Set to Unspecified_Priority unless there is a
14316 -- Priority rep item, in which case we take the value from the rep item.
14317 -- Not used on Ravenscar_EDF profile.
14319 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then
14320 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
14322 Make_Selected_Component (Loc,
14323 Prefix => Make_Identifier (Loc, Name_uInit),
14324 Selector_Name => Make_Identifier (Loc, Name_uPriority)));
14327 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14331 -- Optional Stack parameter
14333 if Restricted_Profile then
14335 -- If the stack has been preallocated by the expander then
14336 -- pass its address. Otherwise, pass a null address.
14338 if Preallocated_Stacks_On_Target then
14340 Make_Attribute_Reference (Loc,
14342 Make_Selected_Component (Loc,
14343 Prefix => Make_Identifier (Loc, Name_uInit),
14344 Selector_Name => Make_Identifier (Loc, Name_uStack)),
14345 Attribute_Name => Name_Address));
14349 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
14353 -- Size parameter. If no Storage_Size pragma is present, then
14354 -- the size is taken from the taskZ variable for the type, which
14355 -- is either Unspecified_Size, or has been reset by the use of
14356 -- a Storage_Size attribute definition clause. If a pragma is
14357 -- present, then the size is taken from the _Size field of the
14358 -- task value record, which was set from the pragma value.
14360 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then
14362 Make_Selected_Component (Loc,
14363 Prefix => Make_Identifier (Loc, Name_uInit),
14364 Selector_Name => Make_Identifier (Loc, Name_uSize)));
14368 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc));
14371 -- Secondary_Stack parameter used for restricted profiles
14373 if Restricted_Profile then
14375 -- If the secondary stack has been allocated by the expander then
14376 -- pass its access pointer. Otherwise, pass null.
14378 if Create_Secondary_Stack_For_Task (Ttyp) then
14380 Make_Attribute_Reference (Loc,
14382 Make_Selected_Component (Loc,
14383 Prefix => Make_Identifier (Loc, Name_uInit),
14385 Make_Identifier (Loc, Name_uSecondary_Stack)),
14386 Attribute_Name => Name_Unrestricted_Access));
14389 Append_To (Args, Make_Null (Loc));
14393 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
14394 -- is a Secondary_Stack_Size pragma, in which case take the value from
14395 -- the pragma. If the restriction No_Secondary_Stack is active then a
14396 -- size of 0 is passed regardless to prevent the allocation of the
14399 if Restriction_Active (No_Secondary_Stack) then
14400 Append_To (Args, Make_Integer_Literal (Loc, 0));
14402 elsif Has_Rep_Pragma
14403 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False)
14406 Make_Selected_Component (Loc,
14407 Prefix => Make_Identifier (Loc, Name_uInit),
14409 Make_Identifier (Loc, Name_uSecondary_Stack_Size)));
14413 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
14416 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14417 -- Task_Info pragma, in which case we take the value from the pragma.
14419 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then
14421 Make_Selected_Component (Loc,
14422 Prefix => Make_Identifier (Loc, Name_uInit),
14423 Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
14427 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc));
14430 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14431 -- in which case we take the value from the rep item. The parameter is
14432 -- passed as an Integer because in the case of unspecified CPU the
14433 -- value is not in the range of CPU_Range.
14435 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then
14437 Convert_To (Standard_Integer,
14438 Make_Selected_Component (Loc,
14439 Prefix => Make_Identifier (Loc, Name_uInit),
14440 Selector_Name => Make_Identifier (Loc, Name_uCPU))));
14443 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc));
14446 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then
14448 -- Deadline parameter. If no Relative_Deadline pragma is present,
14449 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14450 -- the deadline is taken from the _Relative_Deadline field of the
14451 -- task value record, which was set from the pragma value. Note that
14452 -- this parameter must not be generated for the restricted profiles
14453 -- since Ravenscar does not allow deadlines.
14455 -- Case where pragma Relative_Deadline applies: use given value
14457 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
14459 Make_Selected_Component (Loc,
14460 Prefix => Make_Identifier (Loc, Name_uInit),
14462 Make_Identifier (Loc, Name_uRelative_Deadline)));
14464 -- No pragma Relative_Deadline apply to the task
14468 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14472 if not Restricted_Profile then
14474 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14475 -- present, then the dispatching domain is null. If a rep item is
14476 -- present, then the dispatching domain is taken from the
14477 -- _Dispatching_Domain field of the task value record, which was set
14478 -- from the rep item value.
14480 -- Case where Dispatching_Domain rep item applies: use given value
14483 (Ttyp, Name_Dispatching_Domain, Check_Parents => False)
14486 Make_Selected_Component (Loc,
14488 Make_Identifier (Loc, Name_uInit),
14490 Make_Identifier (Loc, Name_uDispatching_Domain)));
14492 -- No pragma or aspect Dispatching_Domain applies to the task
14495 Append_To (Args, Make_Null (Loc));
14498 -- Number of entries. This is an expression of the form:
14500 -- n + _Init.a'Length + _Init.a'B'Length + ...
14502 -- where a,b... are the entry family names for the task definition
14505 Build_Entry_Count_Expression
14510 (Parent (Corresponding_Record_Type (Ttyp))))),
14512 Append_To (Args, Ecount);
14514 -- Master parameter. This is a reference to the _Master parameter of
14515 -- the initialization procedure, except in the case of the pragma
14516 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14517 -- System.Tasking.Library_Task_Level.
14519 if Restriction_Active (No_Task_Hierarchy) = False then
14520 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
14523 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
14527 -- State parameter. This is a pointer to the task body procedure. The
14528 -- required value is obtained by taking 'Unrestricted_Access of the task
14529 -- body procedure and converting it (with an unchecked conversion) to
14530 -- the type required by the task kernel. For further details, see the
14531 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14532 -- than 'Address in order to avoid creating trampolines.
14535 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp);
14536 Subp_Ptr_Typ : constant Node_Id :=
14537 Create_Itype (E_Access_Subprogram_Type, Tdec);
14538 Ref : constant Node_Id := Make_Itype_Reference (Loc);
14541 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc);
14542 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
14544 -- Be sure to freeze a reference to the access-to-subprogram type,
14545 -- otherwise gigi will complain that it's in the wrong scope, because
14546 -- it's actually inside the init procedure for the record type that
14547 -- corresponds to the task type.
14549 Set_Itype (Ref, Subp_Ptr_Typ);
14550 Append_Freeze_Action (Task_Rec, Ref);
14553 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
14554 Make_Qualified_Expression (Loc,
14555 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc),
14557 Make_Attribute_Reference (Loc,
14558 Prefix => New_Occurrence_Of (Body_Proc, Loc),
14559 Attribute_Name => Name_Unrestricted_Access))));
14562 -- Discriminants parameter. This is just the address of the task
14563 -- value record itself (which contains the discriminant values
14566 Make_Attribute_Reference (Loc,
14567 Prefix => Make_Identifier (Loc, Name_uInit),
14568 Attribute_Name => Name_Address));
14570 -- Elaborated parameter. This is an access to the elaboration Boolean
14573 Make_Attribute_Reference (Loc,
14574 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
14575 Attribute_Name => Name_Unchecked_Access));
14577 -- Add Chain parameter (not done for sequential elaboration policy, see
14578 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14580 if Partition_Elaboration_Policy /= 'S' then
14581 Append_To (Args, Make_Identifier (Loc, Name_uChain));
14584 -- Task name parameter. Take this from the _Task_Id parameter to the
14585 -- init call unless there is a Task_Name pragma, in which case we take
14586 -- the value from the pragma.
14588 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then
14589 -- Copy expression in full, because it may be dynamic and have
14596 (Pragma_Argument_Associations
14598 (Ttyp, Name_Task_Name, Check_Parents => False))))));
14601 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
14604 -- Created_Task parameter. This is the _Task_Id field of the task
14608 Make_Selected_Component (Loc,
14609 Prefix => Make_Identifier (Loc, Name_uInit),
14610 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
14616 if Restricted_Profile then
14617 if Partition_Elaboration_Policy = 'S' then
14618 Create_RE := RE_Create_Restricted_Task_Sequential;
14620 Create_RE := RE_Create_Restricted_Task;
14623 Create_RE := RE_Create_Task;
14626 Name := New_Occurrence_Of (RTE (Create_RE), Loc);
14630 Make_Procedure_Call_Statement (Loc,
14632 Parameter_Associations => Args);
14633 end Make_Task_Create_Call;
14635 ------------------------------
14636 -- Next_Protected_Operation --
14637 ------------------------------
14639 function Next_Protected_Operation (N : Node_Id) return Node_Id is
14643 -- Check whether there is a subsequent body for a protected operation
14644 -- in the current protected body. In Ada2012 that includes expression
14645 -- functions that are completions.
14647 Next_Op := Next (N);
14648 while Present (Next_Op)
14649 and then not Nkind_In (Next_Op,
14650 N_Subprogram_Body, N_Entry_Body, N_Expression_Function)
14656 end Next_Protected_Operation;
14658 ---------------------
14659 -- Null_Statements --
14660 ---------------------
14662 function Null_Statements (Stats : List_Id) return Boolean is
14666 Stmt := First (Stats);
14667 while Nkind (Stmt) /= N_Empty
14668 and then (Nkind_In (Stmt, N_Null_Statement, N_Label)
14670 (Nkind (Stmt) = N_Pragma
14672 Nam_In (Pragma_Name_Unmapped (Stmt),
14680 return Nkind (Stmt) = N_Empty;
14681 end Null_Statements;
14683 --------------------------
14684 -- Parameter_Block_Pack --
14685 --------------------------
14687 function Parameter_Block_Pack
14689 Blk_Typ : Entity_Id;
14693 Stmts : List_Id) return Node_Id
14695 Actual : Entity_Id;
14696 Expr : Node_Id := Empty;
14697 Formal : Entity_Id;
14698 Has_Param : Boolean := False;
14701 Temp_Asn : Node_Id;
14702 Temp_Nam : Node_Id;
14705 Actual := First (Actuals);
14706 Formal := Defining_Identifier (First (Formals));
14707 Params := New_List;
14708 while Present (Actual) loop
14709 if Is_By_Copy_Type (Etype (Actual)) then
14711 -- Jnn : aliased <formal-type>
14713 Temp_Nam := Make_Temporary (Loc, 'J');
14716 Make_Object_Declaration (Loc,
14717 Aliased_Present => True,
14718 Defining_Identifier => Temp_Nam,
14719 Object_Definition =>
14720 New_Occurrence_Of (Etype (Formal), Loc)));
14722 -- The object is initialized with an explicit assignment
14723 -- later. Indicate that it does not need an initialization
14724 -- to prevent spurious warnings if the type excludes null.
14726 Set_No_Initialization (Last (Decls));
14728 if Ekind (Formal) /= E_Out_Parameter then
14734 New_Occurrence_Of (Temp_Nam, Loc);
14736 Set_Assignment_OK (Temp_Asn);
14739 Make_Assignment_Statement (Loc,
14741 Expression => New_Copy_Tree (Actual)));
14744 -- If the actual is not controlling, generate:
14746 -- Jnn'unchecked_access
14748 -- and add it to aggegate for access to formals. Note that the
14749 -- actual may be by-copy but still be a controlling actual if it
14750 -- is an access to class-wide interface.
14752 if not Is_Controlling_Actual (Actual) then
14754 Make_Attribute_Reference (Loc,
14755 Attribute_Name => Name_Unchecked_Access,
14756 Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
14761 -- The controlling parameter is omitted
14764 if not Is_Controlling_Actual (Actual) then
14766 Make_Reference (Loc, New_Copy_Tree (Actual)));
14772 Next_Actual (Actual);
14773 Next_Formal_With_Extras (Formal);
14777 Expr := Make_Aggregate (Loc, Params);
14782 -- J1'unchecked_access;
14783 -- <actual2>'reference;
14786 P := Make_Temporary (Loc, 'P');
14789 Make_Object_Declaration (Loc,
14790 Defining_Identifier => P,
14791 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc),
14792 Expression => Expr));
14795 end Parameter_Block_Pack;
14797 ----------------------------
14798 -- Parameter_Block_Unpack --
14799 ----------------------------
14801 function Parameter_Block_Unpack
14805 Formals : List_Id) return List_Id
14807 Actual : Entity_Id;
14809 Formal : Entity_Id;
14810 Has_Asnmt : Boolean := False;
14811 Result : constant List_Id := New_List;
14814 Actual := First (Actuals);
14815 Formal := Defining_Identifier (First (Formals));
14816 while Present (Actual) loop
14817 if Is_By_Copy_Type (Etype (Actual))
14818 and then Ekind (Formal) /= E_In_Parameter
14821 -- <actual> := P.<formal>;
14824 Make_Assignment_Statement (Loc,
14828 Make_Explicit_Dereference (Loc,
14829 Make_Selected_Component (Loc,
14831 New_Occurrence_Of (P, Loc),
14833 Make_Identifier (Loc, Chars (Formal)))));
14835 Set_Assignment_OK (Name (Asnmt));
14836 Append_To (Result, Asnmt);
14841 Next_Actual (Actual);
14842 Next_Formal_With_Extras (Formal);
14848 return New_List (Make_Null_Statement (Loc));
14850 end Parameter_Block_Unpack;
14852 ---------------------
14853 -- Reset_Scopes_To --
14854 ---------------------
14856 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is
14857 function Reset_Scope (N : Node_Id) return Traverse_Result;
14858 -- Temporaries may have been declared during expansion of the procedure
14859 -- created for an entry body or an accept alternative. Indicate that
14860 -- their scope is the new body, to ensure proper generation of uplevel
14861 -- references where needed during unnesting.
14863 procedure Reset_Scopes is new Traverse_Proc (Reset_Scope);
14869 function Reset_Scope (N : Node_Id) return Traverse_Result is
14873 -- If this is a block statement with an Identifier, it forms a scope,
14874 -- so we want to reset its scope but not look inside.
14877 and then Nkind (N) = N_Block_Statement
14878 and then Present (Identifier (N))
14880 Set_Scope (Entity (Identifier (N)), E);
14883 -- Ditto for a package declaration or a full type declaration, etc.
14885 elsif Nkind (N) = N_Package_Declaration
14886 or else Nkind (N) in N_Declaration
14887 or else Nkind (N) in N_Renaming_Declaration
14889 Set_Scope (Defining_Entity (N), E);
14894 -- Scan declarations in new body. Declarations in the statement
14895 -- part will be handled during later traversal.
14897 Decl := First (Declarations (N));
14898 while Present (Decl) loop
14899 Reset_Scopes (Decl);
14903 elsif N /= Bod and then Nkind (N) in N_Proper_Body then
14910 -- Start of processing for Reset_Scopes_To
14913 Reset_Scopes (Bod);
14914 end Reset_Scopes_To;
14916 ----------------------
14917 -- Set_Discriminals --
14918 ----------------------
14920 procedure Set_Discriminals (Dec : Node_Id) is
14923 D_Minal : Entity_Id;
14926 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
14927 Pdef := Defining_Identifier (Dec);
14929 if Has_Discriminants (Pdef) then
14930 D := First_Discriminant (Pdef);
14931 while Present (D) loop
14933 Make_Defining_Identifier (Sloc (D),
14934 Chars => New_External_Name (Chars (D), 'D'));
14936 Set_Ekind (D_Minal, E_Constant);
14937 Set_Etype (D_Minal, Etype (D));
14938 Set_Scope (D_Minal, Pdef);
14939 Set_Discriminal (D, D_Minal);
14940 Set_Discriminal_Link (D_Minal, D);
14942 Next_Discriminant (D);
14945 end Set_Discriminals;
14947 -----------------------
14948 -- Trivial_Accept_OK --
14949 -----------------------
14951 function Trivial_Accept_OK return Boolean is
14953 case Opt.Task_Dispatching_Policy is
14955 -- If we have the default task dispatching policy in effect, we can
14956 -- definitely do the optimization (one way of looking at this is to
14957 -- think of the formal definition of the default policy being allowed
14958 -- to run any task it likes after a rendezvous, so even if notionally
14959 -- a full rescheduling occurs, we can say that our dispatching policy
14960 -- (i.e. the default dispatching policy) reorders the queue to be the
14961 -- same as just before the call.
14966 -- FIFO_Within_Priorities certainly does not permit this
14967 -- optimization since the Rendezvous is a scheduling action that may
14968 -- require some other task to be run.
14973 -- For now, disallow the optimization for all other policies. This
14974 -- may be over-conservative, but it is certainly not incorrect.
14979 end Trivial_Accept_OK;