1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Aspects; use Aspects;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Ch3; use Exp_Ch3;
33 with Exp_Ch6; use Exp_Ch6;
34 with Exp_Ch11; use Exp_Ch11;
35 with Exp_Dbug; use Exp_Dbug;
36 with Exp_Sel; use Exp_Sel;
37 with Exp_Smem; use Exp_Smem;
38 with Exp_Tss; use Exp_Tss;
39 with Exp_Util; use Exp_Util;
40 with Freeze; use Freeze;
42 with Itypes; use Itypes;
43 with Namet; use Namet;
44 with Nlists; use Nlists;
45 with Nmake; use Nmake;
47 with Restrict; use Restrict;
48 with Rident; use Rident;
49 with Rtsfind; use Rtsfind;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Ch5; use Sem_Ch5;
53 with Sem_Ch6; use Sem_Ch6;
54 with Sem_Ch8; use Sem_Ch8;
55 with Sem_Ch9; use Sem_Ch9;
56 with Sem_Ch11; use Sem_Ch11;
57 with Sem_Ch13; use Sem_Ch13;
58 with Sem_Elab; use Sem_Elab;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Res; use Sem_Res;
61 with Sem_Util; use Sem_Util;
62 with Sinfo; use Sinfo;
63 with Snames; use Snames;
64 with Stand; use Stand;
65 with Targparm; use Targparm;
66 with Tbuild; use Tbuild;
67 with Uintp; use Uintp;
68 with Validsw; use Validsw;
70 package body Exp_Ch9 is
72 -- The following constant establishes the upper bound for the index of
73 -- an entry family. It is used to limit the allocated size of protected
74 -- types with defaulted discriminant of an integer type, when the bound
75 -- of some entry family depends on a discriminant. The limitation to entry
76 -- families of 128K should be reasonable in all cases, and is a documented
77 -- implementation restriction.
79 Entry_Family_Bound : constant Pos := 2**16;
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 function Actual_Index_Expression
89 Tsk : Entity_Id) return Node_Id;
90 -- Compute the index position for an entry call. Tsk is the target task. If
91 -- the bounds of some entry family depend on discriminants, the expression
92 -- computed by this function uses the discriminants of the target task.
94 procedure Add_Object_Pointer
98 -- Prepend an object pointer declaration to the declaration list Decls.
99 -- This object pointer is initialized to a type conversion of the System.
100 -- Address pointer passed to entry barrier functions and entry body
103 procedure Add_Formal_Renamings
108 -- Create renaming declarations for the formals, inside the procedure that
109 -- implements an entry body. The renamings make the original names of the
110 -- formals accessible to gdb, and serve no other purpose.
111 -- Spec is the specification of the procedure being built.
112 -- Decls is the list of declarations to be enhanced.
113 -- Ent is the entity for the original entry body.
115 function Build_Accept_Body (Astat : Node_Id) return Node_Id;
116 -- Transform accept statement into a block with added exception handler.
117 -- Used both for simple accept statements and for accept alternatives in
118 -- select statements. Astat is the accept statement.
120 function Build_Barrier_Function
123 Pid : Entity_Id) return Node_Id;
124 -- Build the function body returning the value of the barrier expression
125 -- for the specified entry body.
127 function Build_Barrier_Function_Specification
129 Def_Id : Entity_Id) return Node_Id;
130 -- Build a specification for a function implementing the protected entry
131 -- barrier of the specified entry body.
133 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id);
134 -- Build the body of a wrapper procedure for an entry or entry family that
135 -- has contract cases, preconditions, or postconditions. The body gathers
136 -- the executable contract items and expands them in the usual way, and
137 -- performs the entry call itself. This way preconditions are evaluated
138 -- before the call is queued. E is the entry in question, and Decl is the
139 -- enclosing synchronized type declaration at whose freeze point the
140 -- generated body is analyzed.
142 function Build_Corresponding_Record
145 Loc : Source_Ptr) return Node_Id;
146 -- Common to tasks and protected types. Copy discriminant specifications,
147 -- build record declaration. N is the type declaration, Ctyp is the
148 -- concurrent entity (task type or protected type).
150 function Build_Dispatching_Tag_Check
152 N : Node_Id) return Node_Id;
153 -- Utility to create the tree to check whether the dispatching call in
154 -- a timed entry call, a conditional entry call, or an asynchronous
155 -- transfer of control is a call to a primitive of a non-synchronized type.
156 -- K is the temporary that holds the tagged kind of the target object, and
157 -- N is the enclosing construct.
159 function Build_Entry_Count_Expression
160 (Concurrent_Type : Node_Id;
161 Component_List : List_Id;
162 Loc : Source_Ptr) return Node_Id;
163 -- Compute number of entries for concurrent object. This is a count of
164 -- simple entries, followed by an expression that computes the length
165 -- of the range of each entry family. A single array with that size is
166 -- allocated for each concurrent object of the type.
168 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
169 -- Build the function that translates the entry index in the call
170 -- (which depends on the size of entry families) into an index into the
171 -- Entry_Bodies_Array, to determine the body and barrier function used
172 -- in a protected entry call. A pointer to this function appears in every
175 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
176 -- Build subprogram declaration for previous one
178 function Build_Lock_Free_Protected_Subprogram_Body
181 Unprot_Spec : Node_Id) return Node_Id;
182 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
183 -- the subprogram specification of the unprotected version of N. Transform
184 -- N such that it invokes the unprotected version of the body.
186 function Build_Lock_Free_Unprotected_Subprogram_Body
188 Prot_Typ : Node_Id) return Node_Id;
189 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
190 -- of N where the original statements of N are synchronized through atomic
191 -- actions such as compare and exchange. Prior to invoking this routine, it
192 -- has been established that N can be implemented in a lock-free fashion.
194 function Build_Parameter_Block
198 Decls : List_Id) return Entity_Id;
199 -- Generate an access type for each actual parameter in the list Actuals.
200 -- Create an encapsulating record that contains all the actuals and return
201 -- its type. Generate:
202 -- type Ann1 is access all <actual1-type>
204 -- type AnnN is access all <actualN-type>
205 -- type Pnn is record
211 function Build_Protected_Entry
214 Pid : Node_Id) return Node_Id;
215 -- Build the procedure implementing the statement sequence of the specified
218 function Build_Protected_Entry_Specification
221 Ent_Id : Entity_Id) return Node_Id;
222 -- Build a specification for the procedure implementing the statements of
223 -- the specified entry body. Add attributes associating it with the entry
224 -- defining identifier Ent_Id.
226 function Build_Protected_Spec
228 Obj_Type : Entity_Id;
230 Unprotected : Boolean := False) return List_Id;
231 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
232 -- Subprogram_Type. Builds signature of protected subprogram, adding the
233 -- formal that corresponds to the object itself. For an access to protected
234 -- subprogram, there is no object type to specify, so the parameter has
235 -- type Address and mode In. An indirect call through such a pointer will
236 -- convert the address to a reference to the actual object. The object is
237 -- a limited record and therefore a by_reference type.
239 function Build_Protected_Subprogram_Body
242 N_Op_Spec : Node_Id) return Node_Id;
243 -- This function is used to construct the protected version of a protected
244 -- subprogram. Its statement sequence first defers abort, then locks the
245 -- associated protected object, and then enters a block that contains a
246 -- call to the unprotected version of the subprogram (for details, see
247 -- Build_Unprotected_Subprogram_Body). This block statement requires a
248 -- cleanup handler that unlocks the object in all cases. For details,
249 -- see Exp_Ch7.Expand_Cleanup_Actions.
251 function Build_Renamed_Formal_Declaration
255 Renamed_Formal : Node_Id) return Node_Id;
256 -- Create a renaming declaration for a formal, within a protected entry
257 -- body or an accept body. The renamed object is a component of the
258 -- parameter block that is a parameter in the entry call.
260 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
261 -- does not dereference the corresponding component to prevent an illegal
262 -- use of the incomplete type (AI05-0151).
264 function Build_Selected_Name
266 Selector : Entity_Id;
267 Append_Char : Character := ' ') return Name_Id;
268 -- Build a name in the form of Prefix__Selector, with an optional character
269 -- appended. This is used for internal subprograms generated for operations
270 -- of protected types, including barrier functions. For the subprograms
271 -- generated for entry bodies and entry barriers, the generated name
272 -- includes a sequence number that makes names unique in the presence of
273 -- entry overloading. This is necessary because entry body procedures and
274 -- barrier functions all have the same signature.
276 procedure Build_Simple_Entry_Call
281 -- Some comments here would be useful ???
283 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
284 -- This routine constructs a specification for the procedure that we will
285 -- build for the task body for task type T. The spec has the form:
287 -- procedure tnameB (_Task : access tnameV);
289 -- where name is the character name taken from the task type entity that
290 -- is passed as the argument to the procedure, and tnameV is the task
291 -- value type that is associated with the task type.
293 function Build_Unprotected_Subprogram_Body
295 Pid : Node_Id) return Node_Id;
296 -- This routine constructs the unprotected version of a protected
297 -- subprogram body, which contains all of the code in the original,
298 -- unexpanded body. This is the version of the protected subprogram that is
299 -- called from all protected operations on the same object, including the
300 -- protected version of the same subprogram.
302 procedure Build_Wrapper_Bodies
306 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
307 -- record of a concurrent type. N is the insertion node where all bodies
308 -- will be placed. This routine builds the bodies of the subprograms which
309 -- serve as an indirection mechanism to overriding primitives of concurrent
310 -- types, entries and protected procedures. Any new body is analyzed.
312 procedure Build_Wrapper_Specs
316 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
317 -- record of a concurrent type. N is the insertion node where all specs
318 -- will be placed. This routine builds the specs of the subprograms which
319 -- serve as an indirection mechanism to overriding primitives of concurrent
320 -- types, entries and protected procedures. Any new spec is analyzed.
322 procedure Collect_Entry_Families
325 Current_Node : in out Node_Id;
326 Conctyp : Entity_Id);
327 -- For each entry family in a concurrent type, create an anonymous array
328 -- type of the right size, and add a component to the corresponding_record.
330 function Concurrent_Object
331 (Spec_Id : Entity_Id;
332 Conc_Typ : Entity_Id) return Entity_Id;
333 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
334 -- the entity associated with the concurrent object in the Protected_Body_
335 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
336 -- denotes formal parameter _O, _object or _task.
338 function Copy_Result_Type (Res : Node_Id) return Node_Id;
339 -- Copy the result type of a function specification, when building the
340 -- internal operation corresponding to a protected function, or when
341 -- expanding an access to protected function. If the result is an anonymous
342 -- access to subprogram itself, we need to create a new signature with the
343 -- same parameter names and the same resolved types, but with new entities
346 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean;
347 -- Return whether a secondary stack for the task T should be created by the
348 -- expander. The secondary stack for a task will be created by the expander
349 -- if the size of the stack has been specified by the Secondary_Stack_Size
350 -- representation aspect and either the No_Implicit_Heap_Allocations or
351 -- No_Implicit_Task_Allocations restrictions are in effect and the
352 -- No_Secondary_Stack restriction is not.
354 procedure Debug_Private_Data_Declarations (Decls : List_Id);
355 -- Decls is a list which may contain the declarations created by Install_
356 -- Private_Data_Declarations. All generated entities are marked as needing
357 -- debug info and debug nodes are manually generation where necessary. This
358 -- step of the expansion must to be done after private data has been moved
359 -- to its final resting scope to ensure proper visibility of debug objects.
361 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id);
362 -- If control flow optimizations are suppressed, and Alt is an accept,
363 -- delay, or entry call alternative with no trailing statements, insert
364 -- a null trailing statement with the given Loc (which is the sloc of
365 -- the accept, delay, or entry call statement). There might not be any
366 -- generated code for the accept, delay, or entry call itself (the effect
367 -- of these statements is part of the general processing done for the
368 -- enclosing selective accept, timed entry call, or asynchronous select),
369 -- and the null statement is there to carry the sloc of that statement to
370 -- the back-end for trace-based coverage analysis purposes.
372 procedure Extract_Dispatching_Call
374 Call_Ent : out Entity_Id;
375 Object : out Entity_Id;
376 Actuals : out List_Id;
377 Formals : out List_Id);
378 -- Given a dispatching call, extract the entity of the name of the call,
379 -- its actual dispatching object, its actual parameters and the formal
380 -- parameters of the overridden interface-level version. If the type of
381 -- the dispatching object is an access type then an explicit dereference
382 -- is returned in Object.
384 procedure Extract_Entry
386 Concval : out Node_Id;
388 Index : out Node_Id);
389 -- Given an entry call, returns the associated concurrent object, the entry
390 -- name, and the entry family index.
392 function Family_Offset
397 Cap : Boolean) return Node_Id;
398 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
399 -- accept statement, or the upper bound in the discrete subtype of an entry
400 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
401 -- type of the entry. If Cap is true, the result is capped according to
402 -- Entry_Family_Bound.
409 Cap : Boolean) return Node_Id;
410 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
411 -- family, and handle properly the superflat case. This is equivalent to
412 -- the use of 'Length on the index type, but must use Family_Offset to
413 -- handle properly the case of bounds that depend on discriminants. If
414 -- Cap is true, the result is capped according to Entry_Family_Bound.
416 procedure Find_Enclosing_Context
418 Context : out Node_Id;
419 Context_Id : out Entity_Id;
420 Context_Decls : out List_Id);
421 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
422 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
423 -- nearest enclosing body, block, package, or return statement and return
424 -- its constituents. Context is the enclosing construct, Context_Id is
425 -- the scope of Context_Id and Context_Decls is the declarative list of
428 function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
429 -- Given a subprogram identifier, return the entity which is associated
430 -- with the protection entry index in the Protected_Body_Subprogram or
431 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
434 function Is_Potentially_Large_Family
435 (Base_Index : Entity_Id;
438 Hi : Node_Id) return Boolean;
439 -- Determine whether an entry family is potentially large because one of
440 -- its bounds denotes a discrminant.
442 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
443 -- Determine whether Id is a function or a procedure and is marked as a
444 -- private primitive.
446 function Null_Statements (Stats : List_Id) return Boolean;
447 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
448 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
449 -- to still count as null. Returns True for a null sequence. The argument
450 -- is the list of statements from the DO-END sequence.
452 function Parameter_Block_Pack
458 Stmts : List_Id) return Entity_Id;
459 -- Set the components of the generated parameter block with the values
460 -- of the actual parameters. Generate aliased temporaries to capture the
461 -- values for types that are passed by copy. Otherwise generate a reference
462 -- to the actual's value. Return the address of the aggregate block.
464 -- Jnn1 : alias <formal-type1>;
465 -- Jnn1 := <actual1>;
468 -- Jnn1'unchecked_access;
469 -- <actual2>'reference;
472 function Parameter_Block_Unpack
476 Formals : List_Id) return List_Id;
477 -- Retrieve the values of the components from the parameter block and
478 -- assign then to the original actual parameters. Generate:
479 -- <actual1> := P.<formal1>;
481 -- <actualN> := P.<formalN>;
483 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id);
484 -- Reset the scope of declarations and blocks at the top level of Bod to
485 -- be E. Bod is either a block or a subprogram body. Used after expanding
486 -- various kinds of entry bodies into their corresponding constructs. This
487 -- is needed during unnesting to determine whether a body generated for an
488 -- entry or an accept alternative includes uplevel references.
490 function Trivial_Accept_OK return Boolean;
491 -- If there is no DO-END block for an accept, or if the DO-END block has
492 -- only null statements, then it is possible to do the Rendezvous with much
493 -- less overhead using the Accept_Trivial routine in the run-time library.
494 -- However, this is not always a valid optimization. Whether it is valid or
495 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
496 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
497 -- a rescheduling is required, so this optimization is not allowed. This
498 -- function returns True if the optimization is permitted.
500 -----------------------------
501 -- Actual_Index_Expression --
502 -----------------------------
504 function Actual_Index_Expression
508 Tsk : Entity_Id) return Node_Id
510 Ttyp : constant Entity_Id := Etype (Tsk);
518 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
519 -- Compute difference between bounds of entry family
521 --------------------------
522 -- Actual_Family_Offset --
523 --------------------------
525 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
527 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
528 -- Replace a reference to a discriminant with a selected component
529 -- denoting the discriminant of the target task.
531 -----------------------------
532 -- Actual_Discriminant_Ref --
533 -----------------------------
535 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
536 Typ : constant Entity_Id := Etype (Bound);
540 if not Is_Entity_Name (Bound)
541 or else Ekind (Entity (Bound)) /= E_Discriminant
543 if Nkind (Bound) = N_Attribute_Reference then
546 B := New_Copy_Tree (Bound);
551 Make_Selected_Component (Sloc,
552 Prefix => New_Copy_Tree (Tsk),
553 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
555 Analyze_And_Resolve (B, Typ);
559 Make_Attribute_Reference (Sloc,
560 Attribute_Name => Name_Pos,
561 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
562 Expressions => New_List (B));
563 end Actual_Discriminant_Ref;
565 -- Start of processing for Actual_Family_Offset
569 Make_Op_Subtract (Sloc,
570 Left_Opnd => Actual_Discriminant_Ref (Hi),
571 Right_Opnd => Actual_Discriminant_Ref (Lo));
572 end Actual_Family_Offset;
574 -- Start of processing for Actual_Index_Expression
577 -- The queues of entries and entry families appear in textual order in
578 -- the associated record. The entry index is computed as the sum of the
579 -- number of queues for all entries that precede the designated one, to
580 -- which is added the index expression, if this expression denotes a
581 -- member of a family.
583 -- The following is a place holder for the count of simple entries
585 Num := Make_Integer_Literal (Sloc, 1);
587 -- We construct an expression which is a series of addition operations.
588 -- See comments in Entry_Index_Expression, which is identical in
591 if Present (Index) then
592 S := Entry_Index_Type (Ent);
594 -- First make sure the index is in range if requested. The index type
595 -- has been directly set on the prefix, see Resolve_Entry.
597 if Do_Range_Check (Index) then
599 (Index, Etype (Prefix (Parent (Index))), CE_Range_Check_Failed);
606 Actual_Family_Offset (
607 Make_Attribute_Reference (Sloc,
608 Attribute_Name => Name_Pos,
609 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
610 Expressions => New_List (Relocate_Node (Index))),
611 Type_Low_Bound (S)));
616 -- Now add lengths of preceding entries and entry families
618 Prev := First_Entity (Ttyp);
619 while Chars (Prev) /= Chars (Ent)
620 or else (Ekind (Prev) /= Ekind (Ent))
621 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
623 if Ekind (Prev) = E_Entry then
624 Set_Intval (Num, Intval (Num) + 1);
626 elsif Ekind (Prev) = E_Entry_Family then
627 S := Entry_Index_Type (Prev);
629 -- The need for the following full view retrieval stems from this
630 -- complex case of nested generics and tasking:
633 -- type Formal_Index is range <>;
636 -- type Index is private;
643 -- type Index is new Formal_Index range 1 .. 10;
646 -- package body Outer is
648 -- entry Fam (Index); -- (2)
651 -- package body Inner is -- (3)
659 -- We are currently building the index expression for the entry
660 -- call "T.E" (1). Part of the expansion must mention the range
661 -- of the discrete type "Index" (2) of entry family "Fam".
663 -- However only the private view of type "Index" is available to
664 -- the inner generic (3) because there was no prior mention of
665 -- the type inside "Inner". This visibility requirement is
666 -- implicit and cannot be detected during the construction of
667 -- the generic trees and needs special handling.
670 and then Is_Private_Type (S)
671 and then Present (Full_View (S))
676 Lo := Type_Low_Bound (S);
677 Hi := Type_High_Bound (S);
684 Left_Opnd => Actual_Family_Offset (Hi, Lo),
685 Right_Opnd => Make_Integer_Literal (Sloc, 1)));
687 -- Other components are anonymous types to be ignored
697 end Actual_Index_Expression;
699 --------------------------
700 -- Add_Formal_Renamings --
701 --------------------------
703 procedure Add_Formal_Renamings
709 Ptr : constant Entity_Id :=
711 (Next (First (Parameter_Specifications (Spec))));
712 -- The name of the formal that holds the address of the parameter block
719 Renamed_Formal : Node_Id;
722 Formal := First_Formal (Ent);
723 while Present (Formal) loop
724 Comp := Entry_Component (Formal);
726 Make_Defining_Identifier (Sloc (Formal),
727 Chars => Chars (Formal));
728 Set_Etype (New_F, Etype (Formal));
729 Set_Scope (New_F, Ent);
731 -- Now we set debug info needed on New_F even though it does not come
732 -- from source, so that the debugger will get the right information
733 -- for these generated names.
735 Set_Debug_Info_Needed (New_F);
737 if Ekind (Formal) = E_In_Parameter then
738 Set_Ekind (New_F, E_Constant);
740 Set_Ekind (New_F, E_Variable);
741 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
744 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
747 Make_Selected_Component (Loc,
749 Make_Explicit_Dereference (Loc,
750 Unchecked_Convert_To (Entry_Parameters_Type (Ent),
751 Make_Identifier (Loc, Chars (Ptr)))),
752 Selector_Name => New_Occurrence_Of (Comp, Loc));
755 Build_Renamed_Formal_Declaration
756 (New_F, Formal, Comp, Renamed_Formal);
758 Append (Decl, Decls);
759 Set_Renamed_Object (Formal, New_F);
760 Next_Formal (Formal);
762 end Add_Formal_Renamings;
764 ------------------------
765 -- Add_Object_Pointer --
766 ------------------------
768 procedure Add_Object_Pointer
770 Conc_Typ : Entity_Id;
773 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ);
778 -- Create the renaming declaration for the Protection object of a
779 -- protected type. _Object is used by Complete_Entry_Body.
780 -- ??? An attempt to make this a renaming was unsuccessful.
782 -- Build the entity for the access type
785 Make_Defining_Identifier (Loc,
786 New_External_Name (Chars (Rec_Typ), 'P'));
789 -- _object : poVP := poVP!O;
792 Make_Object_Declaration (Loc,
793 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject),
794 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc),
796 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO)));
797 Set_Debug_Info_Needed (Defining_Identifier (Decl));
798 Prepend_To (Decls, Decl);
801 -- type poVP is access poV;
804 Make_Full_Type_Declaration (Loc,
805 Defining_Identifier =>
808 Make_Access_To_Object_Definition (Loc,
809 Subtype_Indication =>
810 New_Occurrence_Of (Rec_Typ, Loc)));
811 Set_Debug_Info_Needed (Defining_Identifier (Decl));
812 Prepend_To (Decls, Decl);
813 end Add_Object_Pointer;
815 -----------------------
816 -- Build_Accept_Body --
817 -----------------------
819 function Build_Accept_Body (Astat : Node_Id) return Node_Id is
820 Loc : constant Source_Ptr := Sloc (Astat);
821 Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
828 -- At the end of the statement sequence, Complete_Rendezvous is called.
829 -- A label skipping the Complete_Rendezvous, and all other accept
830 -- processing, has already been added for the expansion of requeue
831 -- statements. The Sloc is copied from the last statement since it
832 -- is really part of this last statement.
836 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
837 Insert_Before (Last (Statements (Stats)), Call);
840 -- Ada 2020 (AI12-0279)
842 if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
843 and then RTE_Available (RE_Yield)
845 Insert_Action_After (Call,
846 Make_Procedure_Call_Statement (Loc,
847 New_Occurrence_Of (RTE (RE_Yield), Loc)));
850 -- If exception handlers are present, then append Complete_Rendezvous
851 -- calls to the handlers, and construct the required outer block. As
852 -- above, the Sloc is copied from the last statement in the sequence.
854 if Present (Exception_Handlers (Stats)) then
855 Hand := First (Exception_Handlers (Stats));
856 while Present (Hand) loop
859 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
860 Append (Call, Statements (Hand));
863 -- Ada 2020 (AI12-0279)
865 if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
866 and then RTE_Available (RE_Yield)
868 Insert_Action_After (Call,
869 Make_Procedure_Call_Statement (Loc,
870 New_Occurrence_Of (RTE (RE_Yield), Loc)));
877 Make_Handled_Sequence_Of_Statements (Loc,
878 Statements => New_List (
879 Make_Block_Statement (Loc,
880 Handled_Statement_Sequence => Stats)));
886 -- At this stage we know that the new statement sequence does
887 -- not have an exception handler part, so we supply one to call
888 -- Exceptional_Complete_Rendezvous. This handler is
890 -- when all others =>
891 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
893 -- We handle Abort_Signal to make sure that we properly catch the abort
894 -- case and wake up the caller.
897 Make_Procedure_Call_Statement (Sloc (Stats),
898 Name => New_Occurrence_Of (
899 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
900 Parameter_Associations => New_List (
901 Make_Function_Call (Sloc (Stats),
904 (RTE (RE_Get_GNAT_Exception), Sloc (Stats)))));
906 Ohandle := Make_Others_Choice (Loc);
907 Set_All_Others (Ohandle);
909 Set_Exception_Handlers (New_S,
911 Make_Implicit_Exception_Handler (Loc,
912 Exception_Choices => New_List (Ohandle),
914 Statements => New_List (Call))));
916 -- Ada 2020 (AI12-0279)
918 if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
919 and then RTE_Available (RE_Yield)
921 Insert_Action_After (Call,
922 Make_Procedure_Call_Statement (Loc,
923 New_Occurrence_Of (RTE (RE_Yield), Loc)));
926 Set_Parent (New_S, Astat); -- temp parent for Analyze call
927 Analyze_Exception_Handlers (Exception_Handlers (New_S));
928 Expand_Exception_Handlers (New_S);
930 -- Exceptional_Complete_Rendezvous must be called with abort still
931 -- deferred, which is the case for a "when all others" handler.
934 end Build_Accept_Body;
936 -----------------------------------
937 -- Build_Activation_Chain_Entity --
938 -----------------------------------
940 procedure Build_Activation_Chain_Entity (N : Node_Id) is
941 function Has_Activation_Chain (Stmt : Node_Id) return Boolean;
942 -- Determine whether an extended return statement has activation chain
944 --------------------------
945 -- Has_Activation_Chain --
946 --------------------------
948 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is
952 Decl := First (Return_Object_Declarations (Stmt));
953 while Present (Decl) loop
954 if Nkind (Decl) = N_Object_Declaration
955 and then Chars (Defining_Identifier (Decl)) = Name_uChain
964 end Has_Activation_Chain;
969 Context_Id : Entity_Id;
972 -- Start of processing for Build_Activation_Chain_Entity
975 -- No action needed if the run-time has no tasking support
977 if Global_No_Tasking then
981 -- Activation chain is never used for sequential elaboration policy, see
982 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
984 if Partition_Elaboration_Policy = 'S' then
988 Find_Enclosing_Context (N, Context, Context_Id, Decls);
990 -- If activation chain entity has not been declared already, create one
992 if Nkind (Context) = N_Extended_Return_Statement
993 or else No (Activation_Chain_Entity (Context))
995 -- Since extended return statements do not store the entity of the
996 -- chain, examine the return object declarations to avoid creating
999 if Nkind (Context) = N_Extended_Return_Statement
1000 and then Has_Activation_Chain (Context)
1006 Loc : constant Source_Ptr := Sloc (Context);
1011 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
1013 -- Note: An extended return statement is not really a task
1014 -- activator, but it does have an activation chain on which to
1015 -- store the tasks temporarily. On successful return, the tasks
1016 -- on this chain are moved to the chain passed in by the caller.
1017 -- We do not build an Activation_Chain_Entity for an extended
1018 -- return statement, because we do not want to build a call to
1019 -- Activate_Tasks. Task activation is the responsibility of the
1022 if Nkind (Context) /= N_Extended_Return_Statement then
1023 Set_Activation_Chain_Entity (Context, Chain);
1027 Make_Object_Declaration (Loc,
1028 Defining_Identifier => Chain,
1029 Aliased_Present => True,
1030 Object_Definition =>
1031 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc));
1033 Prepend_To (Decls, Decl);
1035 -- Ensure that _chain appears in the proper scope of the context
1037 if Context_Id /= Current_Scope then
1038 Push_Scope (Context_Id);
1046 end Build_Activation_Chain_Entity;
1048 ----------------------------
1049 -- Build_Barrier_Function --
1050 ----------------------------
1052 function Build_Barrier_Function
1055 Pid : Entity_Id) return Node_Id
1057 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
1058 Cond : constant Node_Id := Condition (Ent_Formals);
1059 Loc : constant Source_Ptr := Sloc (Cond);
1060 Func_Id : constant Entity_Id := Barrier_Function (Ent);
1061 Op_Decls : constant List_Id := New_List;
1063 Func_Body : Node_Id;
1066 -- Add a declaration for the Protection object, renaming declarations
1067 -- for the discriminals and privals and finally a declaration for the
1068 -- entry family index (if applicable).
1070 Install_Private_Data_Declarations (Sloc (N),
1076 Family => Ekind (Ent) = E_Entry_Family);
1078 -- If compiling with -fpreserve-control-flow, make sure we insert an
1079 -- IF statement so that the back-end knows to generate a conditional
1080 -- branch instruction, even if the condition is just the name of a
1081 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1082 -- such redundant IF statements under -fpreserve-control-flow
1083 -- (whether coming from this routine, or directly from source).
1085 if Opt.Suppress_Control_Flow_Optimizations then
1087 Make_Implicit_If_Statement (Cond,
1089 Then_Statements => New_List (
1090 Make_Simple_Return_Statement (Loc,
1091 New_Occurrence_Of (Standard_True, Loc))),
1093 Else_Statements => New_List (
1094 Make_Simple_Return_Statement (Loc,
1095 New_Occurrence_Of (Standard_False, Loc))));
1098 Stmt := Make_Simple_Return_Statement (Loc, Cond);
1101 -- Note: the condition in the barrier function needs to be properly
1102 -- processed for the C/Fortran boolean possibility, but this happens
1103 -- automatically since the return statement does this normalization.
1106 Make_Subprogram_Body (Loc,
1108 Build_Barrier_Function_Specification (Loc,
1109 Make_Defining_Identifier (Loc, Chars (Func_Id))),
1110 Declarations => Op_Decls,
1111 Handled_Statement_Sequence =>
1112 Make_Handled_Sequence_Of_Statements (Loc,
1113 Statements => New_List (Stmt)));
1114 Set_Is_Entry_Barrier_Function (Func_Body);
1117 end Build_Barrier_Function;
1119 ------------------------------------------
1120 -- Build_Barrier_Function_Specification --
1121 ------------------------------------------
1123 function Build_Barrier_Function_Specification
1125 Def_Id : Entity_Id) return Node_Id
1128 Set_Debug_Info_Needed (Def_Id);
1131 Make_Function_Specification (Loc,
1132 Defining_Unit_Name => Def_Id,
1133 Parameter_Specifications => New_List (
1134 Make_Parameter_Specification (Loc,
1135 Defining_Identifier =>
1136 Make_Defining_Identifier (Loc, Name_uO),
1138 New_Occurrence_Of (RTE (RE_Address), Loc)),
1140 Make_Parameter_Specification (Loc,
1141 Defining_Identifier =>
1142 Make_Defining_Identifier (Loc, Name_uE),
1144 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
1146 Result_Definition =>
1147 New_Occurrence_Of (Standard_Boolean, Loc));
1148 end Build_Barrier_Function_Specification;
1150 --------------------------
1151 -- Build_Call_With_Task --
1152 --------------------------
1154 function Build_Call_With_Task
1156 E : Entity_Id) return Node_Id
1158 Loc : constant Source_Ptr := Sloc (N);
1161 Make_Function_Call (Loc,
1162 Name => New_Occurrence_Of (E, Loc),
1163 Parameter_Associations => New_List (Concurrent_Ref (N)));
1164 end Build_Call_With_Task;
1166 -----------------------------
1167 -- Build_Class_Wide_Master --
1168 -----------------------------
1170 procedure Build_Class_Wide_Master (Typ : Entity_Id) is
1171 Loc : constant Source_Ptr := Sloc (Typ);
1172 Master_Decl : Node_Id;
1173 Master_Id : Entity_Id;
1174 Master_Scope : Entity_Id;
1176 Related_Node : Node_Id;
1180 -- No action needed if the run-time has no tasking support
1182 if Global_No_Tasking then
1186 -- Find the declaration that created the access type, which is either a
1187 -- type declaration, or an object declaration with an access definition,
1188 -- in which case the type is anonymous.
1190 if Is_Itype (Typ) then
1191 Related_Node := Associated_Node_For_Itype (Typ);
1193 Related_Node := Parent (Typ);
1196 Master_Scope := Find_Master_Scope (Typ);
1198 -- Nothing to do if the master scope already contains a _master entity.
1199 -- The only exception to this is the following scenario:
1202 -- Transient_Scope_1
1205 -- Transient_Scope_2
1208 -- In this case the source scope is marked as having the master entity
1209 -- even though the actual declaration appears inside an inner scope. If
1210 -- the second transient scope requires a _master, it cannot use the one
1211 -- already declared because the entity is not visible.
1213 Name_Id := Make_Identifier (Loc, Name_uMaster);
1214 Master_Decl := Empty;
1216 if not Has_Master_Entity (Master_Scope)
1217 or else No (Current_Entity_In_Scope (Name_Id))
1223 Set_Has_Master_Entity (Master_Scope);
1224 Master_Decl := Build_Master_Declaration (Loc);
1226 -- Ensure that the master declaration is placed before its use
1228 Ins_Nod := Find_Hook_Context (Related_Node);
1229 while not Is_List_Member (Ins_Nod) loop
1230 Ins_Nod := Parent (Ins_Nod);
1233 Insert_Before (First (List_Containing (Ins_Nod)), Master_Decl);
1234 Analyze (Master_Decl);
1236 -- Mark the containing scope as a task master. Masters associated
1237 -- with return statements are already marked at this stage (see
1238 -- Analyze_Subprogram_Body).
1240 if Ekind (Current_Scope) /= E_Return_Statement then
1242 Par : Node_Id := Related_Node;
1245 while Nkind (Par) /= N_Compilation_Unit loop
1246 Par := Parent (Par);
1248 -- If we fall off the top, we are at the outer level,
1249 -- and the environment task is our effective master,
1250 -- so nothing to mark.
1253 N_Block_Statement | N_Subprogram_Body | N_Task_Body
1255 Set_Is_Task_Master (Par);
1265 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M'));
1268 -- typeMnn renames _master;
1271 Make_Object_Renaming_Declaration (Loc,
1272 Defining_Identifier => Master_Id,
1273 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
1276 -- If the master is declared locally, add the renaming declaration
1277 -- immediately after it, to prevent access-before-elaboration in the
1280 if Present (Master_Decl) then
1281 Insert_After (Master_Decl, Ren_Decl);
1285 Insert_Action (Related_Node, Ren_Decl);
1288 Set_Master_Id (Typ, Master_Id);
1289 end Build_Class_Wide_Master;
1291 ----------------------------
1292 -- Build_Contract_Wrapper --
1293 ----------------------------
1295 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is
1296 Conc_Typ : constant Entity_Id := Scope (E);
1297 Loc : constant Source_Ptr := Sloc (E);
1299 procedure Add_Discriminant_Renamings
1300 (Obj_Id : Entity_Id;
1302 -- Add renaming declarations for all discriminants of concurrent type
1303 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1304 -- represents the concurrent object.
1306 procedure Add_Matching_Formals
1308 Actuals : in out List_Id);
1309 -- Add formal parameters that match those of entry E to list Formals.
1310 -- The routine also adds matching actuals for the new formals to list
1313 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id);
1314 -- Relocate pragma Prag to list To. The routine creates a new list if
1315 -- To does not exist.
1317 --------------------------------
1318 -- Add_Discriminant_Renamings --
1319 --------------------------------
1321 procedure Add_Discriminant_Renamings
1322 (Obj_Id : Entity_Id;
1328 -- Inspect the discriminants of the concurrent type and generate a
1329 -- renaming for each one.
1331 if Has_Discriminants (Conc_Typ) then
1332 Discr := First_Discriminant (Conc_Typ);
1333 while Present (Discr) loop
1335 Make_Object_Renaming_Declaration (Loc,
1336 Defining_Identifier =>
1337 Make_Defining_Identifier (Loc, Chars (Discr)),
1339 New_Occurrence_Of (Etype (Discr), Loc),
1341 Make_Selected_Component (Loc,
1342 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1344 Make_Identifier (Loc, Chars (Discr)))));
1346 Next_Discriminant (Discr);
1349 end Add_Discriminant_Renamings;
1351 --------------------------
1352 -- Add_Matching_Formals --
1353 --------------------------
1355 procedure Add_Matching_Formals
1357 Actuals : in out List_Id)
1360 New_Formal : Entity_Id;
1363 -- Inspect the formal parameters of the entry and generate a new
1364 -- matching formal with the same name for the wrapper. A reference
1365 -- to the new formal becomes an actual in the entry call.
1367 Formal := First_Formal (E);
1368 while Present (Formal) loop
1369 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal));
1371 Make_Parameter_Specification (Loc,
1372 Defining_Identifier => New_Formal,
1373 In_Present => In_Present (Parent (Formal)),
1374 Out_Present => Out_Present (Parent (Formal)),
1376 New_Occurrence_Of (Etype (Formal), Loc)));
1378 if No (Actuals) then
1379 Actuals := New_List;
1382 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
1383 Next_Formal (Formal);
1385 end Add_Matching_Formals;
1387 ---------------------
1388 -- Transfer_Pragma --
1389 ---------------------
1391 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is
1399 New_Prag := Relocate_Node (Prag);
1401 Set_Analyzed (New_Prag, False);
1402 Append (New_Prag, To);
1403 end Transfer_Pragma;
1407 Items : constant Node_Id := Contract (E);
1408 Actuals : List_Id := No_List;
1411 Decls : List_Id := No_List;
1413 Has_Pragma : Boolean := False;
1414 Index_Id : Entity_Id;
1417 Wrapper_Id : Entity_Id;
1419 -- Start of processing for Build_Contract_Wrapper
1422 -- This routine generates a specialized wrapper for a protected or task
1423 -- entry [family] which implements precondition/postcondition semantics.
1424 -- Preconditions and case guards of contract cases are checked before
1425 -- the protected action or rendezvous takes place. Postconditions and
1426 -- consequences of contract cases are checked after the protected action
1427 -- or rendezvous takes place. The structure of the generated wrapper is
1430 -- procedure Wrapper
1431 -- (Obj_Id : Conc_Typ; -- concurrent object
1432 -- [Index : Index_Typ;] -- index of entry family
1433 -- [Formal_1 : ...; -- parameters of original entry
1436 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1437 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1439 -- <precondition checks>
1440 -- <case guard checks>
1442 -- procedure _Postconditions is
1444 -- <postcondition checks>
1445 -- <consequence checks>
1446 -- end _Postconditions;
1449 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1453 -- Create the wrapper only when the entry has at least one executable
1454 -- contract item such as contract cases, precondition or postcondition.
1456 if Present (Items) then
1458 -- Inspect the list of pre/postconditions and transfer all available
1459 -- pragmas to the declarative list of the wrapper.
1461 Prag := Pre_Post_Conditions (Items);
1462 while Present (Prag) loop
1463 if Pragma_Name_Unmapped (Prag) in Name_Postcondition
1465 and then Is_Checked (Prag)
1468 Transfer_Pragma (Prag, To => Decls);
1471 Prag := Next_Pragma (Prag);
1474 -- Inspect the list of test/contract cases and transfer only contract
1475 -- cases pragmas to the declarative part of the wrapper.
1477 Prag := Contract_Test_Cases (Items);
1478 while Present (Prag) loop
1479 if Pragma_Name (Prag) = Name_Contract_Cases
1480 and then Is_Checked (Prag)
1483 Transfer_Pragma (Prag, To => Decls);
1486 Prag := Next_Pragma (Prag);
1490 -- The entry lacks executable contract items and a wrapper is not needed
1492 if not Has_Pragma then
1496 -- Create the profile of the wrapper. The first formal parameter is the
1497 -- concurrent object.
1500 Make_Defining_Identifier (Loc,
1501 Chars => New_External_Name (Chars (Conc_Typ), 'A'));
1503 Formals := New_List (
1504 Make_Parameter_Specification (Loc,
1505 Defining_Identifier => Obj_Id,
1506 Out_Present => True,
1508 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc)));
1510 -- Construct the call to the original entry. The call will be gradually
1511 -- augmented with an optional entry index and extra parameters.
1514 Make_Selected_Component (Loc,
1515 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1516 Selector_Name => New_Occurrence_Of (E, Loc));
1518 -- When creating a wrapper for an entry family, the second formal is the
1521 if Ekind (E) = E_Entry_Family then
1522 Index_Id := Make_Defining_Identifier (Loc, Name_I);
1525 Make_Parameter_Specification (Loc,
1526 Defining_Identifier => Index_Id,
1528 New_Occurrence_Of (Entry_Index_Type (E), Loc)));
1530 -- The call to the original entry becomes an indexed component to
1531 -- accommodate the entry index.
1534 Make_Indexed_Component (Loc,
1536 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc)));
1539 -- Add formal parameters to match those of the entry and build actuals
1540 -- for the entry call.
1542 Add_Matching_Formals (Formals, Actuals);
1545 Make_Procedure_Call_Statement (Loc,
1547 Parameter_Associations => Actuals);
1549 -- Add renaming declarations for the discriminants of the enclosing type
1550 -- as the various contract items may reference them.
1552 Add_Discriminant_Renamings (Obj_Id, Decls);
1555 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E'));
1556 Set_Contract_Wrapper (E, Wrapper_Id);
1557 Set_Is_Entry_Wrapper (Wrapper_Id);
1559 -- The wrapper body is analyzed when the enclosing type is frozen
1561 Append_Freeze_Action (Defining_Entity (Decl),
1562 Make_Subprogram_Body (Loc,
1564 Make_Procedure_Specification (Loc,
1565 Defining_Unit_Name => Wrapper_Id,
1566 Parameter_Specifications => Formals),
1567 Declarations => Decls,
1568 Handled_Statement_Sequence =>
1569 Make_Handled_Sequence_Of_Statements (Loc,
1570 Statements => New_List (Call))));
1571 end Build_Contract_Wrapper;
1573 --------------------------------
1574 -- Build_Corresponding_Record --
1575 --------------------------------
1577 function Build_Corresponding_Record
1580 Loc : Source_Ptr) return Node_Id
1582 Rec_Ent : constant Entity_Id :=
1583 Make_Defining_Identifier
1584 (Loc, New_External_Name (Chars (Ctyp), 'V'));
1587 New_Disc : Entity_Id;
1591 Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
1592 Set_Ekind (Rec_Ent, E_Record_Type);
1593 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
1594 Set_Is_Concurrent_Record_Type (Rec_Ent, True);
1595 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
1596 Set_Stored_Constraint (Rec_Ent, No_Elist);
1599 -- Use discriminals to create list of discriminants for record, and
1600 -- create new discriminals for use in default expressions, etc. It is
1601 -- worth noting that a task discriminant gives rise to 5 entities;
1603 -- a) The original discriminant.
1604 -- b) The discriminal for use in the task.
1605 -- c) The discriminant of the corresponding record.
1606 -- d) The discriminal for the init proc of the corresponding record.
1607 -- e) The local variable that renames the discriminant in the procedure
1608 -- for the task body.
1610 -- In fact the discriminals b) are used in the renaming declarations
1611 -- for e). See details in einfo (Handling of Discriminants).
1613 if Present (Discriminant_Specifications (N)) then
1615 Disc := First_Discriminant (Ctyp);
1617 while Present (Disc) loop
1618 New_Disc := CR_Discriminant (Disc);
1621 Make_Discriminant_Specification (Loc,
1622 Defining_Identifier => New_Disc,
1623 Discriminant_Type =>
1624 New_Occurrence_Of (Etype (Disc), Loc),
1626 New_Copy (Discriminant_Default_Value (Disc))));
1628 Next_Discriminant (Disc);
1635 -- Now we can construct the record type declaration. Note that this
1636 -- record is "limited tagged". It is "limited" to reflect the underlying
1637 -- limitedness of the task or protected object that it represents, and
1638 -- ensuring for example that it is properly passed by reference. It is
1639 -- "tagged" to give support to dispatching calls through interfaces. We
1640 -- propagate here the list of interfaces covered by the concurrent type
1641 -- (Ada 2005: AI-345).
1644 Make_Full_Type_Declaration (Loc,
1645 Defining_Identifier => Rec_Ent,
1646 Discriminant_Specifications => Dlist,
1648 Make_Record_Definition (Loc,
1650 Make_Component_List (Loc, Component_Items => Cdecls),
1652 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp),
1653 Interface_List => Interface_List (N),
1654 Limited_Present => True));
1655 end Build_Corresponding_Record;
1657 ---------------------------------
1658 -- Build_Dispatching_Tag_Check --
1659 ---------------------------------
1661 function Build_Dispatching_Tag_Check
1663 N : Node_Id) return Node_Id
1665 Loc : constant Source_Ptr := Sloc (N);
1672 New_Occurrence_Of (K, Loc),
1674 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)),
1678 New_Occurrence_Of (K, Loc),
1680 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc)));
1681 end Build_Dispatching_Tag_Check;
1683 ----------------------------------
1684 -- Build_Entry_Count_Expression --
1685 ----------------------------------
1687 function Build_Entry_Count_Expression
1688 (Concurrent_Type : Node_Id;
1689 Component_List : List_Id;
1690 Loc : Source_Ptr) return Node_Id
1702 -- Count number of non-family entries
1705 Ent := First_Entity (Concurrent_Type);
1706 while Present (Ent) loop
1707 if Ekind (Ent) = E_Entry then
1714 Ecount := Make_Integer_Literal (Loc, Eindx);
1716 -- Loop through entry families building the addition nodes
1718 Ent := First_Entity (Concurrent_Type);
1719 Comp := First (Component_List);
1720 while Present (Ent) loop
1721 if Ekind (Ent) = E_Entry_Family then
1722 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
1726 Typ := Entry_Index_Type (Ent);
1727 Hi := Type_High_Bound (Typ);
1728 Lo := Type_Low_Bound (Typ);
1729 Large := Is_Potentially_Large_Family
1730 (Base_Type (Typ), Concurrent_Type, Lo, Hi);
1733 Left_Opnd => Ecount,
1735 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large));
1742 end Build_Entry_Count_Expression;
1744 ------------------------------
1745 -- Build_Master_Declaration --
1746 ------------------------------
1748 function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id is
1749 Master_Decl : Node_Id;
1752 -- Generate a dummy master if tasks or tasking hierarchies are
1755 -- _Master : constant Master_Id := 3;
1757 if not Tasking_Allowed
1758 or else Restrictions.Set (No_Task_Hierarchy)
1759 or else not RTE_Available (RE_Current_Master)
1765 -- RE_Library_Task_Level is not always available in configurable
1768 if not RTE_Available (RE_Library_Task_Level) then
1769 Expr := Make_Integer_Literal (Loc, Uint_3);
1771 Expr := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc);
1775 Make_Object_Declaration (Loc,
1776 Defining_Identifier =>
1777 Make_Defining_Identifier (Loc, Name_uMaster),
1778 Constant_Present => True,
1779 Object_Definition =>
1780 New_Occurrence_Of (Standard_Integer, Loc),
1781 Expression => Expr);
1785 -- _master : constant Integer := Current_Master.all;
1789 Make_Object_Declaration (Loc,
1790 Defining_Identifier =>
1791 Make_Defining_Identifier (Loc, Name_uMaster),
1792 Constant_Present => True,
1793 Object_Definition =>
1794 New_Occurrence_Of (Standard_Integer, Loc),
1796 Make_Explicit_Dereference (Loc,
1797 New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
1801 end Build_Master_Declaration;
1803 ---------------------------
1804 -- Build_Parameter_Block --
1805 ---------------------------
1807 function Build_Parameter_Block
1811 Decls : List_Id) return Entity_Id
1817 Has_Comp : Boolean := False;
1821 Actual := First (Actuals);
1823 Formal := Defining_Identifier (First (Formals));
1825 while Present (Actual) loop
1826 if not Is_Controlling_Actual (Actual) then
1829 -- type Ann is access all <actual-type>
1831 Comp_Nam := Make_Temporary (Loc, 'A');
1832 Set_Is_Param_Block_Component_Type (Comp_Nam);
1835 Make_Full_Type_Declaration (Loc,
1836 Defining_Identifier => Comp_Nam,
1838 Make_Access_To_Object_Definition (Loc,
1839 All_Present => True,
1840 Constant_Present => Ekind (Formal) = E_In_Parameter,
1841 Subtype_Indication =>
1842 New_Occurrence_Of (Etype (Actual), Loc))));
1848 Make_Component_Declaration (Loc,
1849 Defining_Identifier =>
1850 Make_Defining_Identifier (Loc, Chars (Formal)),
1851 Component_Definition =>
1852 Make_Component_Definition (Loc,
1855 Subtype_Indication =>
1856 New_Occurrence_Of (Comp_Nam, Loc))));
1861 Next_Actual (Actual);
1862 Next_Formal_With_Extras (Formal);
1865 Rec_Nam := Make_Temporary (Loc, 'P');
1870 -- type Pnn is record
1875 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1876 -- the original parameter names and Ann1 .. AnnN are the access to
1880 Make_Full_Type_Declaration (Loc,
1881 Defining_Identifier =>
1884 Make_Record_Definition (Loc,
1886 Make_Component_List (Loc, Comps))));
1889 -- type Pnn is null record;
1892 Make_Full_Type_Declaration (Loc,
1893 Defining_Identifier =>
1896 Make_Record_Definition (Loc,
1897 Null_Present => True,
1898 Component_List => Empty)));
1902 end Build_Parameter_Block;
1904 --------------------------------------
1905 -- Build_Renamed_Formal_Declaration --
1906 --------------------------------------
1908 function Build_Renamed_Formal_Declaration
1912 Renamed_Formal : Node_Id) return Node_Id
1914 Loc : constant Source_Ptr := Sloc (New_F);
1918 -- If the formal is a tagged incomplete type, it is already passed
1919 -- by reference, so it is sufficient to rename the pointer component
1920 -- that corresponds to the actual. Otherwise we need to dereference
1921 -- the pointer component to obtain the actual.
1923 if Is_Incomplete_Type (Etype (Formal))
1924 and then Is_Tagged_Type (Etype (Formal))
1927 Make_Object_Renaming_Declaration (Loc,
1928 Defining_Identifier => New_F,
1929 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc),
1930 Name => Renamed_Formal);
1934 Make_Object_Renaming_Declaration (Loc,
1935 Defining_Identifier => New_F,
1936 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc),
1938 Make_Explicit_Dereference (Loc, Renamed_Formal));
1942 end Build_Renamed_Formal_Declaration;
1944 --------------------------
1945 -- Build_Wrapper_Bodies --
1946 --------------------------
1948 procedure Build_Wrapper_Bodies
1953 Rec_Typ : Entity_Id;
1955 function Build_Wrapper_Body
1957 Subp_Id : Entity_Id;
1958 Obj_Typ : Entity_Id;
1959 Formals : List_Id) return Node_Id;
1960 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1961 -- associated with a protected or task type. Subp_Id is the subprogram
1962 -- name which will be wrapped. Obj_Typ is the type of the new formal
1963 -- parameter which handles dispatching and object notation. Formals are
1964 -- the original formals of Subp_Id which will be explicitly replicated.
1966 ------------------------
1967 -- Build_Wrapper_Body --
1968 ------------------------
1970 function Build_Wrapper_Body
1972 Subp_Id : Entity_Id;
1973 Obj_Typ : Entity_Id;
1974 Formals : List_Id) return Node_Id
1976 Body_Spec : Node_Id;
1979 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals);
1981 -- The subprogram is not overriding or is not a primitive declared
1982 -- between two views.
1984 if No (Body_Spec) then
1989 Actuals : List_Id := No_List;
1991 First_Form : Node_Id;
1996 -- Map formals to actuals. Use the list built for the wrapper
1997 -- spec, skipping the object notation parameter.
1999 First_Form := First (Parameter_Specifications (Body_Spec));
2001 Formal := First_Form;
2004 if Present (Formal) then
2005 Actuals := New_List;
2006 while Present (Formal) loop
2008 Make_Identifier (Loc,
2009 Chars => Chars (Defining_Identifier (Formal))));
2014 -- Special processing for primitives declared between a private
2015 -- type and its completion: the wrapper needs a properly typed
2016 -- parameter if the wrapped operation has a controlling first
2017 -- parameter. Note that this might not be the case for a function
2018 -- with a controlling result.
2020 if Is_Private_Primitive_Subprogram (Subp_Id) then
2021 if No (Actuals) then
2022 Actuals := New_List;
2025 if Is_Controlling_Formal (First_Formal (Subp_Id)) then
2026 Prepend_To (Actuals,
2027 Unchecked_Convert_To
2028 (Corresponding_Concurrent_Type (Obj_Typ),
2029 Make_Identifier (Loc, Name_uO)));
2032 Prepend_To (Actuals,
2033 Make_Identifier (Loc,
2034 Chars => Chars (Defining_Identifier (First_Form))));
2037 Nam := New_Occurrence_Of (Subp_Id, Loc);
2039 -- An access-to-variable object parameter requires an explicit
2040 -- dereference in the unchecked conversion. This case occurs
2041 -- when a protected entry wrapper must override an interface
2042 -- level procedure with interface access as first parameter.
2044 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
2046 if Nkind (Parameter_Type (First_Form)) =
2050 Make_Explicit_Dereference (Loc,
2051 Prefix => Make_Identifier (Loc, Name_uO));
2053 Conv_Id := Make_Identifier (Loc, Name_uO);
2057 Make_Selected_Component (Loc,
2059 Unchecked_Convert_To
2060 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id),
2061 Selector_Name => New_Occurrence_Of (Subp_Id, Loc));
2064 -- Create the subprogram body. For a function, the call to the
2065 -- actual subprogram has to be converted to the corresponding
2066 -- record if it is a controlling result.
2068 if Ekind (Subp_Id) = E_Function then
2074 Make_Function_Call (Loc,
2076 Parameter_Associations => Actuals);
2078 if Has_Controlling_Result (Subp_Id) then
2080 Unchecked_Convert_To
2081 (Corresponding_Record_Type (Etype (Subp_Id)), Res);
2085 Make_Subprogram_Body (Loc,
2086 Specification => Body_Spec,
2087 Declarations => Empty_List,
2088 Handled_Statement_Sequence =>
2089 Make_Handled_Sequence_Of_Statements (Loc,
2090 Statements => New_List (
2091 Make_Simple_Return_Statement (Loc, Res))));
2096 Make_Subprogram_Body (Loc,
2097 Specification => Body_Spec,
2098 Declarations => Empty_List,
2099 Handled_Statement_Sequence =>
2100 Make_Handled_Sequence_Of_Statements (Loc,
2101 Statements => New_List (
2102 Make_Procedure_Call_Statement (Loc,
2104 Parameter_Associations => Actuals))));
2107 end Build_Wrapper_Body;
2109 -- Start of processing for Build_Wrapper_Bodies
2112 if Is_Concurrent_Type (Typ) then
2113 Rec_Typ := Corresponding_Record_Type (Typ);
2118 -- Generate wrapper bodies for a concurrent type which implements an
2121 if Present (Interfaces (Rec_Typ)) then
2123 Insert_Nod : Node_Id;
2125 Prim_Elmt : Elmt_Id;
2126 Prim_Decl : Node_Id;
2128 Wrap_Body : Node_Id;
2129 Wrap_Id : Entity_Id;
2134 -- Examine all primitive operations of the corresponding record
2135 -- type, looking for wrapper specs. Generate bodies in order to
2138 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ));
2139 while Present (Prim_Elmt) loop
2140 Prim := Node (Prim_Elmt);
2142 if (Ekind (Prim) = E_Function
2143 or else Ekind (Prim) = E_Procedure)
2144 and then Is_Primitive_Wrapper (Prim)
2146 Subp := Wrapped_Entity (Prim);
2147 Prim_Decl := Parent (Parent (Prim));
2150 Build_Wrapper_Body (Loc,
2153 Formals => Parameter_Specifications (Parent (Subp)));
2154 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body));
2156 Set_Corresponding_Spec (Wrap_Body, Prim);
2157 Set_Corresponding_Body (Prim_Decl, Wrap_Id);
2159 Insert_After (Insert_Nod, Wrap_Body);
2160 Insert_Nod := Wrap_Body;
2162 Analyze (Wrap_Body);
2165 Next_Elmt (Prim_Elmt);
2169 end Build_Wrapper_Bodies;
2171 ------------------------
2172 -- Build_Wrapper_Spec --
2173 ------------------------
2175 function Build_Wrapper_Spec
2176 (Subp_Id : Entity_Id;
2177 Obj_Typ : Entity_Id;
2178 Formals : List_Id) return Node_Id
2180 function Overriding_Possible
2181 (Iface_Op : Entity_Id;
2182 Wrapper : Entity_Id) return Boolean;
2183 -- Determine whether a primitive operation can be overridden by Wrapper.
2184 -- Iface_Op is the candidate primitive operation of an interface type,
2185 -- Wrapper is the generated entry wrapper.
2187 function Replicate_Formals
2189 Formals : List_Id) return List_Id;
2190 -- An explicit parameter replication is required due to the Is_Entry_
2191 -- Formal flag being set for all the formals of an entry. The explicit
2192 -- replication removes the flag that would otherwise cause a different
2193 -- path of analysis.
2195 -------------------------
2196 -- Overriding_Possible --
2197 -------------------------
2199 function Overriding_Possible
2200 (Iface_Op : Entity_Id;
2201 Wrapper : Entity_Id) return Boolean
2203 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op);
2204 Wrapper_Spec : constant Node_Id := Parent (Wrapper);
2206 function Type_Conformant_Parameters
2207 (Iface_Op_Params : List_Id;
2208 Wrapper_Params : List_Id) return Boolean;
2209 -- Determine whether the parameters of the generated entry wrapper
2210 -- and those of a primitive operation are type conformant. During
2211 -- this check, the first parameter of the primitive operation is
2212 -- skipped if it is a controlling argument: protected functions
2213 -- may have a controlling result.
2215 --------------------------------
2216 -- Type_Conformant_Parameters --
2217 --------------------------------
2219 function Type_Conformant_Parameters
2220 (Iface_Op_Params : List_Id;
2221 Wrapper_Params : List_Id) return Boolean
2223 Iface_Op_Param : Node_Id;
2224 Iface_Op_Typ : Entity_Id;
2225 Wrapper_Param : Node_Id;
2226 Wrapper_Typ : Entity_Id;
2229 -- Skip the first (controlling) parameter of primitive operation
2231 Iface_Op_Param := First (Iface_Op_Params);
2233 if Present (First_Formal (Iface_Op))
2234 and then Is_Controlling_Formal (First_Formal (Iface_Op))
2236 Next (Iface_Op_Param);
2239 Wrapper_Param := First (Wrapper_Params);
2240 while Present (Iface_Op_Param)
2241 and then Present (Wrapper_Param)
2243 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param);
2244 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param);
2246 -- The two parameters must be mode conformant
2248 if not Conforming_Types
2249 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant)
2254 Next (Iface_Op_Param);
2255 Next (Wrapper_Param);
2258 -- One of the lists is longer than the other
2260 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then
2265 end Type_Conformant_Parameters;
2267 -- Start of processing for Overriding_Possible
2270 if Chars (Iface_Op) /= Chars (Wrapper) then
2274 -- If an inherited subprogram is implemented by a protected procedure
2275 -- or an entry, then the first parameter of the inherited subprogram
2276 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2278 if Ekind (Iface_Op) = E_Procedure
2279 and then Present (Parameter_Specifications (Iface_Op_Spec))
2282 Obj_Param : constant Node_Id :=
2283 First (Parameter_Specifications (Iface_Op_Spec));
2285 if not Out_Present (Obj_Param)
2286 and then Nkind (Parameter_Type (Obj_Param)) /=
2295 Type_Conformant_Parameters
2296 (Parameter_Specifications (Iface_Op_Spec),
2297 Parameter_Specifications (Wrapper_Spec));
2298 end Overriding_Possible;
2300 -----------------------
2301 -- Replicate_Formals --
2302 -----------------------
2304 function Replicate_Formals
2306 Formals : List_Id) return List_Id
2308 New_Formals : constant List_Id := New_List;
2310 Param_Type : Node_Id;
2313 Formal := First (Formals);
2315 -- Skip the object parameter when dealing with primitives declared
2316 -- between two views.
2318 if Is_Private_Primitive_Subprogram (Subp_Id)
2319 and then not Has_Controlling_Result (Subp_Id)
2324 while Present (Formal) loop
2326 -- Create an explicit copy of the entry parameter
2328 -- When creating the wrapper subprogram for a primitive operation
2329 -- of a protected interface we must construct an equivalent
2330 -- signature to that of the overriding operation. For regular
2331 -- parameters we can just use the type of the formal, but for
2332 -- access to subprogram parameters we need to reanalyze the
2333 -- parameter type to create local entities for the signature of
2334 -- the subprogram type. Using the entities of the overriding
2335 -- subprogram will result in out-of-scope errors in the back-end.
2337 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then
2338 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal));
2341 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc);
2344 Append_To (New_Formals,
2345 Make_Parameter_Specification (Loc,
2346 Defining_Identifier =>
2347 Make_Defining_Identifier (Loc,
2348 Chars => Chars (Defining_Identifier (Formal))),
2349 In_Present => In_Present (Formal),
2350 Out_Present => Out_Present (Formal),
2351 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
2352 Parameter_Type => Param_Type));
2358 end Replicate_Formals;
2362 Loc : constant Source_Ptr := Sloc (Subp_Id);
2363 First_Param : Node_Id := Empty;
2365 Iface_Elmt : Elmt_Id;
2366 Iface_Op : Entity_Id;
2367 Iface_Op_Elmt : Elmt_Id;
2368 Overridden_Subp : Entity_Id;
2370 -- Start of processing for Build_Wrapper_Spec
2373 -- No point in building wrappers for untagged concurrent types
2375 pragma Assert (Is_Tagged_Type (Obj_Typ));
2377 -- Check if this subprogram has a profile that matches some interface
2380 Check_Synchronized_Overriding (Subp_Id, Overridden_Subp);
2382 if Present (Overridden_Subp) then
2384 First (Parameter_Specifications (Parent (Overridden_Subp)));
2386 -- An entry or a protected procedure can override a routine where the
2387 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2388 -- type. Since the wrapper must have the exact same signature as that of
2389 -- the overridden subprogram, we try to find the overriding candidate
2390 -- and use its controlling formal.
2392 -- Check every implemented interface
2394 elsif Present (Interfaces (Obj_Typ)) then
2395 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
2396 Search : while Present (Iface_Elmt) loop
2397 Iface := Node (Iface_Elmt);
2399 -- Check every interface primitive
2401 if Present (Primitive_Operations (Iface)) then
2402 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
2403 while Present (Iface_Op_Elmt) loop
2404 Iface_Op := Node (Iface_Op_Elmt);
2406 -- Ignore predefined primitives
2408 if not Is_Predefined_Dispatching_Operation (Iface_Op) then
2409 Iface_Op := Ultimate_Alias (Iface_Op);
2411 -- The current primitive operation can be overridden by
2412 -- the generated entry wrapper.
2414 if Overriding_Possible (Iface_Op, Subp_Id) then
2416 First (Parameter_Specifications (Parent (Iface_Op)));
2422 Next_Elmt (Iface_Op_Elmt);
2426 Next_Elmt (Iface_Elmt);
2430 -- Do not generate the wrapper if no interface primitive is covered by
2431 -- the subprogram and it is not a primitive declared between two views
2432 -- (see Process_Full_View).
2435 and then not Is_Private_Primitive_Subprogram (Subp_Id)
2441 Wrapper_Id : constant Entity_Id :=
2442 Make_Defining_Identifier (Loc, Chars (Subp_Id));
2443 New_Formals : List_Id;
2444 Obj_Param : Node_Id;
2445 Obj_Param_Typ : Entity_Id;
2448 -- Minimum decoration is needed to catch the entity in
2449 -- Sem_Ch6.Override_Dispatching_Operation.
2451 if Ekind (Subp_Id) = E_Function then
2452 Set_Ekind (Wrapper_Id, E_Function);
2454 Set_Ekind (Wrapper_Id, E_Procedure);
2457 Set_Is_Primitive_Wrapper (Wrapper_Id);
2458 Set_Wrapped_Entity (Wrapper_Id, Subp_Id);
2459 Set_Is_Private_Primitive (Wrapper_Id,
2460 Is_Private_Primitive_Subprogram (Subp_Id));
2462 -- Process the formals
2464 New_Formals := Replicate_Formals (Loc, Formals);
2466 -- A function with a controlling result and no first controlling
2467 -- formal needs no additional parameter.
2469 if Has_Controlling_Result (Subp_Id)
2471 (No (First_Formal (Subp_Id))
2472 or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
2476 -- Routine Subp_Id has been found to override an interface primitive.
2477 -- If the interface operation has an access parameter, create a copy
2478 -- of it, with the same null exclusion indicator if present.
2480 elsif Present (First_Param) then
2481 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
2483 Make_Access_Definition (Loc,
2485 New_Occurrence_Of (Obj_Typ, Loc),
2486 Null_Exclusion_Present =>
2487 Null_Exclusion_Present (Parameter_Type (First_Param)),
2489 Constant_Present (Parameter_Type (First_Param)));
2491 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc);
2495 Make_Parameter_Specification (Loc,
2496 Defining_Identifier =>
2497 Make_Defining_Identifier (Loc,
2499 In_Present => In_Present (First_Param),
2500 Out_Present => Out_Present (First_Param),
2501 Parameter_Type => Obj_Param_Typ);
2503 Prepend_To (New_Formals, Obj_Param);
2505 -- If we are dealing with a primitive declared between two views,
2506 -- implemented by a synchronized operation, we need to create
2507 -- a default parameter. The mode of the parameter must match that
2508 -- of the primitive operation.
2511 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
2514 Make_Parameter_Specification (Loc,
2515 Defining_Identifier =>
2516 Make_Defining_Identifier (Loc, Name_uO),
2518 In_Present (Parent (First_Entity (Subp_Id))),
2519 Out_Present => Ekind (Subp_Id) /= E_Function,
2520 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
2522 Prepend_To (New_Formals, Obj_Param);
2525 -- Build the final spec. If it is a function with a controlling
2526 -- result, it is a primitive operation of the corresponding
2527 -- record type, so mark the spec accordingly.
2529 if Ekind (Subp_Id) = E_Function then
2534 if Has_Controlling_Result (Subp_Id) then
2537 (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
2539 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
2543 Make_Function_Specification (Loc,
2544 Defining_Unit_Name => Wrapper_Id,
2545 Parameter_Specifications => New_Formals,
2546 Result_Definition => Res_Def);
2550 Make_Procedure_Specification (Loc,
2551 Defining_Unit_Name => Wrapper_Id,
2552 Parameter_Specifications => New_Formals);
2555 end Build_Wrapper_Spec;
2557 -------------------------
2558 -- Build_Wrapper_Specs --
2559 -------------------------
2561 procedure Build_Wrapper_Specs
2567 Rec_Typ : Entity_Id;
2568 procedure Scan_Declarations (L : List_Id);
2569 -- Common processing for visible and private declarations
2570 -- of a protected type.
2572 procedure Scan_Declarations (L : List_Id) is
2574 Wrap_Decl : Node_Id;
2575 Wrap_Spec : Node_Id;
2583 while Present (Decl) loop
2586 if Nkind (Decl) = N_Entry_Declaration
2587 and then Ekind (Defining_Identifier (Decl)) = E_Entry
2591 (Subp_Id => Defining_Identifier (Decl),
2593 Formals => Parameter_Specifications (Decl));
2595 elsif Nkind (Decl) = N_Subprogram_Declaration then
2598 (Subp_Id => Defining_Unit_Name (Specification (Decl)),
2601 Parameter_Specifications (Specification (Decl)));
2604 if Present (Wrap_Spec) then
2606 Make_Subprogram_Declaration (Loc,
2607 Specification => Wrap_Spec);
2609 Insert_After (N, Wrap_Decl);
2612 Analyze (Wrap_Decl);
2617 end Scan_Declarations;
2619 -- start of processing for Build_Wrapper_Specs
2622 if Is_Protected_Type (Typ) then
2623 Def := Protected_Definition (Parent (Typ));
2624 else pragma Assert (Is_Task_Type (Typ));
2625 Def := Task_Definition (Parent (Typ));
2628 Rec_Typ := Corresponding_Record_Type (Typ);
2630 -- Generate wrapper specs for a concurrent type which implements an
2631 -- interface. Operations in both the visible and private parts may
2632 -- implement progenitor operations.
2634 if Present (Interfaces (Rec_Typ)) and then Present (Def) then
2635 Scan_Declarations (Visible_Declarations (Def));
2636 Scan_Declarations (Private_Declarations (Def));
2638 end Build_Wrapper_Specs;
2640 ---------------------------
2641 -- Build_Find_Body_Index --
2642 ---------------------------
2644 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
2645 Loc : constant Source_Ptr := Sloc (Typ);
2648 Has_F : Boolean := False;
2650 If_St : Node_Id := Empty;
2653 Decls : List_Id := New_List;
2654 Ret : Node_Id := Empty;
2656 Siz : Node_Id := Empty;
2658 procedure Add_If_Clause (Expr : Node_Id);
2659 -- Add test for range of current entry
2661 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
2662 -- If a bound of an entry is given by a discriminant, retrieve the
2663 -- actual value of the discriminant from the enclosing object.
2669 procedure Add_If_Clause (Expr : Node_Id) is
2671 Stats : constant List_Id :=
2673 Make_Simple_Return_Statement (Loc,
2674 Expression => Make_Integer_Literal (Loc, Index + 1)));
2677 -- Index for current entry body
2681 -- Compute total length of entry queues so far
2689 Right_Opnd => Expr);
2694 Left_Opnd => Make_Identifier (Loc, Name_uE),
2697 -- Map entry queue indexes in the range of the current family
2698 -- into the current index, that designates the entry body.
2702 Make_Implicit_If_Statement (Typ,
2704 Then_Statements => Stats,
2705 Elsif_Parts => New_List);
2709 Append_To (Elsif_Parts (If_St),
2710 Make_Elsif_Part (Loc,
2712 Then_Statements => Stats));
2716 ------------------------------
2717 -- Convert_Discriminant_Ref --
2718 ------------------------------
2720 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
2724 if Is_Entity_Name (Bound)
2725 and then Ekind (Entity (Bound)) = E_Discriminant
2728 Make_Selected_Component (Loc,
2730 Unchecked_Convert_To (Corresponding_Record_Type (Typ),
2731 Make_Explicit_Dereference (Loc,
2732 Make_Identifier (Loc, Name_uObject))),
2733 Selector_Name => Make_Identifier (Loc, Chars (Bound)));
2734 Set_Etype (B, Etype (Entity (Bound)));
2736 B := New_Copy_Tree (Bound);
2740 end Convert_Discriminant_Ref;
2742 -- Start of processing for Build_Find_Body_Index
2745 Spec := Build_Find_Body_Index_Spec (Typ);
2747 Ent := First_Entity (Typ);
2748 while Present (Ent) loop
2749 if Ekind (Ent) = E_Entry_Family then
2759 -- If the protected type has no entry families, there is a one-one
2760 -- correspondence between entry queue and entry body.
2763 Make_Simple_Return_Statement (Loc,
2764 Expression => Make_Identifier (Loc, Name_uE));
2767 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2770 -- if E <= l1 then return 1;
2771 -- elsif E <= l1 + l2 then return 2;
2776 Ent := First_Entity (Typ);
2778 Add_Object_Pointer (Loc, Typ, Decls);
2780 while Present (Ent) loop
2781 if Ekind (Ent) = E_Entry then
2782 Add_If_Clause (Make_Integer_Literal (Loc, 1));
2784 elsif Ekind (Ent) = E_Entry_Family then
2785 E_Typ := Entry_Index_Type (Ent);
2786 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
2787 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
2788 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
2797 Make_Simple_Return_Statement (Loc,
2798 Expression => Make_Integer_Literal (Loc, 1));
2801 pragma Assert (Present (Ret));
2803 if Nkind (Ret) = N_If_Statement then
2805 -- Ranges are in increasing order, so last one doesn't need
2809 Nod : constant Node_Id := Last (Elsif_Parts (Ret));
2812 Set_Else_Statements (Ret, Then_Statements (Nod));
2819 Make_Subprogram_Body (Loc,
2820 Specification => Spec,
2821 Declarations => Decls,
2822 Handled_Statement_Sequence =>
2823 Make_Handled_Sequence_Of_Statements (Loc,
2824 Statements => New_List (Ret)));
2825 end Build_Find_Body_Index;
2827 --------------------------------
2828 -- Build_Find_Body_Index_Spec --
2829 --------------------------------
2831 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
2832 Loc : constant Source_Ptr := Sloc (Typ);
2833 Id : constant Entity_Id :=
2834 Make_Defining_Identifier (Loc,
2835 Chars => New_External_Name (Chars (Typ), 'F'));
2836 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
2837 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
2841 Make_Function_Specification (Loc,
2842 Defining_Unit_Name => Id,
2843 Parameter_Specifications => New_List (
2844 Make_Parameter_Specification (Loc,
2845 Defining_Identifier => Parm1,
2847 New_Occurrence_Of (RTE (RE_Address), Loc)),
2849 Make_Parameter_Specification (Loc,
2850 Defining_Identifier => Parm2,
2852 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
2854 Result_Definition => New_Occurrence_Of (
2855 RTE (RE_Protected_Entry_Index), Loc));
2856 end Build_Find_Body_Index_Spec;
2858 -----------------------------------------------
2859 -- Build_Lock_Free_Protected_Subprogram_Body --
2860 -----------------------------------------------
2862 function Build_Lock_Free_Protected_Subprogram_Body
2865 Unprot_Spec : Node_Id) return Node_Id
2867 Actuals : constant List_Id := New_List;
2868 Loc : constant Source_Ptr := Sloc (N);
2869 Spec : constant Node_Id := Specification (N);
2870 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec);
2872 Prot_Spec : Node_Id;
2876 -- Create the protected version of the body
2879 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode);
2881 -- Build the actual parameters which appear in the call to the
2882 -- unprotected version of the body.
2884 Formal := First (Parameter_Specifications (Prot_Spec));
2885 while Present (Formal) loop
2887 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
2892 -- Function case, generate:
2893 -- return <Unprot_Func_Call>;
2895 if Nkind (Spec) = N_Function_Specification then
2897 Make_Simple_Return_Statement (Loc,
2899 Make_Function_Call (Loc,
2901 Make_Identifier (Loc, Chars (Unprot_Id)),
2902 Parameter_Associations => Actuals));
2904 -- Procedure case, call the unprotected version
2908 Make_Procedure_Call_Statement (Loc,
2910 Make_Identifier (Loc, Chars (Unprot_Id)),
2911 Parameter_Associations => Actuals);
2915 Make_Subprogram_Body (Loc,
2916 Declarations => Empty_List,
2917 Specification => Prot_Spec,
2918 Handled_Statement_Sequence =>
2919 Make_Handled_Sequence_Of_Statements (Loc,
2920 Statements => New_List (Stmt)));
2921 end Build_Lock_Free_Protected_Subprogram_Body;
2923 -------------------------------------------------
2924 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2925 -------------------------------------------------
2927 -- Procedures which meet the lock-free implementation requirements and
2928 -- reference a unique scalar component Comp are expanded in the following
2931 -- procedure P (...) is
2932 -- Expected_Comp : constant Comp_Type :=
2934 -- (System.Atomic_Primitives.Lock_Free_Read_N
2935 -- (_Object.Comp'Address));
2939 -- <original declarations before the object renaming declaration
2942 -- Desired_Comp : Comp_Type := Expected_Comp;
2943 -- Comp : Comp_Type renames Desired_Comp;
2945 -- <original delarations after the object renaming declaration
2949 -- <original statements>
2950 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2951 -- (_Object.Comp'Address,
2952 -- Interfaces.Unsigned_N (Expected_Comp),
2953 -- Interfaces.Unsigned_N (Desired_Comp));
2958 -- Each return and raise statement of P is transformed into an atomic
2961 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2962 -- (_Object.Comp'Address,
2963 -- Interfaces.Unsigned_N (Expected_Comp),
2964 -- Interfaces.Unsigned_N (Desired_Comp));
2966 -- <original statement>
2971 -- Functions which meet the lock-free implementation requirements and
2972 -- reference a unique scalar component Comp are expanded in the following
2975 -- function F (...) return ... is
2976 -- <original declarations before the object renaming declaration
2979 -- Expected_Comp : constant Comp_Type :=
2981 -- (System.Atomic_Primitives.Lock_Free_Read_N
2982 -- (_Object.Comp'Address));
2983 -- Comp : Comp_Type renames Expected_Comp;
2985 -- <original delarations after the object renaming declaration of
2989 -- <original statements>
2992 function Build_Lock_Free_Unprotected_Subprogram_Body
2994 Prot_Typ : Node_Id) return Node_Id
2996 function Referenced_Component (N : Node_Id) return Entity_Id;
2997 -- Subprograms which meet the lock-free implementation criteria are
2998 -- allowed to reference only one unique component. Return the prival
2999 -- of the said component.
3001 --------------------------
3002 -- Referenced_Component --
3003 --------------------------
3005 function Referenced_Component (N : Node_Id) return Entity_Id is
3008 Source_Comp : Entity_Id := Empty;
3011 -- Find the unique source component which N references in its
3014 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop
3016 Element : Lock_Free_Subprogram renames
3017 Lock_Free_Subprogram_Table.Table (Index);
3019 if Element.Sub_Body = N then
3020 Source_Comp := Element.Comp_Id;
3026 if No (Source_Comp) then
3030 -- Find the prival which corresponds to the source component within
3031 -- the declarations of N.
3033 Decl := First (Declarations (N));
3034 while Present (Decl) loop
3036 -- Privals appear as object renamings
3038 if Nkind (Decl) = N_Object_Renaming_Declaration then
3039 Comp := Defining_Identifier (Decl);
3041 if Present (Prival_Link (Comp))
3042 and then Prival_Link (Comp) = Source_Comp
3052 end Referenced_Component;
3056 Comp : constant Entity_Id := Referenced_Component (N);
3057 Loc : constant Source_Ptr := Sloc (N);
3058 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N);
3059 Decls : List_Id := Declarations (N);
3061 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
3064 -- Add renamings for the protection object, discriminals, privals, and
3065 -- the entry index constant for use by debugger.
3067 Debug_Private_Data_Declarations (Decls);
3069 -- Perform the lock-free expansion when the subprogram references a
3070 -- protected component.
3072 if Present (Comp) then
3073 Protected_Component_Ref : declare
3074 Comp_Decl : constant Node_Id := Parent (Comp);
3075 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl);
3076 Comp_Type : constant Entity_Id := Etype (Comp);
3078 Is_Procedure : constant Boolean :=
3079 Ekind (Corresponding_Spec (N)) = E_Procedure;
3080 -- Indicates if N is a protected procedure body
3082 Block_Decls : List_Id := No_List;
3083 Try_Write : Entity_Id;
3084 Desired_Comp : Entity_Id;
3087 Label_Id : Entity_Id := Empty;
3089 Expected_Comp : Entity_Id;
3092 New_Copy_List (Statements (Hand_Stmt_Seq));
3094 Unsigned : Entity_Id;
3096 function Process_Node (N : Node_Id) return Traverse_Result;
3097 -- Transform a single node if it is a return statement, a raise
3098 -- statement or a reference to Comp.
3100 procedure Process_Stmts (Stmts : List_Id);
3101 -- Given a statement sequence Stmts, wrap any return or raise
3102 -- statements in the following manner:
3104 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3105 -- (_Object.Comp'Address,
3106 -- Interfaces.Unsigned_N (Expected_Comp),
3107 -- Interfaces.Unsigned_N (Desired_Comp))
3118 function Process_Node (N : Node_Id) return Traverse_Result is
3120 procedure Wrap_Statement (Stmt : Node_Id);
3121 -- Wrap an arbitrary statement inside an if statement where the
3122 -- condition does an atomic check on the state of the object.
3124 --------------------
3125 -- Wrap_Statement --
3126 --------------------
3128 procedure Wrap_Statement (Stmt : Node_Id) is
3130 -- The first time through, create the declaration of a label
3131 -- which is used to skip the remainder of source statements
3132 -- if the state of the object has changed.
3134 if No (Label_Id) then
3136 Make_Identifier (Loc, New_External_Name ('L', 0));
3137 Set_Entity (Label_Id,
3138 Make_Defining_Identifier (Loc, Chars (Label_Id)));
3142 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3143 -- (_Object.Comp'Address,
3144 -- Interfaces.Unsigned_N (Expected_Comp),
3145 -- Interfaces.Unsigned_N (Desired_Comp))
3153 Make_Implicit_If_Statement (N,
3155 Make_Function_Call (Loc,
3157 New_Occurrence_Of (Try_Write, Loc),
3158 Parameter_Associations => New_List (
3159 Make_Attribute_Reference (Loc,
3160 Prefix => Relocate_Node (Comp_Sel_Nam),
3161 Attribute_Name => Name_Address),
3163 Unchecked_Convert_To (Unsigned,
3164 New_Occurrence_Of (Expected_Comp, Loc)),
3166 Unchecked_Convert_To (Unsigned,
3167 New_Occurrence_Of (Desired_Comp, Loc)))),
3169 Then_Statements => New_List (Relocate_Node (Stmt)),
3171 Else_Statements => New_List (
3172 Make_Goto_Statement (Loc,
3174 New_Occurrence_Of (Entity (Label_Id), Loc)))));
3177 -- Start of processing for Process_Node
3180 -- Wrap each return and raise statement that appear inside a
3181 -- procedure. Skip the last return statement which is added by
3182 -- default since it is transformed into an exit statement.
3185 and then ((Nkind (N) = N_Simple_Return_Statement
3186 and then N /= Last (Stmts))
3187 or else Nkind (N) = N_Extended_Return_Statement
3188 or else (Nkind (N) in
3189 N_Raise_xxx_Error | N_Raise_Statement
3190 and then Comes_From_Source (N)))
3198 Set_Analyzed (N, False);
3203 procedure Process_Nodes is new Traverse_Proc (Process_Node);
3209 procedure Process_Stmts (Stmts : List_Id) is
3212 Stmt := First (Stmts);
3213 while Present (Stmt) loop
3214 Process_Nodes (Stmt);
3219 -- Start of processing for Protected_Component_Ref
3222 -- Get the type size
3224 if Known_Static_Esize (Comp_Type) then
3225 Typ_Size := UI_To_Int (Esize (Comp_Type));
3227 -- If the Esize (Object_Size) is unknown at compile time, look at
3228 -- the RM_Size (Value_Size) since it may have been set by an
3229 -- explicit representation clause.
3231 elsif Known_Static_RM_Size (Comp_Type) then
3232 Typ_Size := UI_To_Int (RM_Size (Comp_Type));
3234 -- Should not happen since this has already been checked in
3235 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3238 raise Program_Error;
3241 -- Retrieve all relevant atomic routines and types
3245 Try_Write := RTE (RE_Lock_Free_Try_Write_8);
3246 Read := RTE (RE_Lock_Free_Read_8);
3247 Unsigned := RTE (RE_Uint8);
3250 Try_Write := RTE (RE_Lock_Free_Try_Write_16);
3251 Read := RTE (RE_Lock_Free_Read_16);
3252 Unsigned := RTE (RE_Uint16);
3255 Try_Write := RTE (RE_Lock_Free_Try_Write_32);
3256 Read := RTE (RE_Lock_Free_Read_32);
3257 Unsigned := RTE (RE_Uint32);
3260 Try_Write := RTE (RE_Lock_Free_Try_Write_64);
3261 Read := RTE (RE_Lock_Free_Read_64);
3262 Unsigned := RTE (RE_Uint64);
3265 raise Program_Error;
3269 -- Expected_Comp : constant Comp_Type :=
3271 -- (System.Atomic_Primitives.Lock_Free_Read_N
3272 -- (_Object.Comp'Address));
3275 Make_Defining_Identifier (Loc,
3276 New_External_Name (Chars (Comp), Suffix => "_saved"));
3279 Make_Object_Declaration (Loc,
3280 Defining_Identifier => Expected_Comp,
3281 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3282 Constant_Present => True,
3284 Unchecked_Convert_To (Comp_Type,
3285 Make_Function_Call (Loc,
3286 Name => New_Occurrence_Of (Read, Loc),
3287 Parameter_Associations => New_List (
3288 Make_Attribute_Reference (Loc,
3289 Prefix => Relocate_Node (Comp_Sel_Nam),
3290 Attribute_Name => Name_Address)))));
3292 -- Protected procedures
3294 if Is_Procedure then
3295 -- Move the original declarations inside the generated block
3297 Block_Decls := Decls;
3299 -- Reset the declarations list of the protected procedure to
3300 -- contain only Decl.
3302 Decls := New_List (Decl);
3305 -- Desired_Comp : Comp_Type := Expected_Comp;
3308 Make_Defining_Identifier (Loc,
3309 New_External_Name (Chars (Comp), Suffix => "_current"));
3311 -- Insert the declarations of Expected_Comp and Desired_Comp in
3312 -- the block declarations right before the renaming of the
3313 -- protected component.
3315 Insert_Before (Comp_Decl,
3316 Make_Object_Declaration (Loc,
3317 Defining_Identifier => Desired_Comp,
3318 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3320 New_Occurrence_Of (Expected_Comp, Loc)));
3322 -- Protected function
3325 Desired_Comp := Expected_Comp;
3327 -- Insert the declaration of Expected_Comp in the function
3328 -- declarations right before the renaming of the protected
3331 Insert_Before (Comp_Decl, Decl);
3334 -- Rewrite the protected component renaming declaration to be a
3335 -- renaming of Desired_Comp.
3338 -- Comp : Comp_Type renames Desired_Comp;
3341 Make_Object_Renaming_Declaration (Loc,
3342 Defining_Identifier =>
3343 Defining_Identifier (Comp_Decl),
3345 New_Occurrence_Of (Comp_Type, Loc),
3347 New_Occurrence_Of (Desired_Comp, Loc)));
3349 -- Wrap any return or raise statements in Stmts in same the manner
3350 -- described in Process_Stmts.
3352 Process_Stmts (Stmts);
3355 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3356 -- (_Object.Comp'Address,
3357 -- Interfaces.Unsigned_N (Expected_Comp),
3358 -- Interfaces.Unsigned_N (Desired_Comp))
3360 if Is_Procedure then
3362 Make_Exit_Statement (Loc,
3364 Make_Function_Call (Loc,
3366 New_Occurrence_Of (Try_Write, Loc),
3367 Parameter_Associations => New_List (
3368 Make_Attribute_Reference (Loc,
3369 Prefix => Relocate_Node (Comp_Sel_Nam),
3370 Attribute_Name => Name_Address),
3372 Unchecked_Convert_To (Unsigned,
3373 New_Occurrence_Of (Expected_Comp, Loc)),
3375 Unchecked_Convert_To (Unsigned,
3376 New_Occurrence_Of (Desired_Comp, Loc)))));
3378 -- Small optimization: transform the default return statement
3379 -- of a procedure into the atomic exit statement.
3381 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then
3382 Rewrite (Last (Stmts), Stmt);
3384 Append_To (Stmts, Stmt);
3388 -- Create the declaration of the label used to skip the rest of
3389 -- the source statements when the object state changes.
3391 if Present (Label_Id) then
3392 Label := Make_Label (Loc, Label_Id);
3394 Make_Implicit_Label_Declaration (Loc,
3395 Defining_Identifier => Entity (Label_Id),
3396 Label_Construct => Label));
3397 Append_To (Stmts, Label);
3409 if Is_Procedure then
3412 Make_Loop_Statement (Loc,
3413 Statements => New_List (
3414 Make_Block_Statement (Loc,
3415 Declarations => Block_Decls,
3416 Handled_Statement_Sequence =>
3417 Make_Handled_Sequence_Of_Statements (Loc,
3418 Statements => Stmts))),
3419 End_Label => Empty));
3423 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts);
3424 end Protected_Component_Ref;
3427 -- Make an unprotected version of the subprogram for use within the same
3428 -- object, with new name and extra parameter representing the object.
3431 Make_Subprogram_Body (Loc,
3433 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode),
3434 Declarations => Decls,
3435 Handled_Statement_Sequence => Hand_Stmt_Seq);
3436 end Build_Lock_Free_Unprotected_Subprogram_Body;
3438 -------------------------
3439 -- Build_Master_Entity --
3440 -------------------------
3442 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is
3443 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ);
3445 Context_Id : Entity_Id;
3451 -- No action needed if the run-time has no tasking support
3453 if Global_No_Tasking then
3457 if Is_Itype (Obj_Or_Typ) then
3458 Par := Associated_Node_For_Itype (Obj_Or_Typ);
3460 Par := Parent (Obj_Or_Typ);
3463 -- For transient scopes check if the master entity is already defined
3465 if Is_Type (Obj_Or_Typ)
3466 and then Ekind (Scope (Obj_Or_Typ)) = E_Block
3467 and then Is_Internal (Scope (Obj_Or_Typ))
3470 Master_Scope : constant Entity_Id :=
3471 Find_Master_Scope (Obj_Or_Typ);
3473 if Has_Master_Entity (Master_Scope)
3474 or else Is_Finalizer (Master_Scope)
3479 if Present (Current_Entity_In_Scope (Name_uMaster)) then
3485 -- When creating a master for a record component which is either a task
3486 -- or access-to-task, the enclosing record is the master scope and the
3487 -- proper insertion point is the component list.
3489 if Is_Record_Type (Current_Scope) then
3491 Context_Id := Current_Scope;
3492 Decls := List_Containing (Context);
3494 -- Default case for object declarations and access types. Note that the
3495 -- context is updated to the nearest enclosing body, block, package, or
3496 -- return statement.
3499 Find_Enclosing_Context (Par, Context, Context_Id, Decls);
3502 -- Nothing to do if the context already has a master; internally built
3503 -- finalizers don't need a master.
3505 if Has_Master_Entity (Context_Id)
3506 or else Is_Finalizer (Context_Id)
3511 Decl := Build_Master_Declaration (Loc);
3513 -- The master is inserted at the start of the declarative list of the
3516 Prepend_To (Decls, Decl);
3518 -- In certain cases where transient scopes are involved, the immediate
3519 -- scope is not always the proper master scope. Ensure that the master
3520 -- declaration and entity appear in the same context.
3522 if Context_Id /= Current_Scope then
3523 Push_Scope (Context_Id);
3530 -- Mark the enclosing scope and its associated construct as being task
3533 Set_Has_Master_Entity (Context_Id);
3535 while Present (Context)
3536 and then Nkind (Context) /= N_Compilation_Unit
3538 if Nkind (Context) in
3539 N_Block_Statement | N_Subprogram_Body | N_Task_Body
3541 Set_Is_Task_Master (Context);
3544 elsif Nkind (Parent (Context)) = N_Subunit then
3545 Context := Corresponding_Stub (Parent (Context));
3548 Context := Parent (Context);
3550 end Build_Master_Entity;
3552 ---------------------------
3553 -- Build_Master_Renaming --
3554 ---------------------------
3556 procedure Build_Master_Renaming
3557 (Ptr_Typ : Entity_Id;
3558 Ins_Nod : Node_Id := Empty)
3560 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
3562 Master_Decl : Node_Id;
3563 Master_Id : Entity_Id;
3566 -- No action needed if the run-time has no tasking support
3568 if Global_No_Tasking then
3572 -- Determine the proper context to insert the master renaming
3574 if Present (Ins_Nod) then
3577 elsif Is_Itype (Ptr_Typ) then
3578 Context := Associated_Node_For_Itype (Ptr_Typ);
3580 -- When the context references a discriminant or a component of a
3581 -- private type and we are processing declarations in the private
3582 -- part of the enclosing package, we must insert the master renaming
3583 -- before the full declaration of the private type; otherwise the
3584 -- master renaming would be inserted in the public part of the
3585 -- package (and hence before the declaration of _master).
3587 if In_Private_Part (Current_Scope) then
3589 Ctx : Node_Id := Context;
3592 if Nkind (Context) = N_Discriminant_Specification then
3593 Ctx := Parent (Ctx);
3595 while Nkind (Ctx) in
3596 N_Component_Declaration | N_Component_List
3598 Ctx := Parent (Ctx);
3602 if Nkind (Ctx) in N_Private_Type_Declaration
3603 | N_Private_Extension_Declaration
3605 Context := Parent (Full_View (Defining_Identifier (Ctx)));
3611 Context := Parent (Ptr_Typ);
3615 -- <Ptr_Typ>M : Master_Id renames _Master;
3616 -- and add a numeric suffix to the name to ensure that it is
3617 -- unique in case other access types in nested constructs
3618 -- are homonyms of this one.
3621 Make_Defining_Identifier (Loc,
3622 New_External_Name (Chars (Ptr_Typ), 'M', -1));
3625 Make_Object_Renaming_Declaration (Loc,
3626 Defining_Identifier => Master_Id,
3627 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
3628 Name => Make_Identifier (Loc, Name_uMaster));
3630 Insert_Action (Context, Master_Decl);
3632 -- The renamed master now services the access type
3634 Set_Master_Id (Ptr_Typ, Master_Id);
3635 end Build_Master_Renaming;
3637 ---------------------------
3638 -- Build_Protected_Entry --
3639 ---------------------------
3641 function Build_Protected_Entry
3644 Pid : Node_Id) return Node_Id
3646 Bod_Decls : constant List_Id := New_List;
3647 Decls : constant List_Id := Declarations (N);
3648 End_Lab : constant Node_Id :=
3649 End_Label (Handled_Statement_Sequence (N));
3650 End_Loc : constant Source_Ptr :=
3651 Sloc (Last (Statements (Handled_Statement_Sequence (N))));
3652 -- Used for the generated call to Complete_Entry_Body
3654 Loc : constant Source_Ptr := Sloc (N);
3658 Bod_Stmts : List_Id;
3661 Proc_Body : Node_Id;
3663 EH_Loc : Source_Ptr;
3664 -- Used for the exception handler, inserted at end of the body
3667 -- Set the source location on the exception handler only when debugging
3668 -- the expanded code (see Make_Implicit_Exception_Handler).
3670 if Debug_Generated_Code then
3673 -- Otherwise the inserted code should not be visible to the debugger
3676 EH_Loc := No_Location;
3680 Make_Defining_Identifier (Loc,
3681 Chars => Chars (Protected_Body_Subprogram (Ent)));
3682 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty);
3684 -- Add the following declarations:
3686 -- type poVP is access poV;
3687 -- _object : poVP := poVP (_O);
3689 -- where _O is the formal parameter associated with the concurrent
3690 -- object. These declarations are needed for Complete_Entry_Body.
3692 Add_Object_Pointer (Loc, Pid, Bod_Decls);
3694 -- Add renamings for all formals, the Protection object, discriminals,
3695 -- privals and the entry index constant for use by debugger.
3697 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc);
3698 Debug_Private_Data_Declarations (Decls);
3700 -- Put the declarations and the statements from the entry
3704 Make_Block_Statement (Loc,
3705 Declarations => Decls,
3706 Handled_Statement_Sequence => Handled_Statement_Sequence (N)));
3708 -- Analyze now and reset scopes for declarations so that Scope fields
3709 -- currently denoting the entry will now denote the block scope, and
3710 -- the block's scope will be set to the new procedure entity.
3712 Analyze_Statements (Bod_Stmts);
3714 Set_Scope (Entity (Identifier (First (Bod_Stmts))), Bod_Id);
3717 (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts))));
3719 case Corresponding_Runtime_Package (Pid) is
3720 when System_Tasking_Protected_Objects_Entries =>
3721 Append_To (Bod_Stmts,
3722 Make_Procedure_Call_Statement (End_Loc,
3724 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
3725 Parameter_Associations => New_List (
3726 Make_Attribute_Reference (End_Loc,
3728 Make_Selected_Component (End_Loc,
3730 Make_Identifier (End_Loc, Name_uObject),
3732 Make_Identifier (End_Loc, Name_uObject)),
3733 Attribute_Name => Name_Unchecked_Access))));
3735 when System_Tasking_Protected_Objects_Single_Entry =>
3737 -- Historically, a call to Complete_Single_Entry_Body was
3738 -- inserted, but it was a null procedure.
3743 raise Program_Error;
3746 -- When exceptions cannot be propagated, we never need to call
3747 -- Exception_Complete_Entry_Body.
3749 if No_Exception_Handlers_Set then
3751 Make_Subprogram_Body (Loc,
3752 Specification => Bod_Spec,
3753 Declarations => Bod_Decls,
3754 Handled_Statement_Sequence =>
3755 Make_Handled_Sequence_Of_Statements (Loc,
3756 Statements => Bod_Stmts,
3757 End_Label => End_Lab));
3760 Ohandle := Make_Others_Choice (Loc);
3761 Set_All_Others (Ohandle);
3763 case Corresponding_Runtime_Package (Pid) is
3764 when System_Tasking_Protected_Objects_Entries =>
3767 (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
3769 when System_Tasking_Protected_Objects_Single_Entry =>
3772 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
3775 raise Program_Error;
3778 -- Establish link between subprogram body entity and source entry
3780 Set_Corresponding_Protected_Entry (Bod_Id, Ent);
3782 -- Create body of entry procedure. The renaming declarations are
3783 -- placed ahead of the block that contains the actual entry body.
3786 Make_Subprogram_Body (Loc,
3787 Specification => Bod_Spec,
3788 Declarations => Bod_Decls,
3789 Handled_Statement_Sequence =>
3790 Make_Handled_Sequence_Of_Statements (Loc,
3791 Statements => Bod_Stmts,
3792 End_Label => End_Lab,
3793 Exception_Handlers => New_List (
3794 Make_Implicit_Exception_Handler (EH_Loc,
3795 Exception_Choices => New_List (Ohandle),
3797 Statements => New_List (
3798 Make_Procedure_Call_Statement (EH_Loc,
3800 Parameter_Associations => New_List (
3801 Make_Attribute_Reference (EH_Loc,
3803 Make_Selected_Component (EH_Loc,
3805 Make_Identifier (EH_Loc, Name_uObject),
3807 Make_Identifier (EH_Loc, Name_uObject)),
3808 Attribute_Name => Name_Unchecked_Access),
3810 Make_Function_Call (EH_Loc,
3813 (RTE (RE_Get_GNAT_Exception), Loc)))))))));
3815 Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent));
3818 end Build_Protected_Entry;
3820 -----------------------------------------
3821 -- Build_Protected_Entry_Specification --
3822 -----------------------------------------
3824 function Build_Protected_Entry_Specification
3827 Ent_Id : Entity_Id) return Node_Id
3829 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP);
3832 Set_Debug_Info_Needed (Def_Id);
3834 if Present (Ent_Id) then
3835 Append_Elmt (P, Accept_Address (Ent_Id));
3839 Make_Procedure_Specification (Loc,
3840 Defining_Unit_Name => Def_Id,
3841 Parameter_Specifications => New_List (
3842 Make_Parameter_Specification (Loc,
3843 Defining_Identifier =>
3844 Make_Defining_Identifier (Loc, Name_uO),
3846 New_Occurrence_Of (RTE (RE_Address), Loc)),
3848 Make_Parameter_Specification (Loc,
3849 Defining_Identifier => P,
3851 New_Occurrence_Of (RTE (RE_Address), Loc)),
3853 Make_Parameter_Specification (Loc,
3854 Defining_Identifier =>
3855 Make_Defining_Identifier (Loc, Name_uE),
3857 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))));
3858 end Build_Protected_Entry_Specification;
3860 --------------------------
3861 -- Build_Protected_Spec --
3862 --------------------------
3864 function Build_Protected_Spec
3866 Obj_Type : Entity_Id;
3868 Unprotected : Boolean := False) return List_Id
3870 Loc : constant Source_Ptr := Sloc (N);
3873 New_Plist : List_Id;
3874 New_Param : Node_Id;
3877 New_Plist := New_List;
3879 Formal := First_Formal (Ident);
3880 while Present (Formal) loop
3882 Make_Parameter_Specification (Loc,
3883 Defining_Identifier =>
3884 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
3885 Aliased_Present => Aliased_Present (Parent (Formal)),
3886 In_Present => In_Present (Parent (Formal)),
3887 Out_Present => Out_Present (Parent (Formal)),
3888 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc));
3891 Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
3892 Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal));
3895 Append (New_Param, New_Plist);
3896 Next_Formal (Formal);
3899 -- If the subprogram is a procedure and the context is not an access
3900 -- to protected subprogram, the parameter is in-out. Otherwise it is
3904 Make_Parameter_Specification (Loc,
3905 Defining_Identifier =>
3906 Make_Defining_Identifier (Loc, Name_uObject),
3909 (Etype (Ident) = Standard_Void_Type
3910 and then not Is_RTE (Obj_Type, RE_Address)),
3912 New_Occurrence_Of (Obj_Type, Loc));
3913 Set_Debug_Info_Needed (Defining_Identifier (Decl));
3914 Prepend_To (New_Plist, Decl);
3917 end Build_Protected_Spec;
3919 ---------------------------------------
3920 -- Build_Protected_Sub_Specification --
3921 ---------------------------------------
3923 function Build_Protected_Sub_Specification
3925 Prot_Typ : Entity_Id;
3926 Mode : Subprogram_Protection_Mode) return Node_Id
3928 Loc : constant Source_Ptr := Sloc (N);
3932 New_Plist : List_Id;
3935 Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
3936 (Dispatching_Mode => ' ',
3937 Protected_Mode => 'P',
3938 Unprotected_Mode => 'N');
3941 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
3943 Decl := Unit_Declaration_Node (Corresponding_Spec (N));
3948 Def_Id := Defining_Unit_Name (Specification (Decl));
3951 Build_Protected_Spec
3952 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id,
3953 Mode = Unprotected_Mode);
3955 Make_Defining_Identifier (Loc,
3956 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
3958 -- Reference the original nondispatching subprogram since the analysis
3959 -- of the object.operation notation may need its original name (see
3960 -- Sem_Ch4.Names_Match).
3962 if Mode = Dispatching_Mode then
3963 Set_Ekind (New_Id, Ekind (Def_Id));
3964 Set_Original_Protected_Subprogram (New_Id, Def_Id);
3967 -- Link the protected or unprotected version to the original subprogram
3970 Set_Ekind (New_Id, Ekind (Def_Id));
3971 Set_Protected_Subprogram (New_Id, Def_Id);
3973 -- The unprotected operation carries the user code, and debugging
3974 -- information must be generated for it, even though this spec does
3975 -- not come from source. It is also convenient to allow gdb to step
3976 -- into the protected operation, even though it only contains lock/
3979 Set_Debug_Info_Needed (New_Id);
3981 -- If a pragma Eliminate applies to the source entity, the internal
3982 -- subprograms will be eliminated as well.
3984 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
3986 -- It seems we should set Has_Nested_Subprogram here, but instead we
3987 -- currently set it in Expand_N_Protected_Body, because the entity
3988 -- created here isn't the one that Corresponding_Spec of the body
3989 -- will later be set to, and that's the entity where it's needed. ???
3991 Set_Has_Nested_Subprogram (New_Id, Has_Nested_Subprogram (Def_Id));
3993 if Nkind (Specification (Decl)) = N_Procedure_Specification then
3995 Make_Procedure_Specification (Loc,
3996 Defining_Unit_Name => New_Id,
3997 Parameter_Specifications => New_Plist);
3999 -- Create a new specification for the anonymous subprogram type
4003 Make_Function_Specification (Loc,
4004 Defining_Unit_Name => New_Id,
4005 Parameter_Specifications => New_Plist,
4006 Result_Definition =>
4007 Copy_Result_Type (Result_Definition (Specification (Decl))));
4009 Set_Return_Present (Defining_Unit_Name (New_Spec));
4013 end Build_Protected_Sub_Specification;
4015 -------------------------------------
4016 -- Build_Protected_Subprogram_Body --
4017 -------------------------------------
4019 function Build_Protected_Subprogram_Body
4022 N_Op_Spec : Node_Id) return Node_Id
4024 Exc_Safe : constant Boolean := not Might_Raise (N);
4025 -- True if N cannot raise an exception
4027 Loc : constant Source_Ptr := Sloc (N);
4028 Op_Spec : constant Node_Id := Specification (N);
4029 P_Op_Spec : constant Node_Id :=
4030 Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
4033 Lock_Name : Node_Id;
4034 Lock_Stmt : Node_Id;
4035 Object_Parm : Node_Id;
4038 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
4039 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
4043 Unprot_Call : Node_Id;
4046 -- Build a list of the formal parameters of the protected version of
4047 -- the subprogram to use as the actual parameters of the unprotected
4050 Uactuals := New_List;
4051 Pformal := First (Parameter_Specifications (P_Op_Spec));
4052 while Present (Pformal) loop
4053 Append_To (Uactuals,
4054 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
4058 -- Make a call to the unprotected version of the subprogram built above
4059 -- for use by the protected version built below.
4061 if Nkind (Op_Spec) = N_Function_Specification then
4063 R := Make_Temporary (Loc, 'R');
4066 Make_Object_Declaration (Loc,
4067 Defining_Identifier => R,
4068 Constant_Present => True,
4069 Object_Definition =>
4070 New_Copy (Result_Definition (N_Op_Spec)),
4072 Make_Function_Call (Loc,
4074 Make_Identifier (Loc,
4075 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4076 Parameter_Associations => Uactuals));
4079 Make_Simple_Return_Statement (Loc,
4080 Expression => New_Occurrence_Of (R, Loc));
4084 Make_Simple_Return_Statement (Loc,
4086 Make_Function_Call (Loc,
4088 Make_Identifier (Loc,
4089 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4090 Parameter_Associations => Uactuals));
4093 if Has_Aspect (Pid, Aspect_Exclusive_Functions)
4095 (No (Find_Value_Of_Aspect (Pid, Aspect_Exclusive_Functions))
4097 Is_True (Static_Boolean (Find_Value_Of_Aspect
4098 (Pid, Aspect_Exclusive_Functions))))
4100 Lock_Kind := RE_Lock;
4102 Lock_Kind := RE_Lock_Read_Only;
4106 Make_Procedure_Call_Statement (Loc,
4108 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
4109 Parameter_Associations => Uactuals);
4111 Lock_Kind := RE_Lock;
4114 -- Wrap call in block that will be covered by an at_end handler
4116 if not Exc_Safe then
4118 Make_Block_Statement (Loc,
4119 Handled_Statement_Sequence =>
4120 Make_Handled_Sequence_Of_Statements (Loc,
4121 Statements => New_List (Unprot_Call)));
4124 -- Make the protected subprogram body. This locks the protected
4125 -- object and calls the unprotected version of the subprogram.
4127 case Corresponding_Runtime_Package (Pid) is
4128 when System_Tasking_Protected_Objects_Entries =>
4129 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc);
4131 when System_Tasking_Protected_Objects_Single_Entry =>
4132 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc);
4134 when System_Tasking_Protected_Objects =>
4135 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc);
4138 raise Program_Error;
4142 Make_Attribute_Reference (Loc,
4144 Make_Selected_Component (Loc,
4145 Prefix => Make_Identifier (Loc, Name_uObject),
4146 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4147 Attribute_Name => Name_Unchecked_Access);
4150 Make_Procedure_Call_Statement (Loc,
4152 Parameter_Associations => New_List (Object_Parm));
4154 if Abort_Allowed then
4156 Build_Runtime_Call (Loc, RE_Abort_Defer),
4160 Stmts := New_List (Lock_Stmt);
4163 if not Exc_Safe then
4164 Append (Unprot_Call, Stmts);
4166 if Nkind (Op_Spec) = N_Function_Specification then
4168 Stmts := Empty_List;
4170 Append (Unprot_Call, Stmts);
4173 -- Historical note: Previously, call to the cleanup was inserted
4174 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4175 -- which is also shared by the 'not Exc_Safe' path.
4177 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
4179 if Nkind (Op_Spec) = N_Function_Specification then
4180 Append_To (Stmts, Return_Stmt);
4181 Append_To (Pre_Stmts,
4182 Make_Block_Statement (Loc,
4183 Declarations => New_List (Unprot_Call),
4184 Handled_Statement_Sequence =>
4185 Make_Handled_Sequence_Of_Statements (Loc,
4186 Statements => Stmts)));
4192 Make_Subprogram_Body (Loc,
4193 Declarations => Empty_List,
4194 Specification => P_Op_Spec,
4195 Handled_Statement_Sequence =>
4196 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
4198 -- Mark this subprogram as a protected subprogram body so that the
4199 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4200 -- path as otherwise the cleanup has already been inserted.
4202 if not Exc_Safe then
4203 Set_Is_Protected_Subprogram_Body (Sub_Body);
4207 end Build_Protected_Subprogram_Body;
4209 -------------------------------------
4210 -- Build_Protected_Subprogram_Call --
4211 -------------------------------------
4213 procedure Build_Protected_Subprogram_Call
4217 External : Boolean := True)
4219 Loc : constant Source_Ptr := Sloc (N);
4220 Sub : constant Entity_Id := Entity (Name);
4226 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
4229 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
4232 if Present (Parameter_Associations (N)) then
4233 Params := New_Copy_List_Tree (Parameter_Associations (N));
4238 -- If the type is an untagged derived type, convert to the root type,
4239 -- which is the one on which the operations are defined.
4241 if Nkind (Rec) = N_Unchecked_Type_Conversion
4242 and then not Is_Tagged_Type (Etype (Rec))
4243 and then Is_Derived_Type (Etype (Rec))
4245 Set_Etype (Rec, Root_Type (Etype (Rec)));
4246 Set_Subtype_Mark (Rec,
4247 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
4250 Prepend (Rec, Params);
4252 if Ekind (Sub) = E_Procedure then
4254 Make_Procedure_Call_Statement (Loc,
4256 Parameter_Associations => Params));
4259 pragma Assert (Ekind (Sub) = E_Function);
4261 Make_Function_Call (Loc,
4263 Parameter_Associations => Params));
4265 -- Preserve type of call for subsequent processing (required for
4266 -- call to Wrap_Transient_Expression in the case of a shared passive
4269 Set_Etype (N, Etype (New_Sub));
4273 and then Nkind (Rec) = N_Unchecked_Type_Conversion
4274 and then Is_Entity_Name (Expression (Rec))
4275 and then Is_Shared_Passive (Entity (Expression (Rec)))
4277 Add_Shared_Var_Lock_Procs (N);
4279 end Build_Protected_Subprogram_Call;
4281 ---------------------------------------------
4282 -- Build_Protected_Subprogram_Call_Cleanup --
4283 ---------------------------------------------
4285 procedure Build_Protected_Subprogram_Call_Cleanup
4294 -- If the associated protected object has entries, a protected
4295 -- procedure has to service entry queues. In this case generate:
4297 -- Service_Entries (_object._object'Access);
4299 if Nkind (Op_Spec) = N_Procedure_Specification
4300 and then Has_Entries (Conc_Typ)
4302 case Corresponding_Runtime_Package (Conc_Typ) is
4303 when System_Tasking_Protected_Objects_Entries =>
4304 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc);
4306 when System_Tasking_Protected_Objects_Single_Entry =>
4307 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc);
4310 raise Program_Error;
4314 Make_Procedure_Call_Statement (Loc,
4316 Parameter_Associations => New_List (
4317 Make_Attribute_Reference (Loc,
4319 Make_Selected_Component (Loc,
4320 Prefix => Make_Identifier (Loc, Name_uObject),
4321 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4322 Attribute_Name => Name_Unchecked_Access))));
4326 -- Unlock (_object._object'Access);
4328 case Corresponding_Runtime_Package (Conc_Typ) is
4329 when System_Tasking_Protected_Objects_Entries =>
4330 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc);
4332 when System_Tasking_Protected_Objects_Single_Entry =>
4333 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc);
4335 when System_Tasking_Protected_Objects =>
4336 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc);
4339 raise Program_Error;
4343 Make_Procedure_Call_Statement (Loc,
4345 Parameter_Associations => New_List (
4346 Make_Attribute_Reference (Loc,
4348 Make_Selected_Component (Loc,
4349 Prefix => Make_Identifier (Loc, Name_uObject),
4350 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4351 Attribute_Name => Name_Unchecked_Access))));
4357 if Abort_Allowed then
4358 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4360 end Build_Protected_Subprogram_Call_Cleanup;
4362 -------------------------
4363 -- Build_Selected_Name --
4364 -------------------------
4366 function Build_Selected_Name
4367 (Prefix : Entity_Id;
4368 Selector : Entity_Id;
4369 Append_Char : Character := ' ') return Name_Id
4371 Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
4372 Select_Len : Natural;
4375 Get_Name_String (Chars (Selector));
4376 Select_Len := Name_Len;
4377 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
4378 Get_Name_String (Chars (Prefix));
4380 -- If scope is anonymous type, discard suffix to recover name of
4381 -- single protected object. Otherwise use protected type name.
4383 if Name_Buffer (Name_Len) = 'T' then
4384 Name_Len := Name_Len - 1;
4387 Add_Str_To_Name_Buffer ("__");
4388 for J in 1 .. Select_Len loop
4389 Add_Char_To_Name_Buffer (Select_Buffer (J));
4392 -- Now add the Append_Char if specified. The encoding to follow
4393 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4394 -- then the entity is associated to a protected type subprogram.
4395 -- Otherwise, it is a protected type entry. For each case, the
4396 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4398 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4400 if Append_Char /= ' ' then
4401 if Append_Char = 'P' or Append_Char = 'N' then
4402 Add_Char_To_Name_Buffer (Append_Char);
4405 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
4406 return New_External_Name (Name_Find, ' ', -1);
4411 end Build_Selected_Name;
4413 -----------------------------
4414 -- Build_Simple_Entry_Call --
4415 -----------------------------
4417 -- A task entry call is converted to a call to Call_Simple
4420 -- P : parms := (parm, parm, parm);
4422 -- Call_Simple (acceptor-task, entry-index, P'Address);
4428 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4429 -- the parameters, and the constructed aggregate value contains either the
4430 -- parameters or, in the case of non-elementary types, references to these
4431 -- parameters. Then the address of this aggregate is passed to the runtime
4432 -- routine, along with the task id value and the task entry index value.
4433 -- Pnn is only required if parameters are present.
4435 -- The assignments after the call are present only in the case of in-out
4436 -- or out parameters for elementary types, and are used to assign back the
4437 -- resulting values of such parameters.
4439 -- Note: the reason that we insert a block here is that in the context
4440 -- of selects, conditional entry calls etc. the entry call statement
4441 -- appears on its own, not as an element of a list.
4443 -- A protected entry call is converted to a Protected_Entry_Call:
4446 -- P : E1_Params := (param, param, param);
4448 -- Bnn : Communications_Block;
4451 -- P : E1_Params := (param, param, param);
4452 -- Bnn : Communications_Block;
4455 -- Protected_Entry_Call (
4456 -- Object => po._object'Access,
4457 -- E => <entry index>;
4458 -- Uninterpreted_Data => P'Address;
4459 -- Mode => Simple_Call;
4466 procedure Build_Simple_Entry_Call
4475 -- If call has been inlined, nothing left to do
4477 if Nkind (N) = N_Block_Statement then
4481 -- Convert entry call to Call_Simple call
4484 Loc : constant Source_Ptr := Sloc (N);
4485 Parms : constant List_Id := Parameter_Associations (N);
4486 Stats : constant List_Id := New_List;
4489 Comm_Name : Entity_Id;
4493 Ent_Acc : Entity_Id;
4495 Iface_Tag : Entity_Id;
4496 Iface_Typ : Entity_Id;
4509 -- Simple entry and entry family cases merge here
4511 Ent := Entity (Ename);
4512 Ent_Acc := Entry_Parameters_Type (Ent);
4513 Conctyp := Etype (Concval);
4515 -- Special case for protected subprogram calls
4517 if Is_Protected_Type (Conctyp)
4518 and then Is_Subprogram (Entity (Ename))
4520 if not Is_Eliminated (Entity (Ename)) then
4521 Build_Protected_Subprogram_Call
4522 (N, Ename, Convert_Concurrent (Concval, Conctyp));
4529 -- First parameter is the Task_Id value from the task value or the
4530 -- Object from the protected object value, obtained by selecting
4531 -- the _Task_Id or _Object from the result of doing an unchecked
4532 -- conversion to convert the value to the corresponding record type.
4534 if Nkind (Concval) = N_Function_Call
4535 and then Is_Task_Type (Conctyp)
4536 and then Ada_Version >= Ada_2005
4539 ExpR : constant Node_Id := Relocate_Node (Concval);
4540 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR);
4545 Make_Object_Declaration (Loc,
4546 Defining_Identifier => Obj,
4547 Object_Definition => New_Occurrence_Of (Conctyp, Loc),
4548 Expression => ExpR);
4549 Set_Etype (Obj, Conctyp);
4550 Decls := New_List (Decl);
4551 Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
4558 Parm1 := Concurrent_Ref (Concval);
4560 -- Second parameter is the entry index, computed by the routine
4561 -- provided for this purpose. The value of this expression is
4562 -- assigned to an intermediate variable to assure that any entry
4563 -- family index expressions are evaluated before the entry
4566 if not Is_Protected_Type (Conctyp)
4568 Corresponding_Runtime_Package (Conctyp) =
4569 System_Tasking_Protected_Objects_Entries
4571 X := Make_Defining_Identifier (Loc, Name_uX);
4574 Make_Object_Declaration (Loc,
4575 Defining_Identifier => X,
4576 Object_Definition =>
4577 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
4578 Expression => Actual_Index_Expression (
4579 Loc, Entity (Ename), Index, Concval));
4581 Append_To (Decls, Xdecl);
4582 Parm2 := New_Occurrence_Of (X, Loc);
4589 -- The third parameter is the packaged parameters. If there are
4590 -- none, then it is just the null address, since nothing is passed.
4593 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
4596 -- Case of parameters present, where third argument is the address
4597 -- of a packaged record containing the required parameter values.
4600 -- First build a list of parameter values, which are references to
4601 -- objects of the parameter types.
4605 Actual := First_Actual (N);
4606 Formal := First_Formal (Ent);
4607 while Present (Actual) loop
4609 -- If it is a by-copy type, copy it to a new variable. The
4610 -- packaged record has a field that points to this variable.
4612 if Is_By_Copy_Type (Etype (Actual)) then
4614 Make_Object_Declaration (Loc,
4615 Defining_Identifier => Make_Temporary (Loc, 'J'),
4616 Aliased_Present => True,
4617 Object_Definition =>
4618 New_Occurrence_Of (Etype (Formal), Loc));
4620 -- Mark the object as not needing initialization since the
4621 -- initialization is performed separately, avoiding errors
4622 -- on cases such as formals of null-excluding access types.
4624 Set_No_Initialization (N_Node);
4626 -- We must make a separate assignment statement for the
4627 -- case of limited types. We cannot assign it unless the
4628 -- Assignment_OK flag is set first. An out formal of an
4629 -- access type or whose type has a Default_Value must also
4630 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4631 -- but no constraint, predicate, or null-exclusion check is
4632 -- applied before the call.
4634 if Ekind (Formal) /= E_Out_Parameter
4635 or else Is_Access_Type (Etype (Formal))
4637 (Is_Scalar_Type (Etype (Formal))
4639 Present (Default_Aspect_Value (Etype (Formal))))
4642 New_Occurrence_Of (Defining_Identifier (N_Node), Loc);
4643 Set_Assignment_OK (N_Var);
4645 Make_Assignment_Statement (Loc,
4647 Expression => Relocate_Node (Actual)));
4649 -- Mark the object as internal, so we don't later reset
4650 -- No_Initialization flag in Default_Initialize_Object,
4651 -- which would lead to needless default initialization.
4652 -- We don't set this outside the if statement, because
4653 -- out scalar parameters without Default_Value do require
4654 -- default initialization if Initialize_Scalars applies.
4656 Set_Is_Internal (Defining_Identifier (N_Node));
4658 -- If actual is an out parameter of a null-excluding
4659 -- access type, there is access check on entry, so set
4660 -- Suppress_Assignment_Checks on the generated statement
4661 -- that assigns the actual to the parameter block.
4663 Set_Suppress_Assignment_Checks (Last (Stats));
4666 Append (N_Node, Decls);
4669 Make_Attribute_Reference (Loc,
4670 Attribute_Name => Name_Unchecked_Access,
4673 (Defining_Identifier (N_Node), Loc)));
4676 -- Interface class-wide formal
4678 if Ada_Version >= Ada_2005
4679 and then Ekind (Etype (Formal)) = E_Class_Wide_Type
4680 and then Is_Interface (Etype (Formal))
4682 Iface_Typ := Etype (Etype (Formal));
4685 -- formal_iface_type! (actual.iface_tag)'reference
4688 Find_Interface_Tag (Etype (Actual), Iface_Typ);
4689 pragma Assert (Present (Iface_Tag));
4692 Make_Reference (Loc,
4693 Unchecked_Convert_To (Iface_Typ,
4694 Make_Selected_Component (Loc,
4696 Relocate_Node (Actual),
4698 New_Occurrence_Of (Iface_Tag, Loc)))));
4704 Make_Reference (Loc, Relocate_Node (Actual)));
4708 Next_Actual (Actual);
4709 Next_Formal_With_Extras (Formal);
4712 -- Now build the declaration of parameters initialized with the
4713 -- aggregate containing this constructed parameter list.
4715 P := Make_Defining_Identifier (Loc, Name_uP);
4718 Make_Object_Declaration (Loc,
4719 Defining_Identifier => P,
4720 Object_Definition =>
4721 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc),
4723 Make_Aggregate (Loc, Expressions => Plist));
4726 Make_Attribute_Reference (Loc,
4727 Prefix => New_Occurrence_Of (P, Loc),
4728 Attribute_Name => Name_Address);
4730 Append (Pdecl, Decls);
4733 -- Now we can create the call, case of protected type
4735 if Is_Protected_Type (Conctyp) then
4736 case Corresponding_Runtime_Package (Conctyp) is
4737 when System_Tasking_Protected_Objects_Entries =>
4739 -- Change the type of the index declaration
4741 Set_Object_Definition (Xdecl,
4742 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc));
4744 -- Some additional declarations for protected entry calls
4750 -- Bnn : Communications_Block;
4752 Comm_Name := Make_Temporary (Loc, 'B');
4755 Make_Object_Declaration (Loc,
4756 Defining_Identifier => Comm_Name,
4757 Object_Definition =>
4759 (RTE (RE_Communication_Block), Loc)));
4761 -- Some additional statements for protected entry calls
4763 -- Protected_Entry_Call
4764 -- (Object => po._object'Access,
4765 -- E => <entry index>;
4766 -- Uninterpreted_Data => P'Address;
4767 -- Mode => Simple_Call;
4771 Make_Procedure_Call_Statement (Loc,
4773 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
4775 Parameter_Associations => New_List (
4776 Make_Attribute_Reference (Loc,
4777 Attribute_Name => Name_Unchecked_Access,
4781 New_Occurrence_Of (RTE (RE_Simple_Call), Loc),
4782 New_Occurrence_Of (Comm_Name, Loc)));
4784 when System_Tasking_Protected_Objects_Single_Entry =>
4786 -- Protected_Single_Entry_Call
4787 -- (Object => po._object'Access,
4788 -- Uninterpreted_Data => P'Address);
4791 Make_Procedure_Call_Statement (Loc,
4794 (RTE (RE_Protected_Single_Entry_Call), Loc),
4796 Parameter_Associations => New_List (
4797 Make_Attribute_Reference (Loc,
4798 Attribute_Name => Name_Unchecked_Access,
4803 raise Program_Error;
4806 -- Case of task type
4810 Make_Procedure_Call_Statement (Loc,
4812 New_Occurrence_Of (RTE (RE_Call_Simple), Loc),
4813 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
4817 Append_To (Stats, Call);
4819 -- If there are out or in/out parameters by copy add assignment
4820 -- statements for the result values.
4822 if Present (Parms) then
4823 Actual := First_Actual (N);
4824 Formal := First_Formal (Ent);
4826 Set_Assignment_OK (Actual);
4827 while Present (Actual) loop
4828 if Is_By_Copy_Type (Etype (Actual))
4829 and then Ekind (Formal) /= E_In_Parameter
4832 Make_Assignment_Statement (Loc,
4833 Name => New_Copy (Actual),
4835 Make_Explicit_Dereference (Loc,
4836 Make_Selected_Component (Loc,
4837 Prefix => New_Occurrence_Of (P, Loc),
4839 Make_Identifier (Loc, Chars (Formal)))));
4841 -- In all cases (including limited private types) we want
4842 -- the assignment to be valid.
4844 Set_Assignment_OK (Name (N_Node));
4846 -- If the call is the triggering alternative in an
4847 -- asynchronous select, or the entry_call alternative of a
4848 -- conditional entry call, the assignments for in-out
4849 -- parameters are incorporated into the statement list that
4850 -- follows, so that there are executed only if the entry
4853 if (Nkind (Parent (N)) = N_Triggering_Alternative
4854 and then N = Triggering_Statement (Parent (N)))
4856 (Nkind (Parent (N)) = N_Entry_Call_Alternative
4857 and then N = Entry_Call_Statement (Parent (N)))
4859 if No (Statements (Parent (N))) then
4860 Set_Statements (Parent (N), New_List);
4863 Prepend (N_Node, Statements (Parent (N)));
4866 Insert_After (Call, N_Node);
4870 Next_Actual (Actual);
4871 Next_Formal_With_Extras (Formal);
4875 -- Finally, create block and analyze it
4878 Make_Block_Statement (Loc,
4879 Declarations => Decls,
4880 Handled_Statement_Sequence =>
4881 Make_Handled_Sequence_Of_Statements (Loc,
4882 Statements => Stats)));
4886 end Build_Simple_Entry_Call;
4888 --------------------------------
4889 -- Build_Task_Activation_Call --
4890 --------------------------------
4892 procedure Build_Task_Activation_Call (N : Node_Id) is
4893 function Activation_Call_Loc return Source_Ptr;
4894 -- Find a suitable source location for the activation call
4896 -------------------------
4897 -- Activation_Call_Loc --
4898 -------------------------
4900 function Activation_Call_Loc return Source_Ptr is
4902 -- The activation call must carry the location of the "end" keyword
4903 -- when the context is a package declaration.
4905 if Nkind (N) = N_Package_Declaration then
4906 return End_Keyword_Location (N);
4908 -- Otherwise the activation call must carry the location of the
4912 return Begin_Keyword_Location (N);
4914 end Activation_Call_Loc;
4925 -- Start of processing for Build_Task_Activation_Call
4928 -- For sequential elaboration policy, all the tasks will be activated at
4929 -- the end of the elaboration.
4931 if Partition_Elaboration_Policy = 'S' then
4934 -- Do not create an activation call for a package spec if the package
4935 -- has a completing body. The activation call will be inserted after
4936 -- the "begin" of the body.
4938 elsif Nkind (N) = N_Package_Declaration
4939 and then Present (Corresponding_Body (N))
4944 -- Obtain the activation chain entity. Block statements, entry bodies,
4945 -- subprogram bodies, and task bodies keep the entity in their nodes.
4946 -- Package bodies on the other hand store it in the declaration of the
4947 -- corresponding package spec.
4951 if Nkind (Owner) = N_Package_Body then
4952 Owner := Unit_Declaration_Node (Corresponding_Spec (Owner));
4955 Chain := Activation_Chain_Entity (Owner);
4957 -- Nothing to do when there are no tasks to activate. This is indicated
4958 -- by a missing activation chain entity; also skip generating it when
4959 -- it is a ghost entity.
4961 if No (Chain) or else Is_Ignored_Ghost_Entity (Chain) then
4964 -- The availability of the activation chain entity does not ensure
4965 -- that we have tasks to activate because it may have been declared
4966 -- by the frontend to pass a required extra formal to a build-in-place
4967 -- subprogram call. If we are within the scope of a protected type and
4968 -- pragma Detect_Blocking is active we can assume that no tasks will be
4969 -- activated; if tasks are created in a protected object and this pragma
4970 -- is active then the frontend emits a warning and Program_Error is
4971 -- raised at runtime.
4973 elsif Detect_Blocking and then Within_Protected_Type (Current_Scope) then
4977 -- The location of the activation call must be as close as possible to
4978 -- the intended semantic location of the activation because the ABE
4979 -- mechanism relies heavily on accurate locations.
4981 Loc := Activation_Call_Loc;
4983 if Restricted_Profile then
4984 Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc);
4986 Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc);
4990 Make_Procedure_Call_Statement (Loc,
4992 Parameter_Associations =>
4993 New_List (Make_Attribute_Reference (Loc,
4994 Prefix => New_Occurrence_Of (Chain, Loc),
4995 Attribute_Name => Name_Unchecked_Access)));
4997 if Nkind (N) = N_Package_Declaration then
4998 if Present (Private_Declarations (Specification (N))) then
4999 Append (Call, Private_Declarations (Specification (N)));
5001 Append (Call, Visible_Declarations (Specification (N)));
5005 -- The call goes at the start of the statement sequence after the
5006 -- start of exception range label if one is present.
5008 if Present (Handled_Statement_Sequence (N)) then
5009 Stmt := First (Statements (Handled_Statement_Sequence (N)));
5011 -- A special case, skip exception range label if one is present
5012 -- (from front end zcx processing).
5014 if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then
5018 -- Another special case, if the first statement is a block from
5019 -- optimization of a local raise to a goto, then the call goes
5020 -- inside this block.
5022 if Nkind (Stmt) = N_Block_Statement
5023 and then Exception_Junk (Stmt)
5025 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
5028 -- Insertion point is after any exception label pushes, since we
5029 -- want it covered by any local handlers.
5031 while Nkind (Stmt) in N_Push_xxx_Label loop
5035 -- Now we have the proper insertion point
5037 Insert_Before (Stmt, Call);
5040 Set_Handled_Statement_Sequence (N,
5041 Make_Handled_Sequence_Of_Statements (Loc,
5042 Statements => New_List (Call)));
5048 if Legacy_Elaboration_Checks then
5049 Check_Task_Activation (N);
5051 end Build_Task_Activation_Call;
5053 -------------------------------
5054 -- Build_Task_Allocate_Block --
5055 -------------------------------
5057 procedure Build_Task_Allocate_Block
5062 T : constant Entity_Id := Entity (Expression (N));
5063 Init : constant Entity_Id := Base_Init_Proc (T);
5064 Loc : constant Source_Ptr := Sloc (N);
5065 Chain : constant Entity_Id :=
5066 Make_Defining_Identifier (Loc, Name_uChain);
5067 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5072 Make_Block_Statement (Loc,
5073 Identifier => New_Occurrence_Of (Blkent, Loc),
5074 Declarations => New_List (
5076 -- _Chain : Activation_Chain;
5078 Make_Object_Declaration (Loc,
5079 Defining_Identifier => Chain,
5080 Aliased_Present => True,
5081 Object_Definition =>
5082 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5084 Handled_Statement_Sequence =>
5085 Make_Handled_Sequence_Of_Statements (Loc,
5087 Statements => New_List (
5091 Make_Procedure_Call_Statement (Loc,
5092 Name => New_Occurrence_Of (Init, Loc),
5093 Parameter_Associations => Args),
5095 -- Activate_Tasks (_Chain);
5097 Make_Procedure_Call_Statement (Loc,
5098 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5099 Parameter_Associations => New_List (
5100 Make_Attribute_Reference (Loc,
5101 Prefix => New_Occurrence_Of (Chain, Loc),
5102 Attribute_Name => Name_Unchecked_Access))))),
5104 Has_Created_Identifier => True,
5105 Is_Task_Allocation_Block => True);
5108 Make_Implicit_Label_Declaration (Loc,
5109 Defining_Identifier => Blkent,
5110 Label_Construct => Block));
5112 Append_To (Actions, Block);
5114 Set_Activation_Chain_Entity (Block, Chain);
5115 end Build_Task_Allocate_Block;
5117 -----------------------------------------------
5118 -- Build_Task_Allocate_Block_With_Init_Stmts --
5119 -----------------------------------------------
5121 procedure Build_Task_Allocate_Block_With_Init_Stmts
5124 Init_Stmts : List_Id)
5126 Loc : constant Source_Ptr := Sloc (N);
5127 Chain : constant Entity_Id :=
5128 Make_Defining_Identifier (Loc, Name_uChain);
5129 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5133 Append_To (Init_Stmts,
5134 Make_Procedure_Call_Statement (Loc,
5135 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5136 Parameter_Associations => New_List (
5137 Make_Attribute_Reference (Loc,
5138 Prefix => New_Occurrence_Of (Chain, Loc),
5139 Attribute_Name => Name_Unchecked_Access))));
5142 Make_Block_Statement (Loc,
5143 Identifier => New_Occurrence_Of (Blkent, Loc),
5144 Declarations => New_List (
5146 -- _Chain : Activation_Chain;
5148 Make_Object_Declaration (Loc,
5149 Defining_Identifier => Chain,
5150 Aliased_Present => True,
5151 Object_Definition =>
5152 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5154 Handled_Statement_Sequence =>
5155 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
5157 Has_Created_Identifier => True,
5158 Is_Task_Allocation_Block => True);
5161 Make_Implicit_Label_Declaration (Loc,
5162 Defining_Identifier => Blkent,
5163 Label_Construct => Block));
5165 Append_To (Actions, Block);
5167 Set_Activation_Chain_Entity (Block, Chain);
5168 end Build_Task_Allocate_Block_With_Init_Stmts;
5170 -----------------------------------
5171 -- Build_Task_Proc_Specification --
5172 -----------------------------------
5174 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
5175 Loc : constant Source_Ptr := Sloc (T);
5176 Spec_Id : Entity_Id;
5179 -- Case of explicit task type, suffix TB
5181 if Comes_From_Source (T) then
5183 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB"));
5185 -- Case of anonymous task type, suffix B
5189 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B'));
5192 Set_Is_Internal (Spec_Id);
5194 -- Associate the procedure with the task, if this is the declaration
5195 -- (and not the body) of the procedure.
5197 if No (Task_Body_Procedure (T)) then
5198 Set_Task_Body_Procedure (T, Spec_Id);
5202 Make_Procedure_Specification (Loc,
5203 Defining_Unit_Name => Spec_Id,
5204 Parameter_Specifications => New_List (
5205 Make_Parameter_Specification (Loc,
5206 Defining_Identifier =>
5207 Make_Defining_Identifier (Loc, Name_uTask),
5209 Make_Access_Definition (Loc,
5211 New_Occurrence_Of (Corresponding_Record_Type (T), Loc)))));
5212 end Build_Task_Proc_Specification;
5214 ---------------------------------------
5215 -- Build_Unprotected_Subprogram_Body --
5216 ---------------------------------------
5218 function Build_Unprotected_Subprogram_Body
5220 Pid : Node_Id) return Node_Id
5222 Decls : constant List_Id := Declarations (N);
5225 -- Add renamings for the Protection object, discriminals, privals, and
5226 -- the entry index constant for use by debugger.
5228 Debug_Private_Data_Declarations (Decls);
5230 -- Make an unprotected version of the subprogram for use within the same
5231 -- object, with a new name and an additional parameter representing the
5235 Make_Subprogram_Body (Sloc (N),
5237 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
5238 Declarations => Decls,
5239 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
5240 end Build_Unprotected_Subprogram_Body;
5242 ----------------------------
5243 -- Collect_Entry_Families --
5244 ----------------------------
5246 procedure Collect_Entry_Families
5249 Current_Node : in out Node_Id;
5250 Conctyp : Entity_Id)
5253 Efam_Decl : Node_Id;
5254 Efam_Type : Entity_Id;
5257 Efam := First_Entity (Conctyp);
5258 while Present (Efam) loop
5259 if Ekind (Efam) = E_Entry_Family then
5260 Efam_Type := Make_Temporary (Loc, 'F');
5263 Eityp : constant Entity_Id := Entry_Index_Type (Efam);
5264 Lo : constant Node_Id := Type_Low_Bound (Eityp);
5265 Hi : constant Node_Id := Type_High_Bound (Eityp);
5270 Bityp := Base_Type (Eityp);
5272 if Is_Potentially_Large_Family (Bityp, Conctyp, Lo, Hi) then
5273 Bityp := Make_Temporary (Loc, 'B');
5276 Make_Subtype_Declaration (Loc,
5277 Defining_Identifier => Bityp,
5278 Subtype_Indication =>
5279 Make_Subtype_Indication (Loc,
5281 New_Occurrence_Of (Standard_Integer, Loc),
5283 Make_Range_Constraint (Loc,
5284 Range_Expression => Make_Range (Loc,
5285 Make_Integer_Literal
5286 (Loc, -Entry_Family_Bound),
5287 Make_Integer_Literal
5288 (Loc, Entry_Family_Bound - 1)))));
5290 Insert_After (Current_Node, Bdecl);
5291 Current_Node := Bdecl;
5296 Make_Full_Type_Declaration (Loc,
5297 Defining_Identifier => Efam_Type,
5299 Make_Unconstrained_Array_Definition (Loc,
5301 (New_List (New_Occurrence_Of (Bityp, Loc))),
5303 Component_Definition =>
5304 Make_Component_Definition (Loc,
5305 Aliased_Present => False,
5306 Subtype_Indication =>
5307 New_Occurrence_Of (Standard_Character, Loc))));
5310 Insert_After (Current_Node, Efam_Decl);
5311 Current_Node := Efam_Decl;
5312 Analyze (Efam_Decl);
5315 Make_Component_Declaration (Loc,
5316 Defining_Identifier =>
5317 Make_Defining_Identifier (Loc, Chars (Efam)),
5319 Component_Definition =>
5320 Make_Component_Definition (Loc,
5321 Aliased_Present => False,
5322 Subtype_Indication =>
5323 Make_Subtype_Indication (Loc,
5325 New_Occurrence_Of (Efam_Type, Loc),
5328 Make_Index_Or_Discriminant_Constraint (Loc,
5329 Constraints => New_List (
5330 New_Occurrence_Of (Entry_Index_Type (Efam),
5336 end Collect_Entry_Families;
5338 -----------------------
5339 -- Concurrent_Object --
5340 -----------------------
5342 function Concurrent_Object
5343 (Spec_Id : Entity_Id;
5344 Conc_Typ : Entity_Id) return Entity_Id
5347 -- Parameter _O or _object
5349 if Is_Protected_Type (Conc_Typ) then
5350 return First_Formal (Protected_Body_Subprogram (Spec_Id));
5355 pragma Assert (Is_Task_Type (Conc_Typ));
5356 return First_Formal (Task_Body_Procedure (Conc_Typ));
5358 end Concurrent_Object;
5360 ----------------------
5361 -- Copy_Result_Type --
5362 ----------------------
5364 function Copy_Result_Type (Res : Node_Id) return Node_Id is
5365 New_Res : constant Node_Id := New_Copy_Tree (Res);
5370 -- If the result type is an access_to_subprogram, we must create new
5371 -- entities for its spec.
5373 if Nkind (New_Res) = N_Access_Definition
5374 and then Present (Access_To_Subprogram_Definition (New_Res))
5376 -- Provide new entities for the formals
5378 Par_Spec := First (Parameter_Specifications
5379 (Access_To_Subprogram_Definition (New_Res)));
5380 while Present (Par_Spec) loop
5381 Formal := Defining_Identifier (Par_Spec);
5382 Set_Defining_Identifier (Par_Spec,
5383 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
5389 end Copy_Result_Type;
5391 --------------------
5392 -- Concurrent_Ref --
5393 --------------------
5395 -- The expression returned for a reference to a concurrent object has the
5398 -- taskV!(name)._Task_Id
5402 -- objectV!(name)._Object
5404 -- for a protected object. For the case of an access to a concurrent
5405 -- object, there is an extra explicit dereference:
5407 -- taskV!(name.all)._Task_Id
5408 -- objectV!(name.all)._Object
5410 -- here taskV and objectV are the types for the associated records, which
5411 -- contain the required _Task_Id and _Object fields for tasks and protected
5412 -- objects, respectively.
5414 -- For the case of a task type name, the expression is
5418 -- i.e. a call to the Self function which returns precisely this Task_Id
5420 -- For the case of a protected type name, the expression is
5424 -- which is a renaming of the _object field of the current object
5425 -- record, passed into protected operations as a parameter.
5427 function Concurrent_Ref (N : Node_Id) return Node_Id is
5428 Loc : constant Source_Ptr := Sloc (N);
5429 Ntyp : constant Entity_Id := Etype (N);
5433 function Is_Current_Task (T : Entity_Id) return Boolean;
5434 -- Check whether the reference is to the immediately enclosing task
5435 -- type, or to an outer one (rare but legal).
5437 ---------------------
5438 -- Is_Current_Task --
5439 ---------------------
5441 function Is_Current_Task (T : Entity_Id) return Boolean is
5445 Scop := Current_Scope;
5446 while Present (Scop) and then Scop /= Standard_Standard loop
5450 elsif Is_Task_Type (Scop) then
5453 -- If this is a procedure nested within the task type, we must
5454 -- assume that it can be called from an inner task, and therefore
5455 -- cannot treat it as a local reference.
5457 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then
5461 Scop := Scope (Scop);
5465 -- We know that we are within the task body, so should have found it
5468 raise Program_Error;
5469 end Is_Current_Task;
5471 -- Start of processing for Concurrent_Ref
5474 if Is_Access_Type (Ntyp) then
5475 Dtyp := Designated_Type (Ntyp);
5477 if Is_Protected_Type (Dtyp) then
5478 Sel := Name_uObject;
5480 Sel := Name_uTask_Id;
5484 Make_Selected_Component (Loc,
5486 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
5487 Make_Explicit_Dereference (Loc, N)),
5488 Selector_Name => Make_Identifier (Loc, Sel));
5490 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then
5491 if Is_Task_Type (Entity (N)) then
5493 if Is_Current_Task (Entity (N)) then
5495 Make_Function_Call (Loc,
5496 Name => New_Occurrence_Of (RTE (RE_Self), Loc));
5501 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T');
5502 T_Body : constant Node_Id :=
5503 Parent (Corresponding_Body (Parent (Entity (N))));
5507 Make_Object_Declaration (Loc,
5508 Defining_Identifier => T_Self,
5509 Object_Definition =>
5510 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
5512 Make_Function_Call (Loc,
5513 Name => New_Occurrence_Of (RTE (RE_Self), Loc)));
5514 Prepend (Decl, Declarations (T_Body));
5516 Set_Scope (T_Self, Entity (N));
5517 return New_Occurrence_Of (T_Self, Loc);
5522 pragma Assert (Is_Protected_Type (Entity (N)));
5525 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc);
5529 if Is_Protected_Type (Ntyp) then
5530 Sel := Name_uObject;
5531 elsif Is_Task_Type (Ntyp) then
5532 Sel := Name_uTask_Id;
5534 raise Program_Error;
5538 Make_Selected_Component (Loc,
5540 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
5542 Selector_Name => Make_Identifier (Loc, Sel));
5546 ------------------------
5547 -- Convert_Concurrent --
5548 ------------------------
5550 function Convert_Concurrent
5552 Typ : Entity_Id) return Node_Id
5555 if not Is_Concurrent_Type (Typ) then
5559 Unchecked_Convert_To
5560 (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
5562 end Convert_Concurrent;
5564 -------------------------------------
5565 -- Create_Secondary_Stack_For_Task --
5566 -------------------------------------
5568 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is
5571 (Restriction_Active (No_Implicit_Heap_Allocations)
5572 or else Restriction_Active (No_Implicit_Task_Allocations))
5573 and then not Restriction_Active (No_Secondary_Stack)
5574 and then Has_Rep_Pragma
5575 (T, Name_Secondary_Stack_Size, Check_Parents => False);
5576 end Create_Secondary_Stack_For_Task;
5578 -------------------------------------
5579 -- Debug_Private_Data_Declarations --
5580 -------------------------------------
5582 procedure Debug_Private_Data_Declarations (Decls : List_Id) is
5583 Debug_Nod : Node_Id;
5587 Decl := First (Decls);
5588 while Present (Decl) and then not Comes_From_Source (Decl) loop
5590 -- Declaration for concurrent entity _object and its access type,
5591 -- along with the entry index subtype:
5592 -- type prot_typVP is access prot_typV;
5593 -- _object : prot_typVP := prot_typV (_O);
5594 -- subtype Jnn is <Type of Index> range Low .. High;
5596 if Nkind (Decl) in N_Full_Type_Declaration | N_Object_Declaration then
5597 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5599 -- Declaration for the Protection object, discriminals, privals, and
5600 -- entry index constant:
5601 -- conc_typR : protection_typ renames _object._object;
5602 -- discr_nameD : discr_typ renames _object.discr_name;
5603 -- discr_nameD : discr_typ renames _task.discr_name;
5604 -- prival_name : comp_typ renames _object.comp_name;
5605 -- J : constant Jnn :=
5606 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5608 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
5609 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5610 Debug_Nod := Debug_Renaming_Declaration (Decl);
5612 if Present (Debug_Nod) then
5613 Insert_After (Decl, Debug_Nod);
5619 end Debug_Private_Data_Declarations;
5621 ------------------------------
5622 -- Ensure_Statement_Present --
5623 ------------------------------
5625 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is
5629 if Opt.Suppress_Control_Flow_Optimizations
5630 and then Is_Empty_List (Statements (Alt))
5632 Stmt := Make_Null_Statement (Loc);
5634 -- Mark NULL statement as coming from source so that it is not
5635 -- eliminated by GIGI.
5637 -- Another covert channel. If this is a requirement, it must be
5638 -- documented in sinfo/einfo ???
5640 Set_Comes_From_Source (Stmt, True);
5642 Set_Statements (Alt, New_List (Stmt));
5644 end Ensure_Statement_Present;
5646 ----------------------------
5647 -- Entry_Index_Expression --
5648 ----------------------------
5650 function Entry_Index_Expression
5654 Ttyp : Entity_Id) return Node_Id
5664 -- The queues of entries and entry families appear in textual order in
5665 -- the associated record. The entry index is computed as the sum of the
5666 -- number of queues for all entries that precede the designated one, to
5667 -- which is added the index expression, if this expression denotes a
5668 -- member of a family.
5670 -- The following is a place holder for the count of simple entries
5672 Num := Make_Integer_Literal (Sloc, 1);
5674 -- We construct an expression which is a series of addition operations.
5675 -- The first operand is the number of single entries that precede this
5676 -- one, the second operand is the index value relative to the start of
5677 -- the referenced family, and the remaining operands are the lengths of
5678 -- the entry families that precede this entry, i.e. the constructed
5681 -- number_simple_entries +
5682 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5683 -- family'length + ...
5685 -- where index-value is the given index value, and s is the index
5686 -- subtype (we have to use pos because the subtype might be an
5687 -- enumeration type preventing direct subtraction). Note that the task
5688 -- entry array is one-indexed.
5690 -- The upper bound of the entry family may be a discriminant, so we
5691 -- retrieve the lower bound explicitly to compute offset, rather than
5692 -- using the index subtype which may mention a discriminant.
5694 if Present (Index) then
5695 S := Entry_Index_Type (Ent);
5697 -- First make sure the index is in range if requested. The index type
5698 -- is the pristine Entry_Index_Type of the entry.
5700 if Do_Range_Check (Index) then
5701 Generate_Range_Check (Index, S, CE_Range_Check_Failed);
5710 Make_Attribute_Reference (Sloc,
5711 Attribute_Name => Name_Pos,
5712 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
5713 Expressions => New_List (Relocate_Node (Index))),
5721 -- Now add lengths of preceding entries and entry families
5723 Prev := First_Entity (Ttyp);
5724 while Chars (Prev) /= Chars (Ent)
5725 or else (Ekind (Prev) /= Ekind (Ent))
5726 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
5728 if Ekind (Prev) = E_Entry then
5729 Set_Intval (Num, Intval (Num) + 1);
5731 elsif Ekind (Prev) = E_Entry_Family then
5732 S := Entry_Index_Type (Prev);
5733 Lo := Type_Low_Bound (S);
5734 Hi := Type_High_Bound (S);
5739 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
5741 -- Other components are anonymous types to be ignored
5751 end Entry_Index_Expression;
5753 ---------------------------
5754 -- Establish_Task_Master --
5755 ---------------------------
5757 procedure Establish_Task_Master (N : Node_Id) is
5761 if Restriction_Active (No_Task_Hierarchy) = False then
5762 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
5764 -- The block may have no declarations (and nevertheless be a task
5765 -- master) if it contains a call that may return an object that
5768 if No (Declarations (N)) then
5769 Set_Declarations (N, New_List (Call));
5771 Prepend_To (Declarations (N), Call);
5776 end Establish_Task_Master;
5778 --------------------------------
5779 -- Expand_Accept_Declarations --
5780 --------------------------------
5782 -- Part of the expansion of an accept statement involves the creation of
5783 -- a declaration that can be referenced from the statement sequence of
5788 -- This declaration is inserted immediately before the accept statement
5789 -- and it is important that it be inserted before the statements of the
5790 -- statement sequence are analyzed. Thus it would be too late to create
5791 -- this declaration in the Expand_N_Accept_Statement routine, which is
5792 -- why there is a separate procedure to be called directly from Sem_Ch9.
5794 -- Ann is used to hold the address of the record containing the parameters
5795 -- (see Expand_N_Entry_Call for more details on how this record is built).
5796 -- References to the parameters do an unchecked conversion of this address
5797 -- to a pointer to the required record type, and then access the field that
5798 -- holds the value of the required parameter. The entity for the address
5799 -- variable is held as the top stack element (i.e. the last element) of the
5800 -- Accept_Address stack in the corresponding entry entity, and this element
5801 -- must be set in place before the statements are processed.
5803 -- The above description applies to the case of a stand alone accept
5804 -- statement, i.e. one not appearing as part of a select alternative.
5806 -- For the case of an accept that appears as part of a select alternative
5807 -- of a selective accept, we must still create the declaration right away,
5808 -- since Ann is needed immediately, but there is an important difference:
5810 -- The declaration is inserted before the selective accept, not before
5811 -- the accept statement (which is not part of a list anyway, and so would
5812 -- not accommodate inserted declarations)
5814 -- We only need one address variable for the entire selective accept. So
5815 -- the Ann declaration is created only for the first accept alternative,
5816 -- and subsequent accept alternatives reference the same Ann variable.
5818 -- We can distinguish the two cases by seeing whether the accept statement
5819 -- is part of a list. If not, then it must be in an accept alternative.
5821 -- To expand the requeue statement, a label is provided at the end of the
5822 -- accept statement or alternative of which it is a part, so that the
5823 -- statement can be skipped after the requeue is complete. This label is
5824 -- created here rather than during the expansion of the accept statement,
5825 -- because it will be needed by any requeue statements within the accept,
5826 -- which are expanded before the accept.
5828 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
5829 Loc : constant Source_Ptr := Sloc (N);
5830 Stats : constant Node_Id := Handled_Statement_Sequence (N);
5831 Ann : Entity_Id := Empty;
5838 if Expander_Active then
5840 -- If we have no handled statement sequence, we may need to build
5841 -- a dummy sequence consisting of a null statement. This can be
5842 -- skipped if the trivial accept optimization is permitted.
5844 if not Trivial_Accept_OK
5845 and then (No (Stats) or else Null_Statements (Statements (Stats)))
5847 Set_Handled_Statement_Sequence (N,
5848 Make_Handled_Sequence_Of_Statements (Loc,
5849 Statements => New_List (Make_Null_Statement (Loc))));
5852 -- Create and declare two labels to be placed at the end of the
5853 -- accept statement. The first label is used to allow requeues to
5854 -- skip the remainder of entry processing. The second label is used
5855 -- to skip the remainder of entry processing if the rendezvous
5856 -- completes in the middle of the accept body.
5858 if Present (Handled_Statement_Sequence (N)) then
5863 Ent := Make_Temporary (Loc, 'L');
5864 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5866 Make_Implicit_Label_Declaration (Loc,
5867 Defining_Identifier => Ent,
5868 Label_Construct => Lab);
5869 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5871 Ent := Make_Temporary (Loc, 'L');
5872 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5874 Make_Implicit_Label_Declaration (Loc,
5875 Defining_Identifier => Ent,
5876 Label_Construct => Lab);
5877 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5885 -- Case of stand alone accept statement
5887 if Is_List_Member (N) then
5889 if Present (Handled_Statement_Sequence (N)) then
5890 Ann := Make_Temporary (Loc, 'A');
5893 Make_Object_Declaration (Loc,
5894 Defining_Identifier => Ann,
5895 Object_Definition =>
5896 New_Occurrence_Of (RTE (RE_Address), Loc));
5898 Insert_Before_And_Analyze (N, Adecl);
5899 Insert_Before_And_Analyze (N, Ldecl);
5900 Insert_Before_And_Analyze (N, Ldecl2);
5903 -- Case of accept statement which is in an accept alternative
5907 Acc_Alt : constant Node_Id := Parent (N);
5908 Sel_Acc : constant Node_Id := Parent (Acc_Alt);
5912 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
5913 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
5915 -- ??? Consider a single label for select statements
5917 if Present (Handled_Statement_Sequence (N)) then
5919 Statements (Handled_Statement_Sequence (N)));
5923 Statements (Handled_Statement_Sequence (N)));
5927 -- Find first accept alternative of the selective accept. A
5928 -- valid selective accept must have at least one accept in it.
5930 Alt := First (Select_Alternatives (Sel_Acc));
5932 while Nkind (Alt) /= N_Accept_Alternative loop
5936 -- If this is the first accept statement, then we have to
5937 -- create the Ann variable, as for the stand alone case, except
5938 -- that it is inserted before the selective accept. Similarly,
5939 -- a label for requeue expansion must be declared.
5941 if N = Accept_Statement (Alt) then
5942 Ann := Make_Temporary (Loc, 'A');
5944 Make_Object_Declaration (Loc,
5945 Defining_Identifier => Ann,
5946 Object_Definition =>
5947 New_Occurrence_Of (RTE (RE_Address), Loc));
5949 Insert_Before_And_Analyze (Sel_Acc, Adecl);
5951 -- If this is not the first accept statement, then find the Ann
5952 -- variable allocated by the first accept and use it.
5956 Node (Last_Elmt (Accept_Address
5957 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
5962 -- Merge here with Ann either created or referenced, and Adecl
5963 -- pointing to the corresponding declaration. Remaining processing
5964 -- is the same for the two cases.
5966 if Present (Ann) then
5967 Append_Elmt (Ann, Accept_Address (Ent));
5968 Set_Debug_Info_Needed (Ann);
5971 -- Create renaming declarations for the entry formals. Each reference
5972 -- to a formal becomes a dereference of a component of the parameter
5973 -- block, whose address is held in Ann. These declarations are
5974 -- eventually inserted into the accept block, and analyzed there so
5975 -- that they have the proper scope for gdb and do not conflict with
5976 -- other declarations.
5978 if Present (Parameter_Specifications (N))
5979 and then Present (Handled_Statement_Sequence (N))
5986 Renamed_Formal : Node_Id;
5990 Formal := First_Formal (Ent);
5992 while Present (Formal) loop
5993 Comp := Entry_Component (Formal);
5994 New_F := Make_Defining_Identifier (Loc, Chars (Formal));
5996 Set_Etype (New_F, Etype (Formal));
5997 Set_Scope (New_F, Ent);
5999 -- Now we set debug info needed on New_F even though it does
6000 -- not come from source, so that the debugger will get the
6001 -- right information for these generated names.
6003 Set_Debug_Info_Needed (New_F);
6005 if Ekind (Formal) = E_In_Parameter then
6006 Set_Ekind (New_F, E_Constant);
6008 Set_Ekind (New_F, E_Variable);
6009 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
6012 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
6015 Make_Selected_Component (Loc,
6017 Make_Explicit_Dereference (Loc,
6018 Unchecked_Convert_To (
6019 Entry_Parameters_Type (Ent),
6020 New_Occurrence_Of (Ann, Loc))),
6022 New_Occurrence_Of (Comp, Loc));
6025 Build_Renamed_Formal_Declaration
6026 (New_F, Formal, Comp, Renamed_Formal);
6028 if No (Declarations (N)) then
6029 Set_Declarations (N, New_List);
6032 Append (Decl, Declarations (N));
6033 Set_Renamed_Object (Formal, New_F);
6034 Next_Formal (Formal);
6041 end Expand_Accept_Declarations;
6043 ---------------------------------------------
6044 -- Expand_Access_Protected_Subprogram_Type --
6045 ---------------------------------------------
6047 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
6048 Loc : constant Source_Ptr := Sloc (N);
6049 T : constant Entity_Id := Defining_Identifier (N);
6050 D_T : constant Entity_Id := Designated_Type (T);
6051 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D');
6052 E_T : constant Entity_Id := Make_Temporary (Loc, 'E');
6053 P_List : constant List_Id :=
6054 Build_Protected_Spec (N, RTE (RE_Address), D_T, False);
6062 -- Create access to subprogram with full signature
6064 if Etype (D_T) /= Standard_Void_Type then
6066 Make_Access_Function_Definition (Loc,
6067 Parameter_Specifications => P_List,
6068 Result_Definition =>
6069 Copy_Result_Type (Result_Definition (Type_Definition (N))));
6073 Make_Access_Procedure_Definition (Loc,
6074 Parameter_Specifications => P_List);
6078 Make_Full_Type_Declaration (Loc,
6079 Defining_Identifier => D_T2,
6080 Type_Definition => Def1);
6082 -- Declare the new types before the original one since the latter will
6083 -- refer to them through the Equivalent_Type slot.
6085 Insert_Before_And_Analyze (N, Decl1);
6087 -- Associate the access to subprogram with its original access to
6088 -- protected subprogram type. Needed by the backend to know that this
6089 -- type corresponds with an access to protected subprogram type.
6091 Set_Original_Access_Type (D_T2, T);
6093 -- Create Equivalent_Type, a record with two components for an access to
6094 -- object and an access to subprogram.
6097 Make_Component_Declaration (Loc,
6098 Defining_Identifier => Make_Temporary (Loc, 'P'),
6099 Component_Definition =>
6100 Make_Component_Definition (Loc,
6101 Aliased_Present => False,
6102 Subtype_Indication =>
6103 New_Occurrence_Of (RTE (RE_Address), Loc))),
6105 Make_Component_Declaration (Loc,
6106 Defining_Identifier => Make_Temporary (Loc, 'S'),
6107 Component_Definition =>
6108 Make_Component_Definition (Loc,
6109 Aliased_Present => False,
6110 Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
6113 Make_Full_Type_Declaration (Loc,
6114 Defining_Identifier => E_T,
6116 Make_Record_Definition (Loc,
6118 Make_Component_List (Loc, Component_Items => Comps)));
6120 Insert_Before_And_Analyze (N, Decl2);
6121 Set_Equivalent_Type (T, E_T);
6122 end Expand_Access_Protected_Subprogram_Type;
6124 --------------------------
6125 -- Expand_Entry_Barrier --
6126 --------------------------
6128 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
6129 Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N));
6130 Prot : constant Entity_Id := Scope (Ent);
6131 Spec_Decl : constant Node_Id := Parent (Prot);
6133 Func_Id : Entity_Id := Empty;
6134 -- The entity of the barrier function
6136 function Is_Global_Entity (N : Node_Id) return Traverse_Result;
6137 -- Check whether entity in Barrier is external to protected type.
6138 -- If so, barrier may not be properly synchronized.
6140 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
6141 -- Check whether N meets the Pure_Barriers restriction. Return OK if
6144 function Is_Simple_Barrier (N : Node_Id) return Boolean;
6145 -- Check whether N meets the Simple_Barriers restriction. Return OK if
6148 ----------------------
6149 -- Is_Global_Entity --
6150 ----------------------
6152 function Is_Global_Entity (N : Node_Id) return Traverse_Result is
6157 if Is_Entity_Name (N) and then Present (Entity (N)) then
6161 if Ekind (E) = E_Variable then
6163 -- If the variable is local to the barrier function generated
6164 -- during expansion, it is ok. If expansion is not performed,
6165 -- then Func is Empty so this test cannot succeed.
6167 if Scope (E) = Func_Id then
6170 -- A protected call from a barrier to another object is ok
6172 elsif Ekind (Etype (E)) = E_Protected_Type then
6175 -- If the variable is within the package body we consider
6176 -- this safe. This is a common (if dubious) idiom.
6178 elsif S = Scope (Prot)
6179 and then Is_Package_Or_Generic_Package (S)
6180 and then Nkind (Parent (E)) = N_Object_Declaration
6181 and then Nkind (Parent (Parent (E))) = N_Package_Body
6186 Error_Msg_N ("potentially unsynchronized barrier??", N);
6187 Error_Msg_N ("\& should be private component of type??", N);
6193 end Is_Global_Entity;
6195 procedure Check_Unprotected_Barrier is
6196 new Traverse_Proc (Is_Global_Entity);
6198 -----------------------
6199 -- Is_Simple_Barrier --
6200 -----------------------
6202 function Is_Simple_Barrier (N : Node_Id) return Boolean is
6206 if Is_Static_Expression (N) then
6208 elsif Ada_Version >= Ada_2020
6209 and then Nkind (N) in N_Selected_Component | N_Indexed_Component
6210 and then Statically_Names_Object (N)
6212 -- Restriction relaxed in Ada2020 to allow statically named
6214 return Is_Simple_Barrier (Prefix (N));
6217 -- Check if the name is a component of the protected object. If
6218 -- the expander is active, the component has been transformed into a
6219 -- renaming of _object.all.component. Original_Node is needed in case
6220 -- validity checking is enabled, in which case the simple object
6221 -- reference will have been rewritten.
6223 if Expander_Active then
6225 -- The expanded name may have been constant folded in which case
6226 -- the original node is not necessarily an entity name (e.g. an
6227 -- indexed component).
6229 if not Is_Entity_Name (Original_Node (N)) then
6233 Renamed := Renamed_Object (Entity (Original_Node (N)));
6237 and then Nkind (Renamed) = N_Selected_Component
6238 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
6239 elsif not Is_Entity_Name (N) then
6242 return Is_Protected_Component (Entity (N));
6244 end Is_Simple_Barrier;
6246 ---------------------
6247 -- Is_Pure_Barrier --
6248 ---------------------
6250 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
6253 when N_Expanded_Name
6257 -- Because of N_Expanded_Name case, return Skip instead of OK.
6259 if No (Entity (N)) then
6262 elsif Is_Numeric_Type (Entity (N)) then
6266 case Ekind (Entity (N)) is
6272 when E_Enumeration_Literal
6276 if not Is_OK_Static_Expression (N) then
6285 if Is_Simple_Barrier (N) then
6291 -- The count attribute has been transformed into run-time
6294 if Is_RTE (Entity (N), RE_Protected_Count)
6295 or else Is_RTE (Entity (N), RE_Protected_Count_Entry)
6304 when N_Function_Call =>
6306 -- Function call checks are carried out as part of the analysis
6307 -- of the function call name.
6311 when N_Character_Literal
6320 if Ekind (Entity (N)) = E_Operator then
6324 when N_Short_Circuit
6330 when N_Indexed_Component | N_Selected_Component =>
6331 if Statically_Names_Object (N) then
6332 return Is_Pure_Barrier (Prefix (N));
6337 when N_Case_Expression_Alternative =>
6338 -- do not traverse Discrete_Choices subtree
6339 if Is_Pure_Barrier (Expression (N)) /= Abandon then
6343 when N_Expression_With_Actions =>
6344 -- this may occur in the case of a Count attribute reference
6345 if Original_Node (N) /= N
6346 and then Is_Pure_Barrier (Original_Node (N)) /= Abandon
6351 when N_Membership_Test =>
6352 if Is_Pure_Barrier (Left_Opnd (N)) /= Abandon
6353 and then All_Membership_Choices_Static (N)
6358 when N_Type_Conversion =>
6360 -- Conversions to Universal_Integer do not raise constraint
6361 -- errors. Likewise if the expression's type is statically
6362 -- compatible with the target's type.
6364 if Etype (N) = Universal_Integer
6365 or else Subtypes_Statically_Compatible
6366 (Etype (Expression (N)), Etype (N))
6371 when N_Unchecked_Type_Conversion =>
6379 end Is_Pure_Barrier;
6381 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier);
6385 Cond_Id : Entity_Id;
6386 Entry_Body : Node_Id;
6387 Func_Body : Node_Id := Empty;
6389 -- Start of processing for Expand_Entry_Barrier
6392 if No_Run_Time_Mode then
6393 Error_Msg_CRT ("entry barrier", N);
6397 -- Prevent cascaded errors
6399 if Nkind (Cond) = N_Error then
6403 -- The body of the entry barrier must be analyzed in the context of the
6404 -- protected object, but its scope is external to it, just as any other
6405 -- unprotected version of a protected operation. The specification has
6406 -- been produced when the protected type declaration was elaborated. We
6407 -- build the body, insert it in the enclosing scope, but analyze it in
6408 -- the current context. A more uniform approach would be to treat the
6409 -- barrier just as a protected function, and discard the protected
6410 -- version of it because it is never called.
6412 if Expander_Active then
6413 Func_Body := Build_Barrier_Function (N, Ent, Prot);
6414 Func_Id := Barrier_Function (Ent);
6415 Set_Corresponding_Spec (Func_Body, Func_Id);
6417 Entry_Body := Parent (Corresponding_Body (Spec_Decl));
6419 if Nkind (Parent (Entry_Body)) = N_Subunit then
6420 Entry_Body := Corresponding_Stub (Parent (Entry_Body));
6423 Insert_Before_And_Analyze (Entry_Body, Func_Body);
6425 Set_Discriminals (Spec_Decl);
6426 Set_Scope (Func_Id, Scope (Prot));
6429 Analyze_And_Resolve (Cond, Any_Boolean);
6432 -- Check Simple_Barriers and Pure_Barriers restrictions.
6433 -- Note that it is safe to be calling Check_Restriction from here, even
6434 -- though this is part of the expander, since Expand_Entry_Barrier is
6435 -- called from Sem_Ch9 even in -gnatc mode.
6437 if not Is_Simple_Barrier (Cond) then
6438 -- flag restriction violation
6439 Check_Restriction (Simple_Barriers, Cond);
6442 if Check_Pure_Barriers (Cond) = Abandon then
6443 -- flag restriction violation
6444 Check_Restriction (Pure_Barriers, Cond);
6446 -- Emit warning if barrier contains global entities and is thus
6447 -- potentially unsynchronized (if Pure_Barriers restrictions
6448 -- are met then no need to check for this).
6449 Check_Unprotected_Barrier (Cond);
6452 if Is_Entity_Name (Cond) then
6453 Cond_Id := Entity (Cond);
6455 -- Perform a small optimization of simple barrier functions. If the
6456 -- scope of the condition's entity is not the barrier function, then
6457 -- the condition does not depend on any of the generated renamings.
6458 -- If this is the case, eliminate the renamings as they are useless.
6459 -- This optimization is not performed when the condition was folded
6460 -- and validity checks are in effect because the original condition
6461 -- may have produced at least one check that depends on the generated
6465 and then Scope (Cond_Id) /= Func_Id
6466 and then not Validity_Check_Operands
6468 Set_Declarations (Func_Body, Empty_List);
6471 -- Note that after analysis variables in this context will be
6472 -- replaced by the corresponding prival, that is to say a renaming
6473 -- of a selected component of the form _Object.Var. If expansion is
6474 -- disabled, as within a generic, we check that the entity appears in
6475 -- the current scope.
6477 end Expand_Entry_Barrier;
6479 ------------------------------
6480 -- Expand_N_Abort_Statement --
6481 ------------------------------
6483 -- Expand abort T1, T2, .. Tn; into:
6484 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6486 procedure Expand_N_Abort_Statement (N : Node_Id) is
6487 Loc : constant Source_Ptr := Sloc (N);
6488 Tlist : constant List_Id := Names (N);
6494 Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
6497 Tasknm := First (Tlist);
6499 while Present (Tasknm) loop
6502 -- A task interface class-wide type object is being aborted. Retrieve
6503 -- its _task_id by calling a dispatching routine.
6505 if Ada_Version >= Ada_2005
6506 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
6507 and then Is_Interface (Etype (Tasknm))
6508 and then Is_Task_Interface (Etype (Tasknm))
6510 Append_To (Component_Associations (Aggr),
6511 Make_Component_Association (Loc,
6512 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6515 -- Task_Id (Tasknm._disp_get_task_id)
6517 Make_Unchecked_Type_Conversion (Loc,
6519 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6521 Make_Selected_Component (Loc,
6522 Prefix => New_Copy_Tree (Tasknm),
6524 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
6527 Append_To (Component_Associations (Aggr),
6528 Make_Component_Association (Loc,
6529 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6530 Expression => Concurrent_Ref (Tasknm)));
6537 Make_Procedure_Call_Statement (Loc,
6538 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc),
6539 Parameter_Associations => New_List (
6540 Make_Qualified_Expression (Loc,
6541 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc),
6542 Expression => Aggr))));
6545 end Expand_N_Abort_Statement;
6547 -------------------------------
6548 -- Expand_N_Accept_Statement --
6549 -------------------------------
6551 -- This procedure handles expansion of accept statements that stand alone,
6552 -- i.e. they are not part of an accept alternative. The expansion of
6553 -- accept statement in accept alternatives is handled by the routines
6554 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6555 -- following description applies only to stand alone accept statements.
6557 -- If there is no handled statement sequence, or only null statements, then
6558 -- this is called a trivial accept, and the expansion is:
6560 -- Accept_Trivial (entry-index)
6562 -- If there is a handled statement sequence, then the expansion is:
6569 -- Accept_Call (entry-index, Ann);
6570 -- Renaming_Declarations for formals
6571 -- <statement sequence from N_Accept_Statement node>
6572 -- Complete_Rendezvous;
6577 -- <exception handler from N_Accept_Statement node>
6578 -- Complete_Rendezvous;
6580 -- <exception handler from N_Accept_Statement node>
6581 -- Complete_Rendezvous;
6586 -- when all others =>
6587 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6590 -- The first three declarations were already inserted ahead of the accept
6591 -- statement by the Expand_Accept_Declarations procedure, which was called
6592 -- directly from the semantics during analysis of the accept statement,
6593 -- before analyzing its contained statements.
6595 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6596 -- from possible expansion activity (the original source of course does
6597 -- not have any declarations associated with the accept statement, since
6598 -- an accept statement has no declarative part). In particular, if the
6599 -- expander is active, the first such declaration is the declaration of
6600 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6602 -- The two blocks are merged into a single block if the inner block has
6603 -- no exception handlers, but otherwise two blocks are required, since
6604 -- exceptions might be raised in the exception handlers of the inner
6605 -- block, and Exceptional_Complete_Rendezvous must be called.
6607 procedure Expand_N_Accept_Statement (N : Node_Id) is
6608 Loc : constant Source_Ptr := Sloc (N);
6609 Stats : constant Node_Id := Handled_Statement_Sequence (N);
6610 Ename : constant Node_Id := Entry_Direct_Name (N);
6611 Eindx : constant Node_Id := Entry_Index (N);
6612 Eent : constant Entity_Id := Entity (Ename);
6613 Acstack : constant Elist_Id := Accept_Address (Eent);
6614 Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
6615 Ttyp : constant Entity_Id := Etype (Scope (Eent));
6621 -- If the accept statement is not part of a list, then its parent must
6622 -- be an accept alternative, and, as described above, we do not do any
6623 -- expansion for such accept statements at this level.
6625 if not Is_List_Member (N) then
6626 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
6629 -- Trivial accept case (no statement sequence, or null statements).
6630 -- If the accept statement has declarations, then just insert them
6631 -- before the procedure call.
6633 elsif Trivial_Accept_OK
6634 and then (No (Stats) or else Null_Statements (Statements (Stats)))
6636 -- Remove declarations for renamings, because the parameter block
6637 -- will not be assigned.
6644 D := First (Declarations (N));
6645 while Present (D) loop
6647 if Nkind (D) = N_Object_Renaming_Declaration then
6655 if Present (Declarations (N)) then
6656 Insert_Actions (N, Declarations (N));
6660 Make_Procedure_Call_Statement (Loc,
6661 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc),
6662 Parameter_Associations => New_List (
6663 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
6667 -- Ada 2020 (AI12-0279)
6669 if Has_Yield_Aspect (Eent)
6670 and then RTE_Available (RE_Yield)
6672 Insert_Action_After (N,
6673 Make_Procedure_Call_Statement (Loc,
6674 New_Occurrence_Of (RTE (RE_Yield), Loc)));
6677 -- Discard Entry_Address that was created for it, so it will not be
6678 -- emitted if this accept statement is in the statement part of a
6679 -- delay alternative.
6681 if Present (Stats) then
6682 Remove_Last_Elmt (Acstack);
6685 -- Case of statement sequence present
6688 -- Construct the block, using the declarations from the accept
6689 -- statement if any to initialize the declarations of the block.
6691 Blkent := Make_Temporary (Loc, 'A');
6692 Set_Ekind (Blkent, E_Block);
6693 Set_Etype (Blkent, Standard_Void_Type);
6694 Set_Scope (Blkent, Current_Scope);
6697 Make_Block_Statement (Loc,
6698 Identifier => New_Occurrence_Of (Blkent, Loc),
6699 Declarations => Declarations (N),
6700 Handled_Statement_Sequence => Build_Accept_Body (N));
6702 -- Reset the Scope of local entities associated with the accept
6703 -- statement (that currently reference the entry scope) to the
6704 -- block scope, to avoid having references to the locals treated
6705 -- as up-level references.
6707 Reset_Scopes_To (Block, Blkent);
6709 -- For the analysis of the generated declarations, the parent node
6710 -- must be properly set.
6712 Set_Parent (Block, Parent (N));
6713 Set_Parent (Blkent, Block);
6715 -- Prepend call to Accept_Call to main statement sequence If the
6716 -- accept has exception handlers, the statement sequence is wrapped
6717 -- in a block. Insert call and renaming declarations in the
6718 -- declarations of the block, so they are elaborated before the
6722 Make_Procedure_Call_Statement (Loc,
6723 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc),
6724 Parameter_Associations => New_List (
6725 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
6726 New_Occurrence_Of (Ann, Loc)));
6728 if Parent (Stats) = N then
6729 Prepend (Call, Statements (Stats));
6731 Set_Declarations (Parent (Stats), New_List (Call));
6736 Push_Scope (Blkent);
6744 D := First (Declarations (N));
6745 while Present (D) loop
6748 if Nkind (D) = N_Object_Renaming_Declaration then
6750 -- The renaming declarations for the formals were created
6751 -- during analysis of the accept statement, and attached to
6752 -- the list of declarations. Place them now in the context
6753 -- of the accept block or subprogram.
6756 Typ := Entity (Subtype_Mark (D));
6757 Insert_After (Call, D);
6760 -- If the formal is class_wide, it does not have an actual
6761 -- subtype. The analysis of the renaming declaration creates
6762 -- one, but we need to retain the class-wide nature of the
6765 if Is_Class_Wide_Type (Typ) then
6766 Set_Etype (Defining_Identifier (D), Typ);
6777 -- Replace the accept statement by the new block
6782 -- Last step is to unstack the Accept_Address value
6784 Remove_Last_Elmt (Acstack);
6786 end Expand_N_Accept_Statement;
6788 ----------------------------------
6789 -- Expand_N_Asynchronous_Select --
6790 ----------------------------------
6792 -- This procedure assumes that the trigger statement is an entry call or
6793 -- a dispatching procedure call. A delay alternative should already have
6794 -- been expanded into an entry call to the appropriate delay object Wait
6797 -- If the trigger is a task entry call, the select is implemented with
6798 -- a Task_Entry_Call:
6803 -- P : parms := (parm, parm, parm);
6805 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6807 -- procedure _clean is
6810 -- Cancel_Task_Entry_Call (C);
6817 -- (<acceptor-task>, -- Acceptor
6818 -- <entry-index>, -- E
6819 -- P'Address, -- Uninterpreted_Data
6820 -- Asynchronous_Call, -- Mode
6821 -- B); -- Rendezvous_Successful
6828 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6831 -- when Abort_Signal => Abort_Undefer;
6838 -- <triggered-statements>
6842 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6843 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6847 -- P : parms := (parm, parm, parm);
6849 -- Call_Simple (acceptor-task, entry-index, P'Address);
6855 -- so the task at hand is to convert the latter expansion into the former
6857 -- If the trigger is a protected entry call, the select is implemented
6858 -- with Protected_Entry_Call:
6861 -- P : E1_Params := (param, param, param);
6862 -- Bnn : Communications_Block;
6867 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6869 -- procedure _clean is
6872 -- if Enqueued (Bnn) then
6873 -- Cancel_Protected_Entry_Call (Bnn);
6880 -- Protected_Entry_Call
6881 -- (po._object'Access, -- Object
6882 -- <entry index>, -- E
6883 -- P'Address, -- Uninterpreted_Data
6884 -- Asynchronous_Call, -- Mode
6887 -- if Enqueued (Bnn) then
6891 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6894 -- when Abort_Signal => Abort_Undefer;
6897 -- if not Cancelled (Bnn) then
6898 -- <triggered-statements>
6902 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6906 -- P : E1_Params := (param, param, param);
6907 -- Bnn : Communications_Block;
6910 -- Protected_Entry_Call
6911 -- (po._object'Access, -- Object
6912 -- <entry index>, -- E
6913 -- P'Address, -- Uninterpreted_Data
6914 -- Simple_Call, -- Mode
6921 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6925 -- B : Boolean := False;
6926 -- Bnn : Communication_Block;
6927 -- C : Ada.Tags.Prim_Op_Kind;
6928 -- D : System.Storage_Elements.Dummy_Communication_Block;
6929 -- K : Ada.Tags.Tagged_Kind :=
6930 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6931 -- P : Parameters := (Param1 .. ParamN);
6936 -- if K = Ada.Tags.TK_Limited_Tagged
6937 -- or else K = Ada.Tags.TK_Tagged
6939 -- <dispatching-call>;
6940 -- <triggering-statements>;
6944 -- Ada.Tags.Get_Offset_Index
6945 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6947 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6949 -- if C = POK_Protected_Entry then
6951 -- procedure _clean is
6953 -- if Enqueued (Bnn) then
6954 -- Cancel_Protected_Entry_Call (Bnn);
6960 -- _Disp_Asynchronous_Select
6961 -- (<object>, S, P'Address, D, B);
6962 -- Bnn := Communication_Block (D);
6964 -- Param1 := P.Param1;
6966 -- ParamN := P.ParamN;
6968 -- if Enqueued (Bnn) then
6969 -- <abortable-statements>
6972 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6975 -- when Abort_Signal => Abort_Undefer;
6978 -- if not Cancelled (Bnn) then
6979 -- <triggering-statements>
6982 -- elsif C = POK_Task_Entry then
6984 -- procedure _clean is
6986 -- Cancel_Task_Entry_Call (U);
6992 -- _Disp_Asynchronous_Select
6993 -- (<object>, S, P'Address, D, B);
6994 -- Bnn := Communication_Bloc (D);
6996 -- Param1 := P.Param1;
6998 -- ParamN := P.ParamN;
7003 -- <abortable-statements>
7005 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7008 -- when Abort_Signal => Abort_Undefer;
7012 -- <triggering-statements>
7017 -- <dispatching-call>;
7018 -- <triggering-statements>
7023 -- The job is to convert this to the asynchronous form
7025 -- If the trigger is a delay statement, it will have been expanded into
7026 -- a call to one of the GNARL delay procedures. This routine will convert
7027 -- this into a protected entry call on a delay object and then continue
7028 -- processing as for a protected entry call trigger. This requires
7029 -- declaring a Delay_Block object and adding a pointer to this object to
7030 -- the parameter list of the delay procedure to form the parameter list of
7031 -- the entry call. This object is used by the runtime to queue the delay
7034 -- For a description of the use of P and the assignments after the call,
7035 -- see Expand_N_Entry_Call_Statement.
7037 procedure Expand_N_Asynchronous_Select (N : Node_Id) is
7038 Loc : constant Source_Ptr := Sloc (N);
7039 Abrt : constant Node_Id := Abortable_Part (N);
7040 Trig : constant Node_Id := Triggering_Alternative (N);
7042 Abort_Block_Ent : Entity_Id;
7043 Abortable_Block : Node_Id;
7046 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A');
7047 Blk_Typ : Entity_Id;
7049 Call_Ent : Entity_Id;
7050 Cancel_Param : Entity_Id;
7051 Cleanup_Block : Node_Id;
7052 Cleanup_Block_Ent : Entity_Id;
7053 Cleanup_Stmts : List_Id;
7054 Conc_Typ_Stmts : List_Id;
7056 Dblock_Ent : Entity_Id;
7061 Enqueue_Call : Node_Id;
7065 Lim_Typ_Stmts : List_Id;
7071 ProtE_Stmts : List_Id;
7072 ProtP_Stmts : List_Id;
7075 TaskE_Stmts : List_Id;
7078 B : Entity_Id; -- Call status flag
7079 Bnn : Entity_Id; -- Communication block
7080 C : Entity_Id; -- Call kind
7081 K : Entity_Id; -- Tagged kind
7082 P : Entity_Id; -- Parameter block
7083 S : Entity_Id; -- Primitive operation slot
7084 T : Entity_Id; -- Additional status flag
7086 procedure Rewrite_Abortable_Part;
7087 -- If the trigger is a dispatching call, the expansion inserts multiple
7088 -- copies of the abortable part. This is both inefficient, and may lead
7089 -- to duplicate definitions that the back-end will reject, when the
7090 -- abortable part includes loops. This procedure rewrites the abortable
7091 -- part into a call to a generated procedure.
7093 ----------------------------
7094 -- Rewrite_Abortable_Part --
7095 ----------------------------
7097 procedure Rewrite_Abortable_Part is
7098 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
7103 Make_Subprogram_Body (Loc,
7105 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
7106 Declarations => New_List,
7107 Handled_Statement_Sequence =>
7108 Make_Handled_Sequence_Of_Statements (Loc, Astats));
7109 Insert_Before (N, Decl);
7112 -- Rewrite abortable part into a call to this procedure
7116 Make_Procedure_Call_Statement (Loc,
7117 Name => New_Occurrence_Of (Proc, Loc)));
7118 end Rewrite_Abortable_Part;
7120 -- Start of processing for Expand_N_Asynchronous_Select
7123 -- Asynchronous select is not supported on restricted runtimes. Don't
7126 if Restricted_Profile then
7130 Process_Statements_For_Controlled_Objects (Trig);
7131 Process_Statements_For_Controlled_Objects (Abrt);
7133 Ecall := Triggering_Statement (Trig);
7135 Ensure_Statement_Present (Sloc (Ecall), Trig);
7137 -- Retrieve Astats and Tstats now because the finalization machinery may
7138 -- wrap them in blocks.
7140 Astats := Statements (Abrt);
7141 Tstats := Statements (Trig);
7143 -- The arguments in the call may require dynamic allocation, and the
7144 -- call statement may have been transformed into a block. The block
7145 -- may contain additional declarations for internal entities, and the
7146 -- original call is found by sequential search.
7148 if Nkind (Ecall) = N_Block_Statement then
7149 Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
7150 while Nkind (Ecall) not in
7151 N_Procedure_Call_Statement | N_Entry_Call_Statement
7157 -- This is either a dispatching call or a delay statement used as a
7158 -- trigger which was expanded into a procedure call.
7160 if Nkind (Ecall) = N_Procedure_Call_Statement then
7161 if Ada_Version >= Ada_2005
7163 (No (Original_Node (Ecall))
7164 or else Nkind (Original_Node (Ecall)) not in N_Delay_Statement)
7166 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
7168 Rewrite_Abortable_Part;
7172 -- Call status flag processing, generate:
7173 -- B : Boolean := False;
7175 B := Build_B (Loc, Decls);
7177 -- Communication block processing, generate:
7178 -- Bnn : Communication_Block;
7180 Bnn := Make_Temporary (Loc, 'B');
7182 Make_Object_Declaration (Loc,
7183 Defining_Identifier => Bnn,
7184 Object_Definition =>
7185 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
7187 -- Call kind processing, generate:
7188 -- C : Ada.Tags.Prim_Op_Kind;
7190 C := Build_C (Loc, Decls);
7192 -- Tagged kind processing, generate:
7193 -- K : Ada.Tags.Tagged_Kind :=
7194 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7196 -- Dummy communication block, generate:
7197 -- D : Dummy_Communication_Block;
7200 Make_Object_Declaration (Loc,
7201 Defining_Identifier =>
7202 Make_Defining_Identifier (Loc, Name_uD),
7203 Object_Definition =>
7205 (RTE (RE_Dummy_Communication_Block), Loc)));
7207 K := Build_K (Loc, Decls, Obj);
7209 -- Parameter block processing
7211 Blk_Typ := Build_Parameter_Block
7212 (Loc, Actuals, Formals, Decls);
7213 P := Parameter_Block_Pack
7214 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
7216 -- Dispatch table slot processing, generate:
7219 S := Build_S (Loc, Decls);
7221 -- Additional status flag processing, generate:
7224 T := Make_Temporary (Loc, 'T');
7226 Make_Object_Declaration (Loc,
7227 Defining_Identifier => T,
7228 Object_Definition =>
7229 New_Occurrence_Of (Standard_Boolean, Loc)));
7231 ------------------------------
7232 -- Protected entry handling --
7233 ------------------------------
7236 -- Param1 := P.Param1;
7238 -- ParamN := P.ParamN;
7240 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7243 -- Bnn := Communication_Block (D);
7245 Prepend_To (Cleanup_Stmts,
7246 Make_Assignment_Statement (Loc,
7247 Name => New_Occurrence_Of (Bnn, Loc),
7249 Make_Unchecked_Type_Conversion (Loc,
7251 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7252 Expression => Make_Identifier (Loc, Name_uD))));
7255 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7257 Prepend_To (Cleanup_Stmts,
7258 Make_Procedure_Call_Statement (Loc,
7262 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select),
7264 Parameter_Associations =>
7266 New_Copy_Tree (Obj), -- <object>
7267 New_Occurrence_Of (S, Loc), -- S
7268 Make_Attribute_Reference (Loc, -- P'Address
7269 Prefix => New_Occurrence_Of (P, Loc),
7270 Attribute_Name => Name_Address),
7271 Make_Identifier (Loc, Name_uD), -- D
7272 New_Occurrence_Of (B, Loc)))); -- B
7275 -- if Enqueued (Bnn) then
7276 -- <abortable-statements>
7279 Append_To (Cleanup_Stmts,
7280 Make_Implicit_If_Statement (N,
7282 Make_Function_Call (Loc,
7284 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7285 Parameter_Associations =>
7286 New_List (New_Occurrence_Of (Bnn, Loc))),
7289 New_Copy_List_Tree (Astats)));
7291 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7292 -- will then generate a _clean for the communication block Bnn.
7296 -- procedure _clean is
7298 -- if Enqueued (Bnn) then
7299 -- Cancel_Protected_Entry_Call (Bnn);
7308 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7310 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
7312 -- Wrap the cleanup block in an exception handling block
7318 -- when Abort_Signal => Abort_Undefer;
7321 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7324 Make_Implicit_Label_Declaration (Loc,
7325 Defining_Identifier => Abort_Block_Ent),
7328 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7331 -- if not Cancelled (Bnn) then
7332 -- <triggering-statements>
7335 Append_To (ProtE_Stmts,
7336 Make_Implicit_If_Statement (N,
7340 Make_Function_Call (Loc,
7342 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7343 Parameter_Associations =>
7344 New_List (New_Occurrence_Of (Bnn, Loc)))),
7347 New_Copy_List_Tree (Tstats)));
7349 -------------------------
7350 -- Task entry handling --
7351 -------------------------
7354 -- Param1 := P.Param1;
7356 -- ParamN := P.ParamN;
7358 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7361 -- Bnn := Communication_Block (D);
7363 Append_To (TaskE_Stmts,
7364 Make_Assignment_Statement (Loc,
7366 New_Occurrence_Of (Bnn, Loc),
7368 Make_Unchecked_Type_Conversion (Loc,
7370 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7371 Expression => Make_Identifier (Loc, Name_uD))));
7374 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7376 Prepend_To (TaskE_Stmts,
7377 Make_Procedure_Call_Statement (Loc,
7380 Find_Prim_Op (Etype (Etype (Obj)),
7381 Name_uDisp_Asynchronous_Select),
7384 Parameter_Associations => New_List (
7385 New_Copy_Tree (Obj), -- <object>
7386 New_Occurrence_Of (S, Loc), -- S
7387 Make_Attribute_Reference (Loc, -- P'Address
7388 Prefix => New_Occurrence_Of (P, Loc),
7389 Attribute_Name => Name_Address),
7390 Make_Identifier (Loc, Name_uD), -- D
7391 New_Occurrence_Of (B, Loc)))); -- B
7396 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7400 -- <abortable-statements>
7402 Cleanup_Stmts := New_Copy_List_Tree (Astats);
7405 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7407 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7408 -- will generate a _clean for the additional status flag.
7412 -- procedure _clean is
7414 -- Cancel_Task_Entry_Call (U);
7422 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7424 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
7426 -- Wrap the cleanup block in an exception handling block
7432 -- when Abort_Signal => Abort_Undefer;
7435 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7437 Append_To (TaskE_Stmts,
7438 Make_Implicit_Label_Declaration (Loc,
7439 Defining_Identifier => Abort_Block_Ent));
7441 Append_To (TaskE_Stmts,
7443 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7447 -- <triggering-statements>
7450 Append_To (TaskE_Stmts,
7451 Make_Implicit_If_Statement (N,
7453 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)),
7456 New_Copy_List_Tree (Tstats)));
7458 ----------------------------------
7459 -- Protected procedure handling --
7460 ----------------------------------
7463 -- <dispatching-call>;
7464 -- <triggering-statements>
7466 ProtP_Stmts := New_Copy_List_Tree (Tstats);
7467 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
7470 -- S := Ada.Tags.Get_Offset_Index
7471 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7474 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
7477 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7479 Append_To (Conc_Typ_Stmts,
7480 Make_Procedure_Call_Statement (Loc,
7483 (Find_Prim_Op (Etype (Etype (Obj)),
7484 Name_uDisp_Get_Prim_Op_Kind),
7486 Parameter_Associations =>
7488 New_Copy_Tree (Obj),
7489 New_Occurrence_Of (S, Loc),
7490 New_Occurrence_Of (C, Loc))));
7493 -- if C = POK_Procedure_Entry then
7495 -- elsif C = POK_Task_Entry then
7501 Append_To (Conc_Typ_Stmts,
7502 Make_Implicit_If_Statement (N,
7506 New_Occurrence_Of (C, Loc),
7508 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
7515 Make_Elsif_Part (Loc,
7519 New_Occurrence_Of (C, Loc),
7521 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)),
7530 -- <dispatching-call>;
7531 -- <triggering-statements>
7533 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
7534 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
7537 -- if K = Ada.Tags.TK_Limited_Tagged
7538 -- or else K = Ada.Tags.TK_Tagged
7546 Make_Implicit_If_Statement (N,
7547 Condition => Build_Dispatching_Tag_Check (K, N),
7548 Then_Statements => Lim_Typ_Stmts,
7549 Else_Statements => Conc_Typ_Stmts));
7552 Make_Block_Statement (Loc,
7555 Handled_Statement_Sequence =>
7556 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7561 -- Delay triggering statement processing
7564 -- Add a Delay_Block object to the parameter list of the delay
7565 -- procedure to form the parameter list of the Wait entry call.
7567 Dblock_Ent := Make_Temporary (Loc, 'D');
7569 Pdef := Entity (Name (Ecall));
7571 if Is_RTE (Pdef, RO_CA_Delay_For) then
7573 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc);
7575 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
7577 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc);
7579 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
7580 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc);
7583 Append_To (Parameter_Associations (Ecall),
7584 Make_Attribute_Reference (Loc,
7585 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7586 Attribute_Name => Name_Unchecked_Access));
7588 -- Create the inner block to protect the abortable part
7590 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7592 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7595 Make_Block_Statement (Loc,
7596 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7597 Handled_Statement_Sequence =>
7598 Make_Handled_Sequence_Of_Statements (Loc,
7599 Statements => Astats),
7600 Has_Created_Identifier => True,
7601 Is_Asynchronous_Call_Block => True);
7603 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7606 Make_Implicit_If_Statement (N,
7608 Make_Function_Call (Loc,
7609 Name => Enqueue_Call,
7610 Parameter_Associations => Parameter_Associations (Ecall)),
7612 New_List (Make_Block_Statement (Loc,
7613 Handled_Statement_Sequence =>
7614 Make_Handled_Sequence_Of_Statements (Loc,
7615 Statements => New_List (
7616 Make_Implicit_Label_Declaration (Loc,
7617 Defining_Identifier => Blk_Ent,
7618 Label_Construct => Abortable_Block),
7620 Exception_Handlers => Hdle)))));
7622 Stmts := New_List (Ecall);
7624 -- Construct statement sequence for new block
7627 Make_Implicit_If_Statement (N,
7629 Make_Function_Call (Loc,
7630 Name => New_Occurrence_Of (
7631 RTE (RE_Timed_Out), Loc),
7632 Parameter_Associations => New_List (
7633 Make_Attribute_Reference (Loc,
7634 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7635 Attribute_Name => Name_Unchecked_Access))),
7636 Then_Statements => Tstats));
7638 -- The result is the new block
7640 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
7643 Make_Block_Statement (Loc,
7644 Declarations => New_List (
7645 Make_Object_Declaration (Loc,
7646 Defining_Identifier => Dblock_Ent,
7647 Aliased_Present => True,
7648 Object_Definition =>
7649 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))),
7651 Handled_Statement_Sequence =>
7652 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7662 Extract_Entry (Ecall, Concval, Ename, Index);
7663 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
7665 Stmts := Statements (Handled_Statement_Sequence (Ecall));
7666 Decls := Declarations (Ecall);
7668 if Is_Protected_Type (Etype (Concval)) then
7670 -- Get the declarations of the block expanded from the entry call
7672 Decl := First (Decls);
7673 while Present (Decl)
7674 and then (Nkind (Decl) /= N_Object_Declaration
7675 or else not Is_RTE (Etype (Object_Definition (Decl)),
7676 RE_Communication_Block))
7681 pragma Assert (Present (Decl));
7682 Cancel_Param := Defining_Identifier (Decl);
7684 -- Change the mode of the Protected_Entry_Call call
7686 -- Protected_Entry_Call (
7687 -- Object => po._object'Access,
7688 -- E => <entry index>;
7689 -- Uninterpreted_Data => P'Address;
7690 -- Mode => Asynchronous_Call;
7693 -- Skip assignments to temporaries created for in-out parameters
7695 -- This makes unwarranted assumptions about the shape of the expanded
7696 -- tree for the call, and should be cleaned up ???
7698 Stmt := First (Stmts);
7699 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7705 Param := First (Parameter_Associations (Call));
7706 while Present (Param)
7707 and then not Is_RTE (Etype (Param), RE_Call_Modes)
7712 pragma Assert (Present (Param));
7713 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7716 -- Append an if statement to execute the abortable part
7719 -- if Enqueued (Bnn) then
7722 Make_Implicit_If_Statement (N,
7724 Make_Function_Call (Loc,
7725 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7726 Parameter_Associations => New_List (
7727 New_Occurrence_Of (Cancel_Param, Loc))),
7728 Then_Statements => Astats));
7731 Make_Block_Statement (Loc,
7732 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7733 Handled_Statement_Sequence =>
7734 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts),
7735 Has_Created_Identifier => True,
7736 Is_Asynchronous_Call_Block => True);
7739 Make_Block_Statement (Loc,
7740 Handled_Statement_Sequence =>
7741 Make_Handled_Sequence_Of_Statements (Loc,
7742 Statements => New_List (
7743 Make_Implicit_Label_Declaration (Loc,
7744 Defining_Identifier => Blk_Ent,
7745 Label_Construct => Abortable_Block),
7750 Exception_Handlers => New_List (
7751 Make_Implicit_Exception_Handler (Loc,
7753 -- when Abort_Signal =>
7756 Exception_Choices =>
7757 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
7758 Statements => New_List (Make_Null_Statement (Loc)))))),
7760 -- if not Cancelled (Bnn) then
7761 -- triggered statements
7764 Make_Implicit_If_Statement (N,
7765 Condition => Make_Op_Not (Loc,
7767 Make_Function_Call (Loc,
7768 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7769 Parameter_Associations => New_List (
7770 New_Occurrence_Of (Cancel_Param, Loc)))),
7771 Then_Statements => Tstats));
7773 -- Asynchronous task entry call
7780 B := Make_Defining_Identifier (Loc, Name_uB);
7782 -- Insert declaration of B in declarations of existing block
7785 Make_Object_Declaration (Loc,
7786 Defining_Identifier => B,
7787 Object_Definition =>
7788 New_Occurrence_Of (Standard_Boolean, Loc)));
7790 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
7792 -- Insert the declaration of C in the declarations of the existing
7793 -- block. The variable is initialized to something (True or False,
7794 -- does not matter) to prevent CodePeer from complaining about a
7795 -- possible read of an uninitialized variable.
7798 Make_Object_Declaration (Loc,
7799 Defining_Identifier => Cancel_Param,
7800 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
7801 Expression => New_Occurrence_Of (Standard_False, Loc),
7802 Has_Init_Expression => True));
7804 -- Remove and save the call to Call_Simple
7806 Stmt := First (Stmts);
7808 -- Skip assignments to temporaries created for in-out parameters.
7809 -- This makes unwarranted assumptions about the shape of the expanded
7810 -- tree for the call, and should be cleaned up ???
7812 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7818 -- Create the inner block to protect the abortable part
7820 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7822 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7825 Make_Block_Statement (Loc,
7826 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7827 Handled_Statement_Sequence =>
7828 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats),
7829 Has_Created_Identifier => True,
7830 Is_Asynchronous_Call_Block => True);
7833 Make_Block_Statement (Loc,
7834 Handled_Statement_Sequence =>
7835 Make_Handled_Sequence_Of_Statements (Loc,
7836 Statements => New_List (
7837 Make_Implicit_Label_Declaration (Loc,
7838 Defining_Identifier => Blk_Ent,
7839 Label_Construct => Abortable_Block),
7841 Exception_Handlers => Hdle)));
7843 -- Create new call statement
7845 Params := Parameter_Associations (Call);
7848 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7849 Append_To (Params, New_Occurrence_Of (B, Loc));
7852 Make_Procedure_Call_Statement (Loc,
7853 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
7854 Parameter_Associations => Params));
7856 -- Construct statement sequence for new block
7859 Make_Implicit_If_Statement (N,
7861 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)),
7862 Then_Statements => Tstats));
7864 -- Protected the call against abort
7866 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7869 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
7871 -- The result is the new block
7874 Make_Block_Statement (Loc,
7875 Declarations => Decls,
7876 Handled_Statement_Sequence =>
7877 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7880 end Expand_N_Asynchronous_Select;
7882 -------------------------------------
7883 -- Expand_N_Conditional_Entry_Call --
7884 -------------------------------------
7886 -- The conditional task entry call is converted to a call to
7891 -- P : parms := (parm, parm, parm);
7895 -- (<acceptor-task>, -- Acceptor
7896 -- <entry-index>, -- E
7897 -- P'Address, -- Uninterpreted_Data
7898 -- Conditional_Call, -- Mode
7899 -- B); -- Rendezvous_Successful
7904 -- normal-statements
7910 -- For a description of the use of P and the assignments after the call,
7911 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7912 -- conditional entry call has already been expanded (by the Expand_N_Entry
7913 -- _Call_Statement procedure) as follows:
7916 -- P : parms := (parm, parm, parm);
7918 -- ... info for in-out parameters
7919 -- Call_Simple (acceptor-task, entry-index, P'Address);
7925 -- so the task at hand is to convert the latter expansion into the former
7927 -- The conditional protected entry call is converted to a call to
7928 -- Protected_Entry_Call:
7931 -- P : parms := (parm, parm, parm);
7932 -- Bnn : Communications_Block;
7935 -- Protected_Entry_Call
7936 -- (po._object'Access, -- Object
7937 -- <entry index>, -- E
7938 -- P'Address, -- Uninterpreted_Data
7939 -- Conditional_Call, -- Mode
7944 -- if Cancelled (Bnn) then
7947 -- normal-statements
7951 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7955 -- B : Boolean := False;
7956 -- C : Ada.Tags.Prim_Op_Kind;
7957 -- K : Ada.Tags.Tagged_Kind :=
7958 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7959 -- P : Parameters := (Param1 .. ParamN);
7963 -- if K = Ada.Tags.TK_Limited_Tagged
7964 -- or else K = Ada.Tags.TK_Tagged
7966 -- <dispatching-call>;
7967 -- <triggering-statements>
7971 -- Ada.Tags.Get_Offset_Index
7972 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7974 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7976 -- if C = POK_Protected_Entry
7977 -- or else C = POK_Task_Entry
7979 -- Param1 := P.Param1;
7981 -- ParamN := P.ParamN;
7985 -- if C = POK_Procedure
7986 -- or else C = POK_Protected_Procedure
7987 -- or else C = POK_Task_Procedure
7989 -- <dispatching-call>;
7992 -- <triggering-statements>
7994 -- <else-statements>
7999 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
8000 Loc : constant Source_Ptr := Sloc (N);
8001 Alt : constant Node_Id := Entry_Call_Alternative (N);
8002 Blk : Node_Id := Entry_Call_Statement (Alt);
8005 Blk_Typ : Entity_Id;
8007 Call_Ent : Entity_Id;
8008 Conc_Typ_Stmts : List_Id;
8012 Lim_Typ_Stmts : List_Id;
8019 Transient_Blk : Node_Id;
8022 B : Entity_Id; -- Call status flag
8023 C : Entity_Id; -- Call kind
8024 K : Entity_Id; -- Tagged kind
8025 P : Entity_Id; -- Parameter block
8026 S : Entity_Id; -- Primitive operation slot
8029 Process_Statements_For_Controlled_Objects (N);
8031 if Ada_Version >= Ada_2005
8032 and then Nkind (Blk) = N_Procedure_Call_Statement
8034 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
8039 -- Call status flag processing, generate:
8040 -- B : Boolean := False;
8042 B := Build_B (Loc, Decls);
8044 -- Call kind processing, generate:
8045 -- C : Ada.Tags.Prim_Op_Kind;
8047 C := Build_C (Loc, Decls);
8049 -- Tagged kind processing, generate:
8050 -- K : Ada.Tags.Tagged_Kind :=
8051 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8053 K := Build_K (Loc, Decls, Obj);
8055 -- Parameter block processing
8057 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
8058 P := Parameter_Block_Pack
8059 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
8061 -- Dispatch table slot processing, generate:
8064 S := Build_S (Loc, Decls);
8067 -- S := Ada.Tags.Get_Offset_Index
8068 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
8071 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
8074 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8076 Append_To (Conc_Typ_Stmts,
8077 Make_Procedure_Call_Statement (Loc,
8080 Find_Prim_Op (Etype (Etype (Obj)),
8081 Name_uDisp_Conditional_Select),
8083 Parameter_Associations =>
8085 New_Copy_Tree (Obj), -- <object>
8086 New_Occurrence_Of (S, Loc), -- S
8087 Make_Attribute_Reference (Loc, -- P'Address
8088 Prefix => New_Occurrence_Of (P, Loc),
8089 Attribute_Name => Name_Address),
8090 New_Occurrence_Of (C, Loc), -- C
8091 New_Occurrence_Of (B, Loc)))); -- B
8094 -- if C = POK_Protected_Entry
8095 -- or else C = POK_Task_Entry
8097 -- Param1 := P.Param1;
8099 -- ParamN := P.ParamN;
8102 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
8104 -- Generate the if statement only when the packed parameters need
8105 -- explicit assignments to their corresponding actuals.
8107 if Present (Unpack) then
8108 Append_To (Conc_Typ_Stmts,
8109 Make_Implicit_If_Statement (N,
8115 New_Occurrence_Of (C, Loc),
8117 New_Occurrence_Of (RTE (
8118 RE_POK_Protected_Entry), Loc)),
8123 New_Occurrence_Of (C, Loc),
8125 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
8127 Then_Statements => Unpack));
8132 -- if C = POK_Procedure
8133 -- or else C = POK_Protected_Procedure
8134 -- or else C = POK_Task_Procedure
8136 -- <dispatching-call>
8138 -- <normal-statements>
8140 -- <else-statements>
8143 N_Stats := New_Copy_Separate_List (Statements (Alt));
8145 Prepend_To (N_Stats,
8146 Make_Implicit_If_Statement (N,
8152 New_Occurrence_Of (C, Loc),
8154 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
8161 New_Occurrence_Of (C, Loc),
8163 New_Occurrence_Of (RTE (
8164 RE_POK_Protected_Procedure), Loc)),
8169 New_Occurrence_Of (C, Loc),
8171 New_Occurrence_Of (RTE (
8172 RE_POK_Task_Procedure), Loc)))),
8177 Append_To (Conc_Typ_Stmts,
8178 Make_Implicit_If_Statement (N,
8179 Condition => New_Occurrence_Of (B, Loc),
8180 Then_Statements => N_Stats,
8181 Else_Statements => Else_Statements (N)));
8184 -- <dispatching-call>;
8185 -- <triggering-statements>
8187 Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt));
8188 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
8191 -- if K = Ada.Tags.TK_Limited_Tagged
8192 -- or else K = Ada.Tags.TK_Tagged
8200 Make_Implicit_If_Statement (N,
8201 Condition => Build_Dispatching_Tag_Check (K, N),
8202 Then_Statements => Lim_Typ_Stmts,
8203 Else_Statements => Conc_Typ_Stmts));
8206 Make_Block_Statement (Loc,
8209 Handled_Statement_Sequence =>
8210 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8212 -- As described above, the entry alternative is transformed into a
8213 -- block that contains the gnulli call, and possibly assignment
8214 -- statements for in-out parameters. The gnulli call may itself be
8215 -- rewritten into a transient block if some unconstrained parameters
8216 -- require it. We need to retrieve the call to complete its parameter
8221 First_Real_Statement (Handled_Statement_Sequence (Blk));
8223 if Present (Transient_Blk)
8224 and then Nkind (Transient_Blk) = N_Block_Statement
8226 Blk := Transient_Blk;
8229 Stmts := Statements (Handled_Statement_Sequence (Blk));
8230 Stmt := First (Stmts);
8231 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
8236 Params := Parameter_Associations (Call);
8238 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
8240 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8242 Param := First (Params);
8243 while Present (Param)
8244 and then not Is_RTE (Etype (Param), RE_Call_Modes)
8249 pragma Assert (Present (Param));
8251 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8255 -- Find the Communication_Block parameter for the call to the
8256 -- Cancelled function.
8258 Decl := First (Declarations (Blk));
8259 while Present (Decl)
8260 and then not Is_RTE (Etype (Object_Definition (Decl)),
8261 RE_Communication_Block)
8266 -- Add an if statement to execute the else part if the call
8267 -- does not succeed (as indicated by the Cancelled predicate).
8270 Make_Implicit_If_Statement (N,
8271 Condition => Make_Function_Call (Loc,
8272 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
8273 Parameter_Associations => New_List (
8274 New_Occurrence_Of (Defining_Identifier (Decl), Loc))),
8275 Then_Statements => Else_Statements (N),
8276 Else_Statements => Statements (Alt)));
8279 B := Make_Defining_Identifier (Loc, Name_uB);
8281 -- Insert declaration of B in declarations of existing block
8283 if No (Declarations (Blk)) then
8284 Set_Declarations (Blk, New_List);
8287 Prepend_To (Declarations (Blk),
8288 Make_Object_Declaration (Loc,
8289 Defining_Identifier => B,
8290 Object_Definition =>
8291 New_Occurrence_Of (Standard_Boolean, Loc)));
8293 -- Create new call statement
8296 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8297 Append_To (Params, New_Occurrence_Of (B, Loc));
8300 Make_Procedure_Call_Statement (Loc,
8301 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
8302 Parameter_Associations => Params));
8304 -- Construct statement sequence for new block
8307 Make_Implicit_If_Statement (N,
8308 Condition => New_Occurrence_Of (B, Loc),
8309 Then_Statements => Statements (Alt),
8310 Else_Statements => Else_Statements (N)));
8313 -- The result is the new block
8316 Make_Block_Statement (Loc,
8317 Declarations => Declarations (Blk),
8318 Handled_Statement_Sequence =>
8319 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8324 Reset_Scopes_To (N, Entity (Identifier (N)));
8325 end Expand_N_Conditional_Entry_Call;
8327 ---------------------------------------
8328 -- Expand_N_Delay_Relative_Statement --
8329 ---------------------------------------
8331 -- Delay statement is implemented as a procedure call to Delay_For
8332 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8333 -- simple delays imposed by the use of Protected Objects.
8335 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
8336 Loc : constant Source_Ptr := Sloc (N);
8340 -- Try to use Ada.Calendar.Delays.Delay_For if available.
8342 if RTE_Available (RO_CA_Delay_For) then
8343 Proc := RTE (RO_CA_Delay_For);
8345 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error
8346 -- message if not available. This is the implementation used on
8347 -- restricted platforms when Ada.Calendar is not available.
8350 Proc := RTE (RO_RD_Delay_For);
8354 Make_Procedure_Call_Statement (Loc,
8355 Name => New_Occurrence_Of (Proc, Loc),
8356 Parameter_Associations => New_List (Expression (N))));
8358 end Expand_N_Delay_Relative_Statement;
8360 ------------------------------------
8361 -- Expand_N_Delay_Until_Statement --
8362 ------------------------------------
8364 -- Delay Until statement is implemented as a procedure call to
8365 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8367 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
8368 Loc : constant Source_Ptr := Sloc (N);
8372 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
8373 Typ := RTE (RO_CA_Delay_Until);
8375 Typ := RTE (RO_RT_Delay_Until);
8379 Make_Procedure_Call_Statement (Loc,
8380 Name => New_Occurrence_Of (Typ, Loc),
8381 Parameter_Associations => New_List (Expression (N))));
8384 end Expand_N_Delay_Until_Statement;
8386 -------------------------
8387 -- Expand_N_Entry_Body --
8388 -------------------------
8390 procedure Expand_N_Entry_Body (N : Node_Id) is
8392 -- Associate discriminals with the next protected operation body to be
8395 if Present (Next_Protected_Operation (N)) then
8396 Set_Discriminals (Parent (Current_Scope));
8398 end Expand_N_Entry_Body;
8400 -----------------------------------
8401 -- Expand_N_Entry_Call_Statement --
8402 -----------------------------------
8404 -- An entry call is expanded into GNARLI calls to implement a simple entry
8405 -- call (see Build_Simple_Entry_Call).
8407 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
8413 if No_Run_Time_Mode then
8414 Error_Msg_CRT ("entry call", N);
8418 -- If this entry call is part of an asynchronous select, don't expand it
8419 -- here; it will be expanded with the select statement. Don't expand
8420 -- timed entry calls either, as they are translated into asynchronous
8423 -- ??? This whole approach is questionable; it may be better to go back
8424 -- to allowing the expansion to take place and then attempting to fix it
8425 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8426 -- whether the expanded call is on a task or protected entry.
8428 if (Nkind (Parent (N)) /= N_Triggering_Alternative
8429 or else N /= Triggering_Statement (Parent (N)))
8430 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
8431 or else N /= Entry_Call_Statement (Parent (N))
8432 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
8434 Extract_Entry (N, Concval, Ename, Index);
8435 Build_Simple_Entry_Call (N, Concval, Ename, Index);
8437 end Expand_N_Entry_Call_Statement;
8439 --------------------------------
8440 -- Expand_N_Entry_Declaration --
8441 --------------------------------
8443 -- If there are parameters, then first, each of the formals is marked by
8444 -- setting Is_Entry_Formal. Next a record type is built which is used to
8445 -- hold the parameter values. The name of this record type is entryP where
8446 -- entry is the name of the entry, with an additional corresponding access
8447 -- type called entryPA. The record type has matching components for each
8448 -- formal (the component names are the same as the formal names). For
8449 -- elementary types, the component type matches the formal type. For
8450 -- composite types, an access type is declared (with the name formalA)
8451 -- which designates the formal type, and the type of the component is this
8452 -- access type. Finally the Entry_Component of each formal is set to
8453 -- reference the corresponding record component.
8455 procedure Expand_N_Entry_Declaration (N : Node_Id) is
8456 Loc : constant Source_Ptr := Sloc (N);
8457 Entry_Ent : constant Entity_Id := Defining_Identifier (N);
8458 Components : List_Id;
8461 Last_Decl : Node_Id;
8462 Component : Entity_Id;
8465 Rec_Ent : Entity_Id;
8466 Acc_Ent : Entity_Id;
8469 Formal := First_Formal (Entry_Ent);
8472 -- Most processing is done only if parameters are present
8474 if Present (Formal) then
8475 Components := New_List;
8477 -- Loop through formals
8479 while Present (Formal) loop
8480 Set_Is_Entry_Formal (Formal);
8482 Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
8483 Set_Entry_Component (Formal, Component);
8484 Set_Entry_Formal (Component, Formal);
8485 Ftype := Etype (Formal);
8487 -- Declare new access type and then append
8489 Ctype := Make_Temporary (Loc, 'A');
8490 Set_Is_Param_Block_Component_Type (Ctype);
8493 Make_Full_Type_Declaration (Loc,
8494 Defining_Identifier => Ctype,
8496 Make_Access_To_Object_Definition (Loc,
8497 All_Present => True,
8498 Constant_Present => Ekind (Formal) = E_In_Parameter,
8499 Subtype_Indication => New_Occurrence_Of (Ftype, Loc)));
8501 Insert_After (Last_Decl, Decl);
8504 Append_To (Components,
8505 Make_Component_Declaration (Loc,
8506 Defining_Identifier => Component,
8507 Component_Definition =>
8508 Make_Component_Definition (Loc,
8509 Aliased_Present => False,
8510 Subtype_Indication => New_Occurrence_Of (Ctype, Loc))));
8512 Next_Formal_With_Extras (Formal);
8515 -- Create the Entry_Parameter_Record declaration
8517 Rec_Ent := Make_Temporary (Loc, 'P');
8520 Make_Full_Type_Declaration (Loc,
8521 Defining_Identifier => Rec_Ent,
8523 Make_Record_Definition (Loc,
8525 Make_Component_List (Loc,
8526 Component_Items => Components)));
8528 Insert_After (Last_Decl, Decl);
8531 -- Construct and link in the corresponding access type
8533 Acc_Ent := Make_Temporary (Loc, 'A');
8535 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
8538 Make_Full_Type_Declaration (Loc,
8539 Defining_Identifier => Acc_Ent,
8541 Make_Access_To_Object_Definition (Loc,
8542 All_Present => True,
8543 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc)));
8545 Insert_After (Last_Decl, Decl);
8547 end Expand_N_Entry_Declaration;
8549 -----------------------------
8550 -- Expand_N_Protected_Body --
8551 -----------------------------
8553 -- Protected bodies are expanded to the completion of the subprograms
8554 -- created for the corresponding protected type. These are a protected and
8555 -- unprotected version of each protected subprogram in the object, a
8556 -- function to calculate each entry barrier, and a procedure to execute the
8557 -- sequence of statements of each protected entry body. For example, for
8558 -- protected type ptype:
8561 -- (O : System.Address;
8562 -- E : Protected_Entry_Index)
8565 -- <discriminant renamings>
8566 -- <private object renamings>
8568 -- return <barrier expression>;
8571 -- procedure pprocN (_object : in out poV;...) is
8572 -- <discriminant renamings>
8573 -- <private object renamings>
8575 -- <sequence of statements>
8578 -- procedure pprocP (_object : in out poV;...) is
8579 -- procedure _clean is
8582 -- ptypeS (_object, Pn);
8583 -- Unlock (_object._object'Access);
8584 -- Abort_Undefer.all;
8589 -- Lock (_object._object'Access);
8590 -- pprocN (_object;...);
8595 -- function pfuncN (_object : poV;...) return Return_Type is
8596 -- <discriminant renamings>
8597 -- <private object renamings>
8599 -- <sequence of statements>
8602 -- function pfuncP (_object : poV) return Return_Type is
8603 -- procedure _clean is
8605 -- Unlock (_object._object'Access);
8606 -- Abort_Undefer.all;
8611 -- Lock (_object._object'Access);
8612 -- return pfuncN (_object);
8619 -- (O : System.Address;
8620 -- P : System.Address;
8621 -- E : Protected_Entry_Index)
8623 -- <discriminant renamings>
8624 -- <private object renamings>
8625 -- type poVP is access poV;
8626 -- _Object : ptVP := ptVP!(O);
8630 -- <statement sequence>
8631 -- Complete_Entry_Body (_Object._Object);
8633 -- when all others =>
8634 -- Exceptional_Complete_Entry_Body (
8635 -- _Object._Object, Get_GNAT_Exception);
8639 -- The type poV is the record created for the protected type to hold
8640 -- the state of the protected object.
8642 procedure Expand_N_Protected_Body (N : Node_Id) is
8643 Loc : constant Source_Ptr := Sloc (N);
8644 Pid : constant Entity_Id := Corresponding_Spec (N);
8646 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid);
8647 -- This flag indicates whether the lock free implementation is active
8649 Current_Node : Node_Id;
8650 Disp_Op_Body : Node_Id;
8651 New_Op_Body : Node_Id;
8656 function Build_Dispatching_Subprogram_Body
8659 Prot_Bod : Node_Id) return Node_Id;
8660 -- Build a dispatching version of the protected subprogram body. The
8661 -- newly generated subprogram contains a call to the original protected
8662 -- body. The following code is generated:
8664 -- function <protected-function-name> (Param1 .. ParamN) return
8667 -- return <protected-function-name>P (Param1 .. ParamN);
8668 -- end <protected-function-name>;
8672 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8674 -- <protected-procedure-name>P (Param1 .. ParamN);
8675 -- end <protected-procedure-name>
8677 ---------------------------------------
8678 -- Build_Dispatching_Subprogram_Body --
8679 ---------------------------------------
8681 function Build_Dispatching_Subprogram_Body
8684 Prot_Bod : Node_Id) return Node_Id
8686 Loc : constant Source_Ptr := Sloc (N);
8693 -- Generate a specification without a letter suffix in order to
8694 -- override an interface function or procedure.
8696 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
8698 -- The formal parameters become the actuals of the protected function
8699 -- or procedure call.
8701 Actuals := New_List;
8702 Formal := First (Parameter_Specifications (Spec));
8703 while Present (Formal) loop
8705 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
8709 if Nkind (Spec) = N_Procedure_Specification then
8712 Make_Procedure_Call_Statement (Loc,
8714 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8715 Parameter_Associations => Actuals));
8718 pragma Assert (Nkind (Spec) = N_Function_Specification);
8722 Make_Simple_Return_Statement (Loc,
8724 Make_Function_Call (Loc,
8726 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8727 Parameter_Associations => Actuals)));
8731 Make_Subprogram_Body (Loc,
8732 Declarations => Empty_List,
8733 Specification => Spec,
8734 Handled_Statement_Sequence =>
8735 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8736 end Build_Dispatching_Subprogram_Body;
8738 -- Start of processing for Expand_N_Protected_Body
8741 if No_Run_Time_Mode then
8742 Error_Msg_CRT ("protected body", N);
8746 -- This is the proper body corresponding to a stub. The declarations
8747 -- must be inserted at the point of the stub, which in turn is in the
8748 -- declarative part of the parent unit.
8750 if Nkind (Parent (N)) = N_Subunit then
8751 Current_Node := Corresponding_Stub (Parent (N));
8756 Op_Body := First (Declarations (N));
8758 -- The protected body is replaced with the bodies of its protected
8759 -- operations, and the declarations for internal objects that may
8760 -- have been created for entry family bounds.
8762 Rewrite (N, Make_Null_Statement (Sloc (N)));
8765 while Present (Op_Body) loop
8766 case Nkind (Op_Body) is
8767 when N_Subprogram_Declaration =>
8770 when N_Subprogram_Body =>
8772 -- Do not create bodies for eliminated operations
8774 if not Is_Eliminated (Defining_Entity (Op_Body))
8775 and then not Is_Eliminated (Corresponding_Spec (Op_Body))
8777 if Lock_Free_Active then
8779 Build_Lock_Free_Unprotected_Subprogram_Body
8783 Build_Unprotected_Subprogram_Body (Op_Body, Pid);
8786 Insert_After (Current_Node, New_Op_Body);
8787 Current_Node := New_Op_Body;
8788 Analyze (New_Op_Body);
8790 -- When the original protected body has nested subprograms,
8791 -- the new body also has them, so set the flag accordingly
8792 -- and reset the scopes of the top-level nested subprograms
8793 -- and other declaration entities so that they now refer to
8794 -- the new body's entity. (It would preferable to do this
8795 -- within Build_Protected_Sub_Specification, which is called
8796 -- from Build_Unprotected_Subprogram_Body, but the needed
8797 -- subprogram entity isn't available via Corresponding_Spec
8798 -- until after the above Analyze call.)
8800 if Has_Nested_Subprogram (Corresponding_Spec (Op_Body)) then
8801 Set_Has_Nested_Subprogram
8802 (Corresponding_Spec (New_Op_Body));
8805 (New_Op_Body, Corresponding_Spec (New_Op_Body));
8808 -- Build the corresponding protected operation. This is
8809 -- needed only if this is a public or private operation of
8812 -- Why do we need to test for Corresponding_Spec being
8813 -- present here when it's assumed to be set further above
8814 -- in the Is_Eliminated test???
8816 if Present (Corresponding_Spec (Op_Body)) then
8818 Unit_Declaration_Node (Corresponding_Spec (Op_Body));
8820 if Nkind (Parent (Op_Decl)) = N_Protected_Definition then
8821 if Lock_Free_Active then
8823 Build_Lock_Free_Protected_Subprogram_Body
8824 (Op_Body, Pid, Specification (New_Op_Body));
8827 Build_Protected_Subprogram_Body (
8828 Op_Body, Pid, Specification (New_Op_Body));
8831 Insert_After (Current_Node, New_Op_Body);
8832 Analyze (New_Op_Body);
8833 Current_Node := New_Op_Body;
8835 -- Generate an overriding primitive operation body for
8836 -- this subprogram if the protected type implements
8839 if Ada_Version >= Ada_2005
8840 and then Present (Interfaces (
8841 Corresponding_Record_Type (Pid)))
8844 Build_Dispatching_Subprogram_Body (
8845 Op_Body, Pid, New_Op_Body);
8847 Insert_After (Current_Node, Disp_Op_Body);
8848 Analyze (Disp_Op_Body);
8850 Current_Node := Disp_Op_Body;
8856 when N_Entry_Body =>
8857 Op_Id := Defining_Identifier (Op_Body);
8858 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
8860 Insert_After (Current_Node, New_Op_Body);
8861 Current_Node := New_Op_Body;
8862 Analyze (New_Op_Body);
8864 when N_Implicit_Label_Declaration =>
8870 New_Op_Body := New_Copy (Op_Body);
8871 Insert_After (Current_Node, New_Op_Body);
8872 Current_Node := New_Op_Body;
8874 when N_Freeze_Entity =>
8875 New_Op_Body := New_Copy (Op_Body);
8877 if Present (Entity (Op_Body))
8878 and then Freeze_Node (Entity (Op_Body)) = Op_Body
8880 Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
8883 Insert_After (Current_Node, New_Op_Body);
8884 Current_Node := New_Op_Body;
8885 Analyze (New_Op_Body);
8888 New_Op_Body := New_Copy (Op_Body);
8889 Insert_After (Current_Node, New_Op_Body);
8890 Current_Node := New_Op_Body;
8891 Analyze (New_Op_Body);
8893 when N_Object_Declaration =>
8894 pragma Assert (not Comes_From_Source (Op_Body));
8895 New_Op_Body := New_Copy (Op_Body);
8896 Insert_After (Current_Node, New_Op_Body);
8897 Current_Node := New_Op_Body;
8898 Analyze (New_Op_Body);
8901 raise Program_Error;
8907 -- Finally, create the body of the function that maps an entry index
8908 -- into the corresponding body index, except when there is no entry, or
8909 -- in a Ravenscar-like profile.
8911 if Corresponding_Runtime_Package (Pid) =
8912 System_Tasking_Protected_Objects_Entries
8914 New_Op_Body := Build_Find_Body_Index (Pid);
8915 Insert_After (Current_Node, New_Op_Body);
8916 Current_Node := New_Op_Body;
8917 Analyze (New_Op_Body);
8920 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8921 -- protected body. At this point all wrapper specs have been created,
8922 -- frozen and included in the dispatch table for the protected type.
8924 if Ada_Version >= Ada_2005 then
8925 Build_Wrapper_Bodies (Loc, Pid, Current_Node);
8927 end Expand_N_Protected_Body;
8929 -----------------------------------------
8930 -- Expand_N_Protected_Type_Declaration --
8931 -----------------------------------------
8933 -- First we create a corresponding record type declaration used to
8934 -- represent values of this protected type.
8935 -- The general form of this type declaration is
8937 -- type poV (discriminants) is record
8938 -- _Object : aliased <kind>Protection
8939 -- [(<entry count> [, <handler count>])];
8940 -- [entry_family : array (bounds) of Void;]
8941 -- <private data fields>
8944 -- The discriminants are present only if the corresponding protected type
8945 -- has discriminants, and they exactly mirror the protected type
8946 -- discriminants. The private data fields similarly mirror the private
8947 -- declarations of the protected type.
8949 -- The Object field is always present. It contains RTS specific data used
8950 -- to control the protected object. It is declared as Aliased so that it
8951 -- can be passed as a pointer to the RTS. This allows the protected record
8952 -- to be referenced within RTS data structures. An appropriate Protection
8953 -- type and discriminant are generated.
8955 -- The Service field is present for protected objects with entries. It
8956 -- contains sufficient information to allow the entry service procedure for
8957 -- this object to be called when the object is not known till runtime.
8959 -- One entry_family component is present for each entry family in the
8960 -- task definition (see Expand_N_Task_Type_Declaration).
8962 -- When a protected object is declared, an instance of the protected type
8963 -- value record is created. The elaboration of this declaration creates the
8964 -- correct bounds for the entry families, and also evaluates the priority
8965 -- expression if needed. The initialization routine for the protected type
8966 -- itself then calls Initialize_Protection with appropriate parameters to
8967 -- initialize the value of the Task_Id field. Install_Handlers may be also
8968 -- called if a pragma Attach_Handler applies.
8970 -- Note: this record is passed to the subprograms created by the expansion
8971 -- of protected subprograms and entries. It is an in parameter to protected
8972 -- functions and an in out parameter to procedures and entry bodies. The
8973 -- Entity_Id for this created record type is placed in the
8974 -- Corresponding_Record_Type field of the associated protected type entity.
8976 -- Next we create a procedure specifications for protected subprograms and
8977 -- entry bodies. For each protected subprograms two subprograms are
8978 -- created, an unprotected and a protected version. The unprotected version
8979 -- is called from within other operations of the same protected object.
8981 -- We also build the call to register the procedure if a pragma
8982 -- Interrupt_Handler applies.
8984 -- A single subprogram is created to service all entry bodies; it has an
8985 -- additional boolean out parameter indicating that the previous entry call
8986 -- made by the current task was serviced immediately, i.e. not by proxy.
8987 -- The O parameter contains a pointer to a record object of the type
8988 -- described above. An untyped interface is used here to allow this
8989 -- procedure to be called in places where the type of the object to be
8990 -- serviced is not known. This must be done, for example, when a call that
8991 -- may have been requeued is cancelled; the corresponding object must be
8992 -- serviced, but which object that is not known till runtime.
8995 -- (O : System.Address; P : out Boolean);
8996 -- procedure pprocN (_object : in out poV);
8997 -- procedure pproc (_object : in out poV);
8998 -- function pfuncN (_object : poV);
8999 -- function pfunc (_object : poV);
9002 -- Note that this must come after the record type declaration, since
9003 -- the specs refer to this type.
9005 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
9006 Discr_Map : constant Elist_Id := New_Elmt_List;
9007 Loc : constant Source_Ptr := Sloc (N);
9008 Prot_Typ : constant Entity_Id := Defining_Identifier (N);
9010 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ);
9011 -- This flag indicates whether the lock free implementation is active
9013 Pdef : constant Node_Id := Protected_Definition (N);
9014 -- This contains two lists; one for visible and one for private decls
9016 Current_Node : Node_Id := N;
9018 Entries_Aggr : Node_Id;
9022 procedure Check_Inlining (Subp : Entity_Id);
9023 -- If the original operation has a pragma Inline, propagate the flag
9024 -- to the internal body, for possible inlining later on. The source
9025 -- operation is invisible to the back-end and is never actually called.
9027 procedure Expand_Entry_Declaration (Decl : Node_Id);
9028 -- Create the entry barrier and the procedure body for entry declaration
9029 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
9031 function Static_Component_Size (Comp : Entity_Id) return Boolean;
9032 -- When compiling under the Ravenscar profile, private components must
9033 -- have a static size, or else a protected object will require heap
9034 -- allocation, violating the corresponding restriction. It is preferable
9035 -- to make this check here, because it provides a better error message
9036 -- than the back-end, which refers to the object as a whole.
9038 procedure Register_Handler;
9039 -- For a protected operation that is an interrupt handler, add the
9040 -- freeze action that will register it as such.
9042 procedure Replace_Access_Definition (Comp : Node_Id);
9043 -- If a private component of the type is an access to itself, this
9044 -- is not a reference to the current instance, but an access type out
9045 -- of which one might construct a list. If such a component exists, we
9046 -- create an incomplete type for the equivalent record type, and
9047 -- a named access type for it, that replaces the access definition
9048 -- of the original component. This is similar to what is done for
9049 -- records in Check_Anonymous_Access_Components, but simpler, because
9050 -- the corresponding record type has no previous declaration.
9051 -- This needs to be done only once, even if there are several such
9052 -- access components. The following entity stores the constructed
9055 Acc_T : Entity_Id := Empty;
9057 --------------------
9058 -- Check_Inlining --
9059 --------------------
9061 procedure Check_Inlining (Subp : Entity_Id) is
9063 if Is_Inlined (Subp) then
9064 Set_Is_Inlined (Protected_Body_Subprogram (Subp));
9065 Set_Is_Inlined (Subp, False);
9068 if Has_Pragma_No_Inline (Subp) then
9069 Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp));
9073 ---------------------------
9074 -- Static_Component_Size --
9075 ---------------------------
9077 function Static_Component_Size (Comp : Entity_Id) return Boolean is
9078 Typ : constant Entity_Id := Etype (Comp);
9082 if Is_Scalar_Type (Typ) then
9085 elsif Is_Array_Type (Typ) then
9086 return Compile_Time_Known_Bounds (Typ);
9088 elsif Is_Record_Type (Typ) then
9089 C := First_Component (Typ);
9090 while Present (C) loop
9091 if not Static_Component_Size (C) then
9100 -- Any other type will be checked by the back-end
9105 end Static_Component_Size;
9107 ------------------------------
9108 -- Expand_Entry_Declaration --
9109 ------------------------------
9111 procedure Expand_Entry_Declaration (Decl : Node_Id) is
9112 Ent_Id : constant Entity_Id := Defining_Entity (Decl);
9118 E_Count := E_Count + 1;
9120 -- Create the protected body subprogram
9123 Make_Defining_Identifier (Loc,
9124 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E'));
9125 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id);
9128 Make_Subprogram_Declaration (Loc,
9130 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id));
9132 Insert_After (Current_Node, Subp);
9133 Current_Node := Subp;
9137 -- Build a wrapper procedure to handle contract cases, preconditions,
9138 -- and postconditions.
9140 Build_Contract_Wrapper (Ent_Id, N);
9142 -- Create the barrier function
9145 Make_Defining_Identifier (Loc,
9146 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B'));
9147 Set_Barrier_Function (Ent_Id, Bar_Id);
9150 Make_Subprogram_Declaration (Loc,
9152 Build_Barrier_Function_Specification (Loc, Bar_Id));
9153 Set_Is_Entry_Barrier_Function (Subp);
9155 Insert_After (Current_Node, Subp);
9156 Current_Node := Subp;
9160 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id);
9161 Set_Scope (Bar_Id, Scope (Ent_Id));
9163 -- Collect pointers to the protected subprogram and the barrier
9164 -- of the current entry, for insertion into Entry_Bodies_Array.
9166 Append_To (Expressions (Entries_Aggr),
9167 Make_Aggregate (Loc,
9168 Expressions => New_List (
9169 Make_Attribute_Reference (Loc,
9170 Prefix => New_Occurrence_Of (Bar_Id, Loc),
9171 Attribute_Name => Name_Unrestricted_Access),
9172 Make_Attribute_Reference (Loc,
9173 Prefix => New_Occurrence_Of (Bod_Id, Loc),
9174 Attribute_Name => Name_Unrestricted_Access))));
9175 end Expand_Entry_Declaration;
9177 ----------------------
9178 -- Register_Handler --
9179 ----------------------
9181 procedure Register_Handler is
9183 -- All semantic checks already done in Sem_Prag
9185 Prot_Proc : constant Entity_Id :=
9186 Defining_Unit_Name (Specification (Current_Node));
9188 Proc_Address : constant Node_Id :=
9189 Make_Attribute_Reference (Loc,
9191 New_Occurrence_Of (Prot_Proc, Loc),
9192 Attribute_Name => Name_Address);
9194 RTS_Call : constant Entity_Id :=
9195 Make_Procedure_Call_Statement (Loc,
9198 (RTE (RE_Register_Interrupt_Handler), Loc),
9199 Parameter_Associations => New_List (Proc_Address));
9201 Append_Freeze_Action (Prot_Proc, RTS_Call);
9202 end Register_Handler;
9204 -------------------------------
9205 -- Replace_Access_Definition --
9206 -------------------------------
9208 procedure Replace_Access_Definition (Comp : Node_Id) is
9209 Loc : constant Source_Ptr := Sloc (Comp);
9217 Inc_T := Make_Defining_Identifier (Loc, Chars (Rec_Id));
9218 Inc_D := Make_Incomplete_Type_Declaration (Loc, Inc_T);
9219 Acc_T := Make_Temporary (Loc, 'S');
9221 Make_Access_To_Object_Definition (Loc,
9222 Subtype_Indication => New_Occurrence_Of (Inc_T, Loc));
9224 Make_Full_Type_Declaration (Loc,
9225 Defining_Identifier => Acc_T,
9226 Type_Definition => Acc_Def);
9228 Insert_Before (Rec_Decl, Inc_D);
9231 Insert_Before (Rec_Decl, Acc_D);
9235 Set_Access_Definition (Comp, Empty);
9236 Set_Subtype_Indication (Comp, New_Occurrence_Of (Acc_T, Loc));
9237 end Replace_Access_Definition;
9242 Body_Id : Entity_Id;
9248 Object_Comp : Node_Id;
9252 -- Start of processing for Expand_N_Protected_Type_Declaration
9255 if Present (Corresponding_Record_Type (Prot_Typ)) then
9258 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
9259 Rec_Id := Defining_Identifier (Rec_Decl);
9262 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
9264 Qualify_Entity_Names (N);
9266 -- If the type has discriminants, their occurrences in the declaration
9267 -- have been replaced by the corresponding discriminals. For components
9268 -- that are constrained by discriminants, their homologues in the
9269 -- corresponding record type must refer to the discriminants of that
9270 -- record, so we must apply a new renaming to subtypes_indications:
9272 -- protected discriminant => discriminal => record discriminant
9274 -- This replacement is not applied to default expressions, for which
9275 -- the discriminal is correct.
9277 if Has_Discriminants (Prot_Typ) then
9283 Disc := First_Discriminant (Prot_Typ);
9284 Decl := First (Discriminant_Specifications (Rec_Decl));
9285 while Present (Disc) loop
9286 Append_Elmt (Discriminal (Disc), Discr_Map);
9287 Append_Elmt (Defining_Identifier (Decl), Discr_Map);
9288 Next_Discriminant (Disc);
9294 -- Fill in the component declarations
9296 -- Add components for entry families. For each entry family, create an
9297 -- anonymous type declaration with the same size, and analyze the type.
9299 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
9301 pragma Assert (Present (Pdef));
9303 Insert_After (Current_Node, Rec_Decl);
9304 Current_Node := Rec_Decl;
9306 -- Add private field components
9308 if Present (Private_Declarations (Pdef)) then
9309 Priv := First (Private_Declarations (Pdef));
9310 while Present (Priv) loop
9311 if Nkind (Priv) = N_Component_Declaration then
9312 if not Static_Component_Size (Defining_Identifier (Priv)) then
9314 -- When compiling for a restricted profile, the private
9315 -- components must have a static size. If not, this is an
9316 -- error for a single protected declaration, and rates a
9317 -- warning on a protected type declaration.
9319 if not Comes_From_Source (Prot_Typ) then
9321 -- It's ok to be checking this restriction at expansion
9322 -- time, because this is only for the restricted profile,
9323 -- which is not subject to strict RM conformance, so it
9324 -- is OK to miss this check in -gnatc mode.
9326 Check_Restriction (No_Implicit_Heap_Allocations, Priv);
9328 (No_Implicit_Protected_Object_Allocations, Priv);
9330 elsif Restriction_Active (No_Implicit_Heap_Allocations) then
9331 if not Discriminated_Size (Defining_Identifier (Priv))
9333 -- Any object of the type will be non-static
9335 Error_Msg_N ("component has non-static size??", Priv);
9337 ("\creation of protected object of type& will "
9338 & "violate restriction "
9339 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
9341 -- Object will be non-static if discriminants are
9344 ("creation of protected object of type& with "
9345 & "non-static discriminants will violate "
9346 & "restriction No_Implicit_Heap_Allocations??",
9350 -- Likewise for No_Implicit_Protected_Object_Allocations
9352 elsif Restriction_Active
9353 (No_Implicit_Protected_Object_Allocations)
9355 if not Discriminated_Size (Defining_Identifier (Priv))
9357 -- Any object of the type will be non-static
9359 Error_Msg_N ("component has non-static size??", Priv);
9361 ("\creation of protected object of type& will "
9362 & "violate restriction "
9363 & "No_Implicit_Protected_Object_Allocations??",
9366 -- Object will be non-static if discriminants are
9369 ("creation of protected object of type& with "
9370 & "non-static discriminants will violate "
9372 & "No_Implicit_Protected_Object_Allocations??",
9378 -- The component definition consists of a subtype indication,
9379 -- or (in Ada 2005) an access definition. Make a copy of the
9380 -- proper definition.
9383 Old_Comp : constant Node_Id := Component_Definition (Priv);
9384 Oent : constant Entity_Id := Defining_Identifier (Priv);
9385 Nent : constant Entity_Id :=
9386 Make_Defining_Identifier (Sloc (Oent),
9387 Chars => Chars (Oent));
9391 if Present (Subtype_Indication (Old_Comp)) then
9393 Make_Component_Definition (Sloc (Oent),
9394 Aliased_Present => False,
9395 Subtype_Indication =>
9397 (Subtype_Indication (Old_Comp), Discr_Map));
9400 Make_Component_Definition (Sloc (Oent),
9401 Aliased_Present => False,
9402 Access_Definition =>
9404 (Access_Definition (Old_Comp), Discr_Map));
9406 -- A self-reference in the private part becomes a
9407 -- self-reference to the corresponding record.
9409 if Entity (Subtype_Mark (Access_Definition (New_Comp)))
9412 Replace_Access_Definition (New_Comp);
9417 Make_Component_Declaration (Loc,
9418 Defining_Identifier => Nent,
9419 Component_Definition => New_Comp,
9420 Expression => Expression (Priv));
9422 Set_Has_Per_Object_Constraint (Nent,
9423 Has_Per_Object_Constraint (Oent));
9425 Append_To (Cdecls, New_Priv);
9428 elsif Nkind (Priv) = N_Subprogram_Declaration then
9430 -- Make the unprotected version of the subprogram available
9431 -- for expansion of intra object calls. There is need for
9432 -- a protected version only if the subprogram is an interrupt
9433 -- handler, otherwise this operation can only be called from
9437 Make_Subprogram_Declaration (Loc,
9439 Build_Protected_Sub_Specification
9440 (Priv, Prot_Typ, Unprotected_Mode));
9442 Insert_After (Current_Node, Sub);
9445 Set_Protected_Body_Subprogram
9446 (Defining_Unit_Name (Specification (Priv)),
9447 Defining_Unit_Name (Specification (Sub)));
9448 Check_Inlining (Defining_Unit_Name (Specification (Priv)));
9449 Current_Node := Sub;
9452 Make_Subprogram_Declaration (Loc,
9454 Build_Protected_Sub_Specification
9455 (Priv, Prot_Typ, Protected_Mode));
9457 Insert_After (Current_Node, Sub);
9459 Current_Node := Sub;
9461 if Is_Interrupt_Handler
9462 (Defining_Unit_Name (Specification (Priv)))
9464 if not Restricted_Profile then
9474 -- Except for the lock-free implementation, append the _Object field
9475 -- with the right type to the component list. We need to compute the
9476 -- number of entries, and in some cases the number of Attach_Handler
9479 if not Lock_Free_Active then
9481 Entry_Count_Expr : constant Node_Id :=
9482 Build_Entry_Count_Expression
9483 (Prot_Typ, Cdecls, Loc);
9484 Num_Attach_Handler : Nat := 0;
9485 Protection_Subtype : Node_Id;
9489 if Has_Attach_Handler (Prot_Typ) then
9490 Ritem := First_Rep_Item (Prot_Typ);
9491 while Present (Ritem) loop
9492 if Nkind (Ritem) = N_Pragma
9493 and then Pragma_Name (Ritem) = Name_Attach_Handler
9495 Num_Attach_Handler := Num_Attach_Handler + 1;
9498 Next_Rep_Item (Ritem);
9502 -- Determine the proper protection type. There are two special
9503 -- cases: 1) when the protected type has dynamic interrupt
9504 -- handlers, and 2) when it has static handlers and we use a
9505 -- restricted profile.
9507 if Has_Attach_Handler (Prot_Typ)
9508 and then not Restricted_Profile
9510 Protection_Subtype :=
9511 Make_Subtype_Indication (Loc,
9514 (RTE (RE_Static_Interrupt_Protection), Loc),
9516 Make_Index_Or_Discriminant_Constraint (Loc,
9517 Constraints => New_List (
9519 Make_Integer_Literal (Loc, Num_Attach_Handler))));
9521 elsif Has_Interrupt_Handler (Prot_Typ)
9522 and then not Restriction_Active (No_Dynamic_Attachment)
9524 Protection_Subtype :=
9525 Make_Subtype_Indication (Loc,
9528 (RTE (RE_Dynamic_Interrupt_Protection), Loc),
9530 Make_Index_Or_Discriminant_Constraint (Loc,
9531 Constraints => New_List (Entry_Count_Expr)));
9534 case Corresponding_Runtime_Package (Prot_Typ) is
9535 when System_Tasking_Protected_Objects_Entries =>
9536 Protection_Subtype :=
9537 Make_Subtype_Indication (Loc,
9540 (RTE (RE_Protection_Entries), Loc),
9542 Make_Index_Or_Discriminant_Constraint (Loc,
9543 Constraints => New_List (Entry_Count_Expr)));
9545 when System_Tasking_Protected_Objects_Single_Entry =>
9546 Protection_Subtype :=
9547 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc);
9549 when System_Tasking_Protected_Objects =>
9550 Protection_Subtype :=
9551 New_Occurrence_Of (RTE (RE_Protection), Loc);
9554 raise Program_Error;
9559 Make_Component_Declaration (Loc,
9560 Defining_Identifier =>
9561 Make_Defining_Identifier (Loc, Name_uObject),
9562 Component_Definition =>
9563 Make_Component_Definition (Loc,
9564 Aliased_Present => True,
9565 Subtype_Indication => Protection_Subtype));
9568 -- Put the _Object component after the private component so that it
9569 -- be finalized early as required by 9.4 (20)
9571 Append_To (Cdecls, Object_Comp);
9574 -- Analyze the record declaration immediately after construction,
9575 -- because the initialization procedure is needed for single object
9576 -- declarations before the next entity is analyzed (the freeze call
9577 -- that generates this initialization procedure is found below).
9579 Analyze (Rec_Decl, Suppress => All_Checks);
9581 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9582 -- the corresponding record is frozen. If any wrappers are generated,
9583 -- Current_Node is updated accordingly.
9585 if Ada_Version >= Ada_2005 then
9586 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
9589 -- Collect pointers to entry bodies and their barriers, to be placed
9590 -- in the Entry_Bodies_Array for the type. For each entry/family we
9591 -- add an expression to the aggregate which is the initial value of
9592 -- this array. The array is declared after all protected subprograms.
9594 if Has_Entries (Prot_Typ) then
9595 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
9597 Entries_Aggr := Empty;
9600 -- Build two new procedure specifications for each protected subprogram;
9601 -- one to call from outside the object and one to call from inside.
9602 -- Build a barrier function and an entry body action procedure
9603 -- specification for each protected entry. Initialize the entry body
9604 -- array. If subprogram is flagged as eliminated, do not generate any
9605 -- internal operations.
9608 Comp := First (Visible_Declarations (Pdef));
9609 while Present (Comp) loop
9610 if Nkind (Comp) = N_Subprogram_Declaration then
9612 Make_Subprogram_Declaration (Loc,
9614 Build_Protected_Sub_Specification
9615 (Comp, Prot_Typ, Unprotected_Mode));
9617 Insert_After (Current_Node, Sub);
9620 Set_Protected_Body_Subprogram
9621 (Defining_Unit_Name (Specification (Comp)),
9622 Defining_Unit_Name (Specification (Sub)));
9623 Check_Inlining (Defining_Unit_Name (Specification (Comp)));
9625 -- Make the protected version of the subprogram available for
9626 -- expansion of external calls.
9628 Current_Node := Sub;
9631 Make_Subprogram_Declaration (Loc,
9633 Build_Protected_Sub_Specification
9634 (Comp, Prot_Typ, Protected_Mode));
9636 Insert_After (Current_Node, Sub);
9639 Current_Node := Sub;
9641 -- Generate an overriding primitive operation specification for
9642 -- this subprogram if the protected type implements an interface
9643 -- and Build_Wrapper_Spec did not generate its wrapper.
9645 if Ada_Version >= Ada_2005
9647 Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
9650 Found : Boolean := False;
9651 Prim_Elmt : Elmt_Id;
9657 (Primitive_Operations
9658 (Corresponding_Record_Type (Prot_Typ)));
9660 while Present (Prim_Elmt) loop
9661 Prim_Op := Node (Prim_Elmt);
9663 if Is_Primitive_Wrapper (Prim_Op)
9664 and then Wrapped_Entity (Prim_Op) =
9665 Defining_Entity (Specification (Comp))
9671 Next_Elmt (Prim_Elmt);
9676 Make_Subprogram_Declaration (Loc,
9678 Build_Protected_Sub_Specification
9679 (Comp, Prot_Typ, Dispatching_Mode));
9681 Insert_After (Current_Node, Sub);
9684 Current_Node := Sub;
9689 -- If a pragma Interrupt_Handler applies, build and add a call to
9690 -- Register_Interrupt_Handler to the freezing actions of the
9691 -- protected version (Current_Node) of the subprogram:
9693 -- system.interrupts.register_interrupt_handler
9694 -- (prot_procP'address);
9696 if not Restricted_Profile
9697 and then Is_Interrupt_Handler
9698 (Defining_Unit_Name (Specification (Comp)))
9703 elsif Nkind (Comp) = N_Entry_Declaration then
9704 Expand_Entry_Declaration (Comp);
9710 -- If there are some private entry declarations, expand it as if they
9711 -- were visible entries.
9713 if Present (Private_Declarations (Pdef)) then
9714 Comp := First (Private_Declarations (Pdef));
9715 while Present (Comp) loop
9716 if Nkind (Comp) = N_Entry_Declaration then
9717 Expand_Entry_Declaration (Comp);
9724 -- Create the declaration of an array object which contains the values
9725 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9726 -- type. This object is later passed to the appropriate protected object
9727 -- initialization routine.
9729 if Has_Entries (Prot_Typ)
9730 and then Corresponding_Runtime_Package (Prot_Typ) =
9731 System_Tasking_Protected_Objects_Entries
9738 Maxes_Id : Entity_Id;
9739 Need_Array : Boolean := False;
9742 -- First check if there is any Max_Queue_Length pragma
9744 Item := First_Entity (Prot_Typ);
9745 while Present (Item) loop
9746 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then
9754 -- Gather the Max_Queue_Length values of all entries in a list. A
9755 -- value of zero indicates that the entry has no limitation on its
9760 Item := First_Entity (Prot_Typ);
9762 while Present (Item) loop
9763 if Is_Entry (Item) then
9766 Make_Integer_Literal
9767 (Loc, Get_Max_Queue_Length (Item)));
9773 -- Create the declaration of the array object. Generate:
9775 -- Maxes_Id : aliased constant
9776 -- Protected_Entry_Queue_Max_Array
9777 -- (1 .. Count) := (..., ...);
9780 Make_Defining_Identifier (Loc,
9781 Chars => New_External_Name (Chars (Prot_Typ), 'B'));
9784 Make_Object_Declaration (Loc,
9785 Defining_Identifier => Maxes_Id,
9786 Aliased_Present => True,
9787 Constant_Present => True,
9788 Object_Definition =>
9789 Make_Subtype_Indication (Loc,
9792 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
9794 Make_Index_Or_Discriminant_Constraint (Loc,
9795 Constraints => New_List (
9797 Make_Integer_Literal (Loc, 1),
9798 Make_Integer_Literal (Loc, Count))))),
9799 Expression => Make_Aggregate (Loc, Maxes));
9801 -- A pointer to this array will be placed in the corresponding
9802 -- record by its initialization procedure so this needs to be
9805 Insert_After (Current_Node, Max_Vals);
9806 Current_Node := Max_Vals;
9809 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id);
9814 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9815 -- all protected subprograms have been collected.
9817 if Has_Entries (Prot_Typ) then
9819 Make_Defining_Identifier (Sloc (Prot_Typ),
9820 Chars => New_External_Name (Chars (Prot_Typ), 'A'));
9822 case Corresponding_Runtime_Package (Prot_Typ) is
9823 when System_Tasking_Protected_Objects_Entries =>
9824 Expr := Entries_Aggr;
9826 Make_Subtype_Indication (Loc,
9829 (RTE (RE_Protected_Entry_Body_Array), Loc),
9831 Make_Index_Or_Discriminant_Constraint (Loc,
9832 Constraints => New_List (
9834 Make_Integer_Literal (Loc, 1),
9835 Make_Integer_Literal (Loc, E_Count)))));
9837 when System_Tasking_Protected_Objects_Single_Entry =>
9838 Expr := Remove_Head (Expressions (Entries_Aggr));
9839 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc);
9842 raise Program_Error;
9846 Make_Object_Declaration (Loc,
9847 Defining_Identifier => Body_Id,
9848 Aliased_Present => True,
9849 Constant_Present => True,
9850 Object_Definition => Obj_Def,
9851 Expression => Expr);
9853 -- A pointer to this array will be placed in the corresponding record
9854 -- by its initialization procedure so this needs to be analyzed here.
9856 Insert_After (Current_Node, Body_Arr);
9857 Current_Node := Body_Arr;
9860 Set_Entry_Bodies_Array (Prot_Typ, Body_Id);
9862 -- Finally, build the function that maps an entry index into the
9863 -- corresponding body. A pointer to this function is placed in each
9864 -- object of the type. Except for a ravenscar-like profile (no abort,
9865 -- no entry queue, 1 entry)
9867 if Corresponding_Runtime_Package (Prot_Typ) =
9868 System_Tasking_Protected_Objects_Entries
9871 Make_Subprogram_Declaration (Loc,
9872 Specification => Build_Find_Body_Index_Spec (Prot_Typ));
9874 Insert_After (Current_Node, Sub);
9878 end Expand_N_Protected_Type_Declaration;
9880 --------------------------------
9881 -- Expand_N_Requeue_Statement --
9882 --------------------------------
9884 -- A nondispatching requeue statement is expanded into one of four GNARLI
9885 -- operations, depending on the source and destination (task or protected
9886 -- object). A dispatching requeue statement is expanded into a call to the
9887 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9888 -- jump around the remainder of processing for the original entry and, if
9889 -- the destination is (different) protected object, to attempt to service
9890 -- it. The following illustrates the various cases:
9893 -- (O : System.Address;
9894 -- P : System.Address;
9895 -- E : Protected_Entry_Index)
9897 -- <discriminant renamings>
9898 -- <private object renamings>
9899 -- type poVP is access poV;
9900 -- _object : ptVP := ptVP!(O);
9904 -- <start of statement sequence for entry>
9906 -- -- Requeue from one protected entry body to another protected
9909 -- Requeue_Protected_Entry (
9910 -- _object._object'Access,
9911 -- new._object'Access,
9916 -- <some more of the statement sequence for entry>
9918 -- -- Requeue from an entry body to a task entry
9920 -- Requeue_Protected_To_Task_Entry (
9926 -- <rest of statement sequence for entry>
9927 -- Complete_Entry_Body (_object._object);
9930 -- when all others =>
9931 -- Exceptional_Complete_Entry_Body (
9932 -- _object._object, Get_GNAT_Exception);
9936 -- Requeue of a task entry call to a task entry
9938 -- Accept_Call (E, Ann);
9939 -- <start of statement sequence for accept statement>
9940 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9942 -- <rest of statement sequence for accept statement>
9944 -- Complete_Rendezvous;
9947 -- when all others =>
9948 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9950 -- Requeue of a task entry call to a protected entry
9952 -- Accept_Call (E, Ann);
9953 -- <start of statement sequence for accept statement>
9954 -- Requeue_Task_To_Protected_Entry (
9955 -- new._object'Access,
9960 -- <rest of statement sequence for accept statement>
9962 -- Complete_Rendezvous;
9965 -- when all others =>
9966 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9968 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9969 -- marked by pragma Implemented (XXX, By_Entry).
9971 -- The requeue is inside a protected entry:
9974 -- (O : System.Address;
9975 -- P : System.Address;
9976 -- E : Protected_Entry_Index)
9978 -- <discriminant renamings>
9979 -- <private object renamings>
9980 -- type poVP is access poV;
9981 -- _object : ptVP := ptVP!(O);
9985 -- <start of statement sequence for entry>
9988 -- (<interface class-wide object>,
9991 -- Ada.Tags.Get_Offset_Index
9993 -- <interface dispatch table index of target entry>),
9997 -- <rest of statement sequence for entry>
9998 -- Complete_Entry_Body (_object._object);
10001 -- when all others =>
10002 -- Exceptional_Complete_Entry_Body (
10003 -- _object._object, Get_GNAT_Exception);
10007 -- The requeue is inside a task entry:
10009 -- Accept_Call (E, Ann);
10010 -- <start of statement sequence for accept statement>
10012 -- (<interface class-wide object>,
10015 -- Ada.Tags.Get_Offset_Index
10017 -- <interface dispatch table index of target entrt>),
10019 -- newS (new, Pnn);
10021 -- <rest of statement sequence for accept statement>
10023 -- Complete_Rendezvous;
10026 -- when all others =>
10027 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
10029 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
10030 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
10031 -- statement is replaced by a dispatching call with actual parameters taken
10032 -- from the inner-most accept statement or entry body.
10034 -- Target.Primitive (Param1, ..., ParamN);
10036 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
10037 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
10041 -- S : constant Offset_Index :=
10042 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
10043 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
10046 -- if C = POK_Protected_Entry
10047 -- or else C = POK_Task_Entry
10049 -- <statements for dispatching requeue>
10051 -- elsif C = POK_Protected_Procedure then
10052 -- <dispatching call equivalent>
10055 -- raise Program_Error;
10059 procedure Expand_N_Requeue_Statement (N : Node_Id) is
10060 Loc : constant Source_Ptr := Sloc (N);
10061 Conc_Typ : Entity_Id;
10064 Enc_Subp : Entity_Id;
10066 Old_Typ : Entity_Id;
10068 function Build_Dispatching_Call_Equivalent return Node_Id;
10069 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10070 -- the form Concval.Ename. It is statically known that Ename is allowed
10071 -- to be implemented by a protected procedure. Create a dispatching call
10072 -- equivalent of Concval.Ename taking the actual parameters from the
10073 -- inner-most accept statement or entry body.
10075 function Build_Dispatching_Requeue return Node_Id;
10076 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10077 -- the form Concval.Ename. It is statically known that Ename is allowed
10078 -- to be implemented by a protected or a task entry. Create a call to
10079 -- primitive _Disp_Requeue which handles the low-level actions.
10081 function Build_Dispatching_Requeue_To_Any return Node_Id;
10082 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
10083 -- the form Concval.Ename. Ename is either marked by pragma Implemented
10084 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
10085 -- determines at runtime whether Ename denotes an entry or a procedure
10086 -- and perform the appropriate kind of dispatching select.
10088 function Build_Normal_Requeue return Node_Id;
10089 -- N denotes a nondispatching requeue statement to either a task or a
10090 -- protected entry. Build the appropriate runtime call to perform the
10093 function Build_Skip_Statement (Search : Node_Id) return Node_Id;
10094 -- For a protected entry, create a return statement to skip the rest of
10095 -- the entry body. Otherwise, create a goto statement to skip the rest
10096 -- of a task accept statement. The lookup for the enclosing entry body
10097 -- or accept statement starts from Search.
10099 ---------------------------------------
10100 -- Build_Dispatching_Call_Equivalent --
10101 ---------------------------------------
10103 function Build_Dispatching_Call_Equivalent return Node_Id is
10104 Call_Ent : constant Entity_Id := Entity (Ename);
10105 Obj : constant Node_Id := Original_Node (Concval);
10112 -- Climb the parent chain looking for the inner-most entry body or
10113 -- accept statement.
10116 while Present (Acc_Ent)
10117 and then Nkind (Acc_Ent) not in N_Accept_Statement | N_Entry_Body
10119 Acc_Ent := Parent (Acc_Ent);
10122 -- A requeue statement should be housed inside an entry body or an
10123 -- accept statement at some level. If this is not the case, then the
10124 -- tree is malformed.
10126 pragma Assert (Present (Acc_Ent));
10128 -- Recover the list of formal parameters
10130 if Nkind (Acc_Ent) = N_Entry_Body then
10131 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
10134 Formals := Parameter_Specifications (Acc_Ent);
10136 -- Create the actual parameters for the dispatching call. These are
10137 -- simply copies of the entry body or accept statement formals in the
10138 -- same order as they appear.
10140 Actuals := No_List;
10142 if Present (Formals) then
10143 Actuals := New_List;
10144 Formal := First (Formals);
10145 while Present (Formal) loop
10146 Append_To (Actuals,
10147 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
10153 -- Obj.Call_Ent (Actuals);
10156 Make_Procedure_Call_Statement (Loc,
10158 Make_Selected_Component (Loc,
10159 Prefix => Make_Identifier (Loc, Chars (Obj)),
10160 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))),
10162 Parameter_Associations => Actuals);
10163 end Build_Dispatching_Call_Equivalent;
10165 -------------------------------
10166 -- Build_Dispatching_Requeue --
10167 -------------------------------
10169 function Build_Dispatching_Requeue return Node_Id is
10170 Params : constant List_Id := New_List;
10173 -- Process the "with abort" parameter
10175 Prepend_To (Params,
10176 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10178 -- Process the entry wrapper's position in the primary dispatch
10179 -- table parameter. Generate:
10181 -- Ada.Tags.Get_Entry_Index
10182 -- (T => To_Tag_Ptr (Obj'Address).all,
10184 -- Ada.Tags.Get_Offset_Index
10185 -- (Ada.Tags.Tag (Concval),
10186 -- <interface dispatch table position of Ename>));
10188 -- Note that Obj'Address is recursively expanded into a call to
10189 -- Base_Address (Obj).
10191 if Tagged_Type_Expansion then
10192 Prepend_To (Params,
10193 Make_Function_Call (Loc,
10194 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10195 Parameter_Associations => New_List (
10197 Make_Explicit_Dereference (Loc,
10198 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
10199 Make_Attribute_Reference (Loc,
10200 Prefix => New_Copy_Tree (Concval),
10201 Attribute_Name => Name_Address))),
10203 Make_Function_Call (Loc,
10204 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10205 Parameter_Associations => New_List (
10206 Unchecked_Convert_To (RTE (RE_Tag), Concval),
10207 Make_Integer_Literal (Loc,
10208 DT_Position (Entity (Ename))))))));
10213 Prepend_To (Params,
10214 Make_Function_Call (Loc,
10215 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10216 Parameter_Associations => New_List (
10218 Make_Attribute_Reference (Loc,
10220 Attribute_Name => Name_Tag),
10222 Make_Function_Call (Loc,
10223 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10225 Parameter_Associations => New_List (
10229 Make_Attribute_Reference (Loc,
10231 Attribute_Name => Name_Tag),
10235 Make_Attribute_Reference (Loc,
10236 Prefix => New_Occurrence_Of (Etype (Concval), Loc),
10237 Attribute_Name => Name_Tag),
10241 Make_Integer_Literal (Loc,
10242 DT_Position (Entity (Ename))))))));
10245 -- Specific actuals for protected to XXX requeue
10247 if Is_Protected_Type (Old_Typ) then
10248 Prepend_To (Params,
10249 Make_Attribute_Reference (Loc, -- _object'Address
10251 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10252 Attribute_Name => Name_Address));
10254 Prepend_To (Params, -- True
10255 New_Occurrence_Of (Standard_True, Loc));
10257 -- Specific actuals for task to XXX requeue
10260 pragma Assert (Is_Task_Type (Old_Typ));
10262 Prepend_To (Params, -- null
10263 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
10265 Prepend_To (Params, -- False
10266 New_Occurrence_Of (Standard_False, Loc));
10269 -- Add the object parameter
10271 Prepend_To (Params, New_Copy_Tree (Concval));
10274 -- _Disp_Requeue (<Params>);
10276 -- Find entity for Disp_Requeue operation, which belongs to
10277 -- the type and may not be directly visible.
10281 Op : Entity_Id := Empty;
10284 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
10285 while Present (Elmt) loop
10287 exit when Chars (Op) = Name_uDisp_Requeue;
10291 pragma Assert (Present (Op));
10294 Make_Procedure_Call_Statement (Loc,
10295 Name => New_Occurrence_Of (Op, Loc),
10296 Parameter_Associations => Params);
10298 end Build_Dispatching_Requeue;
10300 --------------------------------------
10301 -- Build_Dispatching_Requeue_To_Any --
10302 --------------------------------------
10304 function Build_Dispatching_Requeue_To_Any return Node_Id is
10305 Call_Ent : constant Entity_Id := Entity (Ename);
10306 Obj : constant Node_Id := Original_Node (Concval);
10307 Skip : constant Node_Id := Build_Skip_Statement (N);
10317 -- Dispatch table slot processing, generate:
10320 S := Build_S (Loc, Decls);
10322 -- Call kind processing, generate:
10323 -- C : Ada.Tags.Prim_Op_Kind;
10325 C := Build_C (Loc, Decls);
10328 -- S := Ada.Tags.Get_Offset_Index
10329 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10331 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
10334 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10337 Make_Procedure_Call_Statement (Loc,
10339 New_Occurrence_Of (
10340 Find_Prim_Op (Etype (Etype (Obj)),
10341 Name_uDisp_Get_Prim_Op_Kind),
10343 Parameter_Associations => New_List (
10344 New_Copy_Tree (Obj),
10345 New_Occurrence_Of (S, Loc),
10346 New_Occurrence_Of (C, Loc))));
10350 -- if C = POK_Protected_Entry
10351 -- or else C = POK_Task_Entry
10354 Make_Implicit_If_Statement (N,
10360 New_Occurrence_Of (C, Loc),
10362 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
10367 New_Occurrence_Of (C, Loc),
10369 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
10371 -- Dispatching requeue equivalent
10373 Then_Statements => New_List (
10374 Build_Dispatching_Requeue,
10377 -- elsif C = POK_Protected_Procedure then
10379 Elsif_Parts => New_List (
10380 Make_Elsif_Part (Loc,
10384 New_Occurrence_Of (C, Loc),
10386 New_Occurrence_Of (
10387 RTE (RE_POK_Protected_Procedure), Loc)),
10389 -- Dispatching call equivalent
10391 Then_Statements => New_List (
10392 Build_Dispatching_Call_Equivalent))),
10395 -- raise Program_Error;
10398 Else_Statements => New_List (
10399 Make_Raise_Program_Error (Loc,
10400 Reason => PE_Explicit_Raise))));
10402 -- Wrap everything into a block
10405 Make_Block_Statement (Loc,
10406 Declarations => Decls,
10407 Handled_Statement_Sequence =>
10408 Make_Handled_Sequence_Of_Statements (Loc,
10409 Statements => Stmts));
10410 end Build_Dispatching_Requeue_To_Any;
10412 --------------------------
10413 -- Build_Normal_Requeue --
10414 --------------------------
10416 function Build_Normal_Requeue return Node_Id is
10417 Params : constant List_Id := New_List;
10422 -- Process the "with abort" parameter
10424 Prepend_To (Params,
10425 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10427 -- Add the index expression to the parameters. It is common among all
10430 Prepend_To (Params,
10431 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
10433 if Is_Protected_Type (Old_Typ) then
10435 Self_Param : Node_Id;
10439 Make_Attribute_Reference (Loc,
10441 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10443 Name_Unchecked_Access);
10445 -- Protected to protected requeue
10447 if Is_Protected_Type (Conc_Typ) then
10449 New_Occurrence_Of (
10450 RTE (RE_Requeue_Protected_Entry), Loc);
10453 Make_Attribute_Reference (Loc,
10455 Concurrent_Ref (Concval),
10457 Name_Unchecked_Access);
10459 -- Protected to task requeue
10461 else pragma Assert (Is_Task_Type (Conc_Typ));
10463 New_Occurrence_Of (
10464 RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
10466 Param := Concurrent_Ref (Concval);
10469 Prepend_To (Params, Param);
10470 Prepend_To (Params, Self_Param);
10473 else pragma Assert (Is_Task_Type (Old_Typ));
10475 -- Task to protected requeue
10477 if Is_Protected_Type (Conc_Typ) then
10479 New_Occurrence_Of (
10480 RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
10483 Make_Attribute_Reference (Loc,
10485 Concurrent_Ref (Concval),
10487 Name_Unchecked_Access);
10489 -- Task to task requeue
10491 else pragma Assert (Is_Task_Type (Conc_Typ));
10493 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc);
10495 Param := Concurrent_Ref (Concval);
10498 Prepend_To (Params, Param);
10502 Make_Procedure_Call_Statement (Loc,
10504 Parameter_Associations => Params);
10505 end Build_Normal_Requeue;
10507 --------------------------
10508 -- Build_Skip_Statement --
10509 --------------------------
10511 function Build_Skip_Statement (Search : Node_Id) return Node_Id is
10512 Skip_Stmt : Node_Id;
10515 -- Build a return statement to skip the rest of the entire body
10517 if Is_Protected_Type (Old_Typ) then
10518 Skip_Stmt := Make_Simple_Return_Statement (Loc);
10520 -- If the requeue is within a task, find the end label of the
10521 -- enclosing accept statement and create a goto statement to it.
10529 -- Climb the parent chain looking for the enclosing accept
10532 Acc := Parent (Search);
10533 while Present (Acc)
10534 and then Nkind (Acc) /= N_Accept_Statement
10536 Acc := Parent (Acc);
10539 -- The last statement is the second label used for completing
10540 -- the rendezvous the usual way. The label we are looking for
10541 -- is right before it.
10544 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
10546 pragma Assert (Nkind (Label) = N_Label);
10548 -- Generate a goto statement to skip the rest of the accept
10551 Make_Goto_Statement (Loc,
10553 New_Occurrence_Of (Entity (Identifier (Label)), Loc));
10557 Set_Analyzed (Skip_Stmt);
10560 end Build_Skip_Statement;
10562 -- Start of processing for Expand_N_Requeue_Statement
10565 -- Extract the components of the entry call
10567 Extract_Entry (N, Concval, Ename, Index);
10568 Conc_Typ := Etype (Concval);
10570 -- Examine the scope stack in order to find nearest enclosing concurrent
10571 -- type. This will constitute our invocation source.
10573 Old_Typ := Current_Scope;
10574 while Present (Old_Typ)
10575 and then not Is_Concurrent_Type (Old_Typ)
10577 Old_Typ := Scope (Old_Typ);
10580 -- Obtain the innermost enclosing callable construct for use in
10581 -- generating a dynamic accessibility check.
10583 Enc_Subp := Current_Scope;
10585 if Ekind (Enc_Subp) not in Entry_Kind | Subprogram_Kind then
10586 Enc_Subp := Enclosing_Subprogram (Enc_Subp);
10589 -- Generate a dynamic accessibility check on the target object
10591 Insert_Before_And_Analyze (N,
10592 Make_Raise_Program_Error (Loc,
10595 Left_Opnd => Accessibility_Level (Name (N), Dynamic_Level),
10596 Right_Opnd => Make_Integer_Literal (Loc,
10597 Scope_Depth (Enc_Subp))),
10598 Reason => PE_Accessibility_Check_Failed));
10600 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10601 -- Concval.Ename where the type of Concval is class-wide concurrent
10604 if Ada_Version >= Ada_2012
10605 and then Present (Concval)
10606 and then Is_Class_Wide_Type (Conc_Typ)
10607 and then Is_Concurrent_Interface (Conc_Typ)
10610 Has_Impl : Boolean := False;
10611 Impl_Kind : Name_Id := No_Name;
10614 -- Check whether the Ename is flagged by pragma Implemented
10616 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
10618 Impl_Kind := Implementation_Kind (Entity (Ename));
10621 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10622 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10624 if Has_Impl and then Impl_Kind = Name_By_Entry then
10625 Rewrite (N, Build_Dispatching_Requeue);
10627 Insert_After (N, Build_Skip_Statement (N));
10629 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10630 -- a protected procedure. In this case the requeue is transformed
10631 -- into a dispatching call.
10634 and then Impl_Kind = Name_By_Protected_Procedure
10636 Rewrite (N, Build_Dispatching_Call_Equivalent);
10639 -- The procedure_or_entry_NAME's implementation kind is either
10640 -- By_Any, Optional, or pragma Implemented was not applied at all.
10641 -- In this case a runtime test determines whether Ename denotes an
10642 -- entry or a protected procedure and performs the appropriate
10646 Rewrite (N, Build_Dispatching_Requeue_To_Any);
10651 -- Processing for regular (nondispatching) requeues
10654 Rewrite (N, Build_Normal_Requeue);
10656 Insert_After (N, Build_Skip_Statement (N));
10658 end Expand_N_Requeue_Statement;
10660 -------------------------------
10661 -- Expand_N_Selective_Accept --
10662 -------------------------------
10664 procedure Expand_N_Selective_Accept (N : Node_Id) is
10665 Loc : constant Source_Ptr := Sloc (N);
10666 Alts : constant List_Id := Select_Alternatives (N);
10668 -- Note: in the below declarations a lot of new lists are allocated
10669 -- unconditionally which may well not end up being used. That's not
10670 -- a good idea since it wastes space gratuitously ???
10672 Accept_Case : List_Id;
10673 Accept_List : constant List_Id := New_List;
10676 Alt_List : constant List_Id := New_List;
10677 Alt_Stats : List_Id;
10678 Ann : Entity_Id := Empty;
10680 Check_Guard : Boolean := True;
10682 Decls : constant List_Id := New_List;
10683 Stats : constant List_Id := New_List;
10684 Body_List : constant List_Id := New_List;
10685 Trailing_List : constant List_Id := New_List;
10688 Else_Present : Boolean := False;
10689 Terminate_Alt : Node_Id := Empty;
10690 Select_Mode : Node_Id;
10692 Delay_Case : List_Id;
10693 Delay_Count : Integer := 0;
10694 Delay_Val : Entity_Id;
10695 Delay_Index : Entity_Id;
10696 Delay_Min : Entity_Id;
10697 Delay_Num : Pos := 1;
10698 Delay_Alt_List : List_Id := New_List;
10699 Delay_List : constant List_Id := New_List;
10703 First_Delay : Boolean := True;
10704 Guard_Open : Entity_Id;
10710 Num_Accept : Nat := 0;
10712 Time_Type : Entity_Id := Empty;
10713 Select_Call : Node_Id;
10715 Qnam : constant Entity_Id :=
10716 Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
10718 Xnam : constant Entity_Id :=
10719 Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
10721 -----------------------
10722 -- Local subprograms --
10723 -----------------------
10725 function Accept_Or_Raise return List_Id;
10726 -- For the rare case where delay alternatives all have guards, and
10727 -- all of them are closed, it is still possible that there were open
10728 -- accept alternatives with no callers. We must reexamine the
10729 -- Accept_List, and execute a selective wait with no else if some
10730 -- accept is open. If none, we raise program_error.
10732 procedure Add_Accept (Alt : Node_Id);
10733 -- Process a single accept statement in a select alternative. Build
10734 -- procedure for body of accept, and add entry to dispatch table with
10735 -- expression for guard, in preparation for call to run time select.
10737 function Make_And_Declare_Label (Num : Int) return Node_Id;
10738 -- Manufacture a label using Num as a serial number and declare it.
10739 -- The declaration is appended to Decls. The label marks the trailing
10740 -- statements of an accept or delay alternative.
10742 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
10743 -- Build call to Selective_Wait runtime routine
10745 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
10746 -- Add code to compare value of delay with previous values, and
10747 -- generate case entry for trailing statements.
10749 procedure Process_Accept_Alternative
10753 -- Add code to call corresponding procedure, and branch to
10754 -- trailing statements, if any.
10756 ---------------------
10757 -- Accept_Or_Raise --
10758 ---------------------
10760 function Accept_Or_Raise return List_Id is
10763 J : constant Entity_Id := Make_Temporary (Loc, 'J');
10766 -- We generate the following:
10768 -- for J in q'range loop
10769 -- if q(J).S /=null_task_entry then
10770 -- selective_wait (simple_mode,...);
10776 -- if no rendez_vous then
10777 -- raise program_error;
10780 -- Note that the code needs to know that the selector name
10781 -- in an Accept_Alternative is named S.
10783 Cond := Make_Op_Ne (Loc,
10785 Make_Selected_Component (Loc,
10787 Make_Indexed_Component (Loc,
10788 Prefix => New_Occurrence_Of (Qnam, Loc),
10789 Expressions => New_List (New_Occurrence_Of (J, Loc))),
10790 Selector_Name => Make_Identifier (Loc, Name_S)),
10792 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc));
10794 Stats := New_List (
10795 Make_Implicit_Loop_Statement (N,
10796 Iteration_Scheme =>
10797 Make_Iteration_Scheme (Loc,
10798 Loop_Parameter_Specification =>
10799 Make_Loop_Parameter_Specification (Loc,
10800 Defining_Identifier => J,
10801 Discrete_Subtype_Definition =>
10802 Make_Attribute_Reference (Loc,
10803 Prefix => New_Occurrence_Of (Qnam, Loc),
10804 Attribute_Name => Name_Range,
10805 Expressions => New_List (
10806 Make_Integer_Literal (Loc, 1))))),
10808 Statements => New_List (
10809 Make_Implicit_If_Statement (N,
10811 Then_Statements => New_List (
10813 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)),
10814 Make_Exit_Statement (Loc))))));
10817 Make_Raise_Program_Error (Loc,
10818 Condition => Make_Op_Eq (Loc,
10819 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
10821 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
10822 Reason => PE_All_Guards_Closed));
10825 end Accept_Or_Raise;
10831 procedure Add_Accept (Alt : Node_Id) is
10832 Acc_Stm : constant Node_Id := Accept_Statement (Alt);
10833 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm);
10834 Eloc : constant Source_Ptr := Sloc (Ename);
10835 Eent : constant Entity_Id := Entity (Ename);
10836 Index : constant Node_Id := Entry_Index (Acc_Stm);
10840 Null_Body : Node_Id;
10841 PB_Ent : Entity_Id;
10842 Proc_Body : Node_Id;
10844 -- Start of processing for Add_Accept
10848 Ann := Node (Last_Elmt (Accept_Address (Eent)));
10851 if Present (Condition (Alt)) then
10853 Make_If_Expression (Eloc, New_List (
10855 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
10856 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc)));
10858 Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent));
10861 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
10862 Null_Body := New_Occurrence_Of (Standard_False, Eloc);
10864 -- Always add call to Abort_Undefer when generating code, since
10865 -- this is what the runtime expects (abort deferred in
10866 -- Selective_Wait). In CodePeer mode this only confuses the
10867 -- analysis with unknown calls, so don't do it.
10869 if not CodePeer_Mode then
10870 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
10872 (First (Statements (Handled_Statement_Sequence
10873 (Accept_Statement (Alt)))),
10879 Make_Defining_Identifier (Eloc,
10880 New_External_Name (Chars (Ename), 'A', Num_Accept));
10882 -- Link the acceptor to the original receiving entry
10884 Set_Ekind (PB_Ent, E_Procedure);
10885 Set_Receiving_Entry (PB_Ent, Eent);
10887 if Comes_From_Source (Alt) then
10888 Set_Debug_Info_Needed (PB_Ent);
10892 Make_Subprogram_Body (Eloc,
10894 Make_Procedure_Specification (Eloc,
10895 Defining_Unit_Name => PB_Ent),
10896 Declarations => Declarations (Acc_Stm),
10897 Handled_Statement_Sequence =>
10898 Build_Accept_Body (Accept_Statement (Alt)));
10900 Reset_Scopes_To (Proc_Body, PB_Ent);
10902 -- During the analysis of the body of the accept statement, any
10903 -- zero cost exception handler records were collected in the
10904 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10905 -- This is where we move them to where they belong, namely the
10906 -- newly created procedure.
10908 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
10909 Append (Proc_Body, Body_List);
10912 Null_Body := New_Occurrence_Of (Standard_True, Eloc);
10914 -- if accept statement has declarations, insert above, given that
10915 -- we are not creating a body for the accept.
10917 if Present (Declarations (Acc_Stm)) then
10918 Insert_Actions (N, Declarations (Acc_Stm));
10922 Append_To (Accept_List,
10923 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr)));
10925 Num_Accept := Num_Accept + 1;
10928 ----------------------------
10929 -- Make_And_Declare_Label --
10930 ----------------------------
10932 function Make_And_Declare_Label (Num : Int) return Node_Id is
10936 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
10938 Make_Label (Loc, Lab_Id);
10941 Make_Implicit_Label_Declaration (Loc,
10942 Defining_Identifier =>
10943 Make_Defining_Identifier (Loc, Chars (Lab_Id)),
10944 Label_Construct => Lab));
10947 end Make_And_Declare_Label;
10949 ----------------------
10950 -- Make_Select_Call --
10951 ----------------------
10953 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
10954 Params : constant List_Id := New_List;
10958 Make_Attribute_Reference (Loc,
10959 Prefix => New_Occurrence_Of (Qnam, Loc),
10960 Attribute_Name => Name_Unchecked_Access));
10961 Append_To (Params, Select_Mode);
10962 Append_To (Params, New_Occurrence_Of (Ann, Loc));
10963 Append_To (Params, New_Occurrence_Of (Xnam, Loc));
10966 Make_Procedure_Call_Statement (Loc,
10967 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc),
10968 Parameter_Associations => Params);
10969 end Make_Select_Call;
10971 --------------------------------
10972 -- Process_Accept_Alternative --
10973 --------------------------------
10975 procedure Process_Accept_Alternative
10980 Astmt : constant Node_Id := Accept_Statement (Alt);
10981 Alt_Stats : List_Id;
10984 Adjust_Condition (Condition (Alt));
10986 -- Accept with body
10988 if Present (Handled_Statement_Sequence (Astmt)) then
10991 Make_Procedure_Call_Statement (Sloc (Proc),
10994 (Defining_Unit_Name (Specification (Proc)),
10997 -- Accept with no body (followed by trailing statements)
11001 Entry_Id : constant Entity_Id :=
11002 Entity (Entry_Direct_Name (Accept_Statement (Alt)));
11004 -- Ada 2020 (AI12-0279)
11006 if Has_Yield_Aspect (Entry_Id)
11007 and then RTE_Available (RE_Yield)
11011 Make_Procedure_Call_Statement (Sloc (Proc),
11012 New_Occurrence_Of (RTE (RE_Yield), Sloc (Proc))));
11014 Alt_Stats := Empty_List;
11019 Ensure_Statement_Present (Sloc (Astmt), Alt);
11021 -- After the call, if any, branch to trailing statements, if any.
11022 -- We create a label for each, as well as the corresponding label
11025 if not Is_Empty_List (Statements (Alt)) then
11026 Lab := Make_And_Declare_Label (Index);
11027 Append (Lab, Trailing_List);
11028 Append_List (Statements (Alt), Trailing_List);
11029 Append_To (Trailing_List,
11030 Make_Goto_Statement (Loc,
11031 Name => New_Copy (Identifier (End_Lab))));
11037 Append_To (Alt_Stats,
11038 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab))));
11040 Append_To (Alt_List,
11041 Make_Case_Statement_Alternative (Loc,
11042 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)),
11043 Statements => Alt_Stats));
11044 end Process_Accept_Alternative;
11046 -------------------------------
11047 -- Process_Delay_Alternative --
11048 -------------------------------
11050 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
11051 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt));
11053 Delay_Alt : List_Id;
11056 -- Deal with C/Fortran boolean as delay condition
11058 Adjust_Condition (Condition (Alt));
11060 -- Determine the smallest specified delay
11062 -- for each delay alternative generate:
11064 -- if guard-expression then
11065 -- Delay_Val := delay-expression;
11066 -- Guard_Open := True;
11067 -- if Delay_Val < Delay_Min then
11068 -- Delay_Min := Delay_Val;
11069 -- Delay_Index := Index;
11073 -- The enclosing if-statement is omitted if there is no guard
11075 if Delay_Count = 1 or else First_Delay then
11076 First_Delay := False;
11078 Delay_Alt := New_List (
11079 Make_Assignment_Statement (Loc,
11080 Name => New_Occurrence_Of (Delay_Min, Loc),
11081 Expression => Expression (Delay_Statement (Alt))));
11083 if Delay_Count > 1 then
11084 Append_To (Delay_Alt,
11085 Make_Assignment_Statement (Loc,
11086 Name => New_Occurrence_Of (Delay_Index, Loc),
11087 Expression => Make_Integer_Literal (Loc, Index)));
11091 Delay_Alt := New_List (
11092 Make_Assignment_Statement (Loc,
11093 Name => New_Occurrence_Of (Delay_Val, Loc),
11094 Expression => Expression (Delay_Statement (Alt))));
11096 if Time_Type = Standard_Duration then
11099 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc),
11100 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc));
11103 -- The scope of the time type must define a comparison
11104 -- operator. The scope itself may not be visible, so we
11105 -- construct a node with entity information to insure that
11106 -- semantic analysis can find the proper operator.
11109 Make_Function_Call (Loc,
11110 Name => Make_Selected_Component (Loc,
11112 New_Occurrence_Of (Scope (Time_Type), Loc),
11114 Make_Operator_Symbol (Loc,
11115 Chars => Name_Op_Lt,
11116 Strval => No_String)),
11117 Parameter_Associations =>
11119 New_Occurrence_Of (Delay_Val, Loc),
11120 New_Occurrence_Of (Delay_Min, Loc)));
11122 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
11125 Append_To (Delay_Alt,
11126 Make_Implicit_If_Statement (N,
11128 Then_Statements => New_List (
11129 Make_Assignment_Statement (Loc,
11130 Name => New_Occurrence_Of (Delay_Min, Loc),
11131 Expression => New_Occurrence_Of (Delay_Val, Loc)),
11133 Make_Assignment_Statement (Loc,
11134 Name => New_Occurrence_Of (Delay_Index, Loc),
11135 Expression => Make_Integer_Literal (Loc, Index)))));
11138 if Check_Guard then
11139 Append_To (Delay_Alt,
11140 Make_Assignment_Statement (Loc,
11141 Name => New_Occurrence_Of (Guard_Open, Loc),
11142 Expression => New_Occurrence_Of (Standard_True, Loc)));
11145 if Present (Condition (Alt)) then
11146 Delay_Alt := New_List (
11147 Make_Implicit_If_Statement (N,
11148 Condition => Condition (Alt),
11149 Then_Statements => Delay_Alt));
11152 Append_List (Delay_Alt, Delay_List);
11154 Ensure_Statement_Present (Dloc, Alt);
11156 -- If the delay alternative has a statement part, add choice to the
11157 -- case statements for delays.
11159 if not Is_Empty_List (Statements (Alt)) then
11161 if Delay_Count = 1 then
11162 Append_List (Statements (Alt), Delay_Alt_List);
11165 Append_To (Delay_Alt_List,
11166 Make_Case_Statement_Alternative (Loc,
11167 Discrete_Choices => New_List (
11168 Make_Integer_Literal (Loc, Index)),
11169 Statements => Statements (Alt)));
11172 elsif Delay_Count = 1 then
11174 -- If the single delay has no trailing statements, add a branch
11175 -- to the exit label to the selective wait.
11177 Delay_Alt_List := New_List (
11178 Make_Goto_Statement (Loc,
11179 Name => New_Copy (Identifier (End_Lab))));
11182 end Process_Delay_Alternative;
11184 -- Start of processing for Expand_N_Selective_Accept
11187 Process_Statements_For_Controlled_Objects (N);
11189 -- First insert some declarations before the select. The first is:
11193 -- This variable holds the parameters passed to the accept body. This
11194 -- declaration has already been inserted by the time we get here by
11195 -- a call to Expand_Accept_Declarations made from the semantics when
11196 -- processing the first accept statement contained in the select. We
11197 -- can find this entity as Accept_Address (E), where E is any of the
11198 -- entries references by contained accept statements.
11200 -- The first step is to scan the list of Selective_Accept_Statements
11201 -- to find this entity, and also count the number of accepts, and
11202 -- determine if terminated, delay or else is present:
11206 Alt := First (Alts);
11207 while Present (Alt) loop
11208 Process_Statements_For_Controlled_Objects (Alt);
11210 if Nkind (Alt) = N_Accept_Alternative then
11213 elsif Nkind (Alt) = N_Delay_Alternative then
11214 Delay_Count := Delay_Count + 1;
11216 -- If the delays are relative delays, the delay expressions have
11217 -- type Standard_Duration. Otherwise they must have some time type
11218 -- recognized by GNAT.
11220 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
11221 Time_Type := Standard_Duration;
11223 Time_Type := Etype (Expression (Delay_Statement (Alt)));
11225 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
11226 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
11230 -- Move this check to sem???
11232 "& is not a time type (RM 9.6(6))",
11233 Expression (Delay_Statement (Alt)), Time_Type);
11234 Time_Type := Standard_Duration;
11235 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
11239 if No (Condition (Alt)) then
11241 -- This guard will always be open
11243 Check_Guard := False;
11246 elsif Nkind (Alt) = N_Terminate_Alternative then
11247 Adjust_Condition (Condition (Alt));
11248 Terminate_Alt := Alt;
11251 Num_Alts := Num_Alts + 1;
11255 Else_Present := Present (Else_Statements (N));
11257 -- At the same time (see procedure Add_Accept) we build the accept list:
11259 -- Qnn : Accept_List (1 .. num-select) := (
11260 -- (null-body, entry-index),
11261 -- (null-body, entry-index),
11263 -- (null_body, entry-index));
11265 -- In the above declaration, null-body is True if the corresponding
11266 -- accept has no body, and false otherwise. The entry is either the
11267 -- entry index expression if there is no guard, or if a guard is
11268 -- present, then an if expression of the form:
11270 -- (if guard then entry-index else Null_Task_Entry)
11272 -- If a guard is statically known to be false, the entry can simply
11273 -- be omitted from the accept list.
11276 Make_Object_Declaration (Loc,
11277 Defining_Identifier => Qnam,
11278 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11279 Aliased_Present => True,
11281 Make_Qualified_Expression (Loc,
11283 New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11285 Make_Aggregate (Loc, Expressions => Accept_List))));
11287 -- Then we declare the variable that holds the index for the accept
11288 -- that will be selected for service:
11290 -- Xnn : Select_Index;
11293 Make_Object_Declaration (Loc,
11294 Defining_Identifier => Xnam,
11295 Object_Definition =>
11296 New_Occurrence_Of (RTE (RE_Select_Index), Loc),
11298 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)));
11300 -- After this follow procedure declarations for each accept body
11302 -- procedure Pnn is
11307 -- where the ... are statements from the corresponding procedure body.
11308 -- No parameters are involved, since the parameters are passed via Ann
11309 -- and the parameter references have already been expanded to be direct
11310 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11311 -- any embedded tasking statements (which would normally be illegal in
11312 -- procedures), have been converted to calls to the tasking runtime so
11313 -- there is no problem in putting them into procedures.
11315 -- The original accept statement has been expanded into a block in
11316 -- the same fashion as for simple accepts (see Build_Accept_Body).
11318 -- Note: we don't really need to build these procedures for the case
11319 -- where no delay statement is present, but it is just as easy to
11320 -- build them unconditionally, and not significantly inefficient,
11321 -- since if they are short they will be inlined anyway.
11323 -- The procedure declarations have been assembled in Body_List
11325 -- If delays are present, we must compute the required delay.
11326 -- We first generate the declarations:
11328 -- Delay_Index : Boolean := 0;
11329 -- Delay_Min : Some_Time_Type.Time;
11330 -- Delay_Val : Some_Time_Type.Time;
11332 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11333 -- active delay that is actually chosen as the basis for the possible
11334 -- delay if an immediate rendez-vous is not possible.
11336 -- In the most common case there is a single delay statement, and this
11337 -- is handled specially.
11339 if Delay_Count > 0 then
11341 -- Generate the required declarations
11344 Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
11346 Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
11348 Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
11350 pragma Assert (Present (Time_Type));
11353 Make_Object_Declaration (Loc,
11354 Defining_Identifier => Delay_Val,
11355 Object_Definition => New_Occurrence_Of (Time_Type, Loc)));
11358 Make_Object_Declaration (Loc,
11359 Defining_Identifier => Delay_Index,
11360 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
11361 Expression => Make_Integer_Literal (Loc, 0)));
11364 Make_Object_Declaration (Loc,
11365 Defining_Identifier => Delay_Min,
11366 Object_Definition => New_Occurrence_Of (Time_Type, Loc),
11368 Unchecked_Convert_To (Time_Type,
11369 Make_Attribute_Reference (Loc,
11371 New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
11372 Attribute_Name => Name_Last))));
11374 -- Create Duration and Delay_Mode objects used for passing a delay
11377 D := Make_Temporary (Loc, 'D');
11378 M := Make_Temporary (Loc, 'M');
11384 -- Note that these values are defined in s-osprim.ads and must
11385 -- be kept in sync:
11387 -- Relative : constant := 0;
11388 -- Absolute_Calendar : constant := 1;
11389 -- Absolute_RT : constant := 2;
11391 if Time_Type = Standard_Duration then
11392 Discr := Make_Integer_Literal (Loc, 0);
11394 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11395 Discr := Make_Integer_Literal (Loc, 1);
11399 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11400 Discr := Make_Integer_Literal (Loc, 2);
11404 Make_Object_Declaration (Loc,
11405 Defining_Identifier => D,
11406 Object_Definition =>
11407 New_Occurrence_Of (Standard_Duration, Loc)));
11410 Make_Object_Declaration (Loc,
11411 Defining_Identifier => M,
11412 Object_Definition =>
11413 New_Occurrence_Of (Standard_Integer, Loc),
11414 Expression => Discr));
11417 if Check_Guard then
11419 Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
11422 Make_Object_Declaration (Loc,
11423 Defining_Identifier => Guard_Open,
11424 Object_Definition =>
11425 New_Occurrence_Of (Standard_Boolean, Loc),
11427 New_Occurrence_Of (Standard_False, Loc)));
11430 -- Delay_Count is zero, don't need M and D set (suppress warning)
11437 if Present (Terminate_Alt) then
11439 -- If the terminate alternative guard is False, use
11440 -- Simple_Mode; otherwise use Terminate_Mode.
11442 if Present (Condition (Terminate_Alt)) then
11443 Select_Mode := Make_If_Expression (Loc,
11444 New_List (Condition (Terminate_Alt),
11445 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc),
11446 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)));
11448 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc);
11451 elsif Else_Present or Delay_Count > 0 then
11452 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc);
11455 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc);
11458 Select_Call := Make_Select_Call (Select_Mode);
11459 Append (Select_Call, Stats);
11461 -- Now generate code to act on the result. There is an entry
11462 -- in this case for each accept statement with a non-null body,
11463 -- followed by a branch to the statements that follow the Accept.
11464 -- In the absence of delay alternatives, we generate:
11467 -- when No_Rendezvous => -- omitted if simple mode
11482 -- Lab0: Else_Statements;
11485 -- Lab1: Trailing_Statements1;
11488 -- Lab2: Trailing_Statements2;
11493 -- Generate label for common exit
11495 End_Lab := Make_And_Declare_Label (Num_Alts + 1);
11497 -- First entry is the default case, when no rendezvous is possible
11499 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc));
11501 if Else_Present then
11503 -- If no rendezvous is possible, the else part is executed
11505 Lab := Make_And_Declare_Label (0);
11506 Alt_Stats := New_List (
11507 Make_Goto_Statement (Loc,
11508 Name => New_Copy (Identifier (Lab))));
11510 Append (Lab, Trailing_List);
11511 Append_List (Else_Statements (N), Trailing_List);
11512 Append_To (Trailing_List,
11513 Make_Goto_Statement (Loc,
11514 Name => New_Copy (Identifier (End_Lab))));
11516 Alt_Stats := New_List (
11517 Make_Goto_Statement (Loc,
11518 Name => New_Copy (Identifier (End_Lab))));
11521 Append_To (Alt_List,
11522 Make_Case_Statement_Alternative (Loc,
11523 Discrete_Choices => Choices,
11524 Statements => Alt_Stats));
11526 -- We make use of the fact that Accept_Index is an integer type, and
11527 -- generate successive literals for entries for each accept. Only those
11528 -- for which there is a body or trailing statements get a case entry.
11530 Alt := First (Select_Alternatives (N));
11531 Proc := First (Body_List);
11532 while Present (Alt) loop
11534 if Nkind (Alt) = N_Accept_Alternative then
11535 Process_Accept_Alternative (Alt, Index, Proc);
11536 Index := Index + 1;
11539 (Handled_Statement_Sequence (Accept_Statement (Alt)))
11544 elsif Nkind (Alt) = N_Delay_Alternative then
11545 Process_Delay_Alternative (Alt, Delay_Num);
11546 Delay_Num := Delay_Num + 1;
11552 -- An others choice is always added to the main case, as well
11553 -- as the delay case (to satisfy the compiler).
11555 Append_To (Alt_List,
11556 Make_Case_Statement_Alternative (Loc,
11557 Discrete_Choices =>
11558 New_List (Make_Others_Choice (Loc)),
11560 New_List (Make_Goto_Statement (Loc,
11561 Name => New_Copy (Identifier (End_Lab))))));
11563 Accept_Case := New_List (
11564 Make_Case_Statement (Loc,
11565 Expression => New_Occurrence_Of (Xnam, Loc),
11566 Alternatives => Alt_List));
11568 Append_List (Trailing_List, Accept_Case);
11569 Append_List (Body_List, Decls);
11571 -- Construct case statement for trailing statements of delay
11572 -- alternatives, if there are several of them.
11574 if Delay_Count > 1 then
11575 Append_To (Delay_Alt_List,
11576 Make_Case_Statement_Alternative (Loc,
11577 Discrete_Choices =>
11578 New_List (Make_Others_Choice (Loc)),
11580 New_List (Make_Null_Statement (Loc))));
11582 Delay_Case := New_List (
11583 Make_Case_Statement (Loc,
11584 Expression => New_Occurrence_Of (Delay_Index, Loc),
11585 Alternatives => Delay_Alt_List));
11587 Delay_Case := Delay_Alt_List;
11590 -- If there are no delay alternatives, we append the case statement
11591 -- to the statement list.
11593 if Delay_Count = 0 then
11594 Append_List (Accept_Case, Stats);
11596 -- Delay alternatives present
11599 -- If delay alternatives are present we generate:
11601 -- find minimum delay.
11602 -- DX := minimum delay;
11603 -- M := <delay mode>;
11604 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11607 -- if X = No_Rendezvous then
11608 -- case statement for delay statements.
11610 -- case statement for accept alternatives.
11621 -- The type of the delay expression is known to be legal
11623 if Time_Type = Standard_Duration then
11624 Conv := New_Occurrence_Of (Delay_Min, Loc);
11626 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11627 Conv := Make_Function_Call (Loc,
11628 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
11629 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11633 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11635 Conv := Make_Function_Call (Loc,
11636 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
11637 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11640 Stmt := Make_Assignment_Statement (Loc,
11641 Name => New_Occurrence_Of (D, Loc),
11642 Expression => Conv);
11644 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11646 Parms := Parameter_Associations (Select_Call);
11648 Parm := First (Parms);
11649 while Present (Parm) and then Parm /= Select_Mode loop
11653 pragma Assert (Present (Parm));
11654 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc));
11657 -- Prepare two new parameters of Duration and Delay_Mode type
11658 -- which represent the value and the mode of the minimum delay.
11661 Insert_After (Parm, New_Occurrence_Of (M, Loc));
11662 Insert_After (Parm, New_Occurrence_Of (D, Loc));
11664 -- Create a call to RTS
11666 Rewrite (Select_Call,
11667 Make_Procedure_Call_Statement (Loc,
11668 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc),
11669 Parameter_Associations => Parms));
11671 -- This new call should follow the calculation of the minimum
11674 Insert_List_Before (Select_Call, Delay_List);
11676 if Check_Guard then
11678 Make_Implicit_If_Statement (N,
11679 Condition => New_Occurrence_Of (Guard_Open, Loc),
11680 Then_Statements => New_List (
11681 New_Copy_Tree (Stmt),
11682 New_Copy_Tree (Select_Call)),
11683 Else_Statements => Accept_Or_Raise);
11684 Rewrite (Select_Call, Stmt);
11686 Insert_Before (Select_Call, Stmt);
11690 Make_Implicit_If_Statement (N,
11691 Condition => Make_Op_Eq (Loc,
11692 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
11694 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
11696 Then_Statements => Delay_Case,
11697 Else_Statements => Accept_Case);
11699 Append (Cases, Stats);
11703 Append (End_Lab, Stats);
11705 -- Replace accept statement with appropriate block
11708 Make_Block_Statement (Loc,
11709 Declarations => Decls,
11710 Handled_Statement_Sequence =>
11711 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)));
11714 -- Note: have to worry more about abort deferral in above code ???
11716 -- Final step is to unstack the Accept_Address entries for all accept
11717 -- statements appearing in accept alternatives in the select statement
11719 Alt := First (Alts);
11720 while Present (Alt) loop
11721 if Nkind (Alt) = N_Accept_Alternative then
11722 Remove_Last_Elmt (Accept_Address
11723 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
11728 end Expand_N_Selective_Accept;
11730 -------------------------------------------
11731 -- Expand_N_Single_Protected_Declaration --
11732 -------------------------------------------
11734 -- A single protected declaration should never be present after semantic
11735 -- analysis because it is transformed into a protected type declaration
11736 -- and an accompanying anonymous object. This routine ensures that the
11737 -- transformation takes place.
11739 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is
11741 raise Program_Error;
11742 end Expand_N_Single_Protected_Declaration;
11744 --------------------------------------
11745 -- Expand_N_Single_Task_Declaration --
11746 --------------------------------------
11748 -- A single task declaration should never be present after semantic
11749 -- analysis because it is transformed into a task type declaration and
11750 -- an accompanying anonymous object. This routine ensures that the
11751 -- transformation takes place.
11753 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
11755 raise Program_Error;
11756 end Expand_N_Single_Task_Declaration;
11758 ------------------------
11759 -- Expand_N_Task_Body --
11760 ------------------------
11762 -- Given a task body
11764 -- task body tname is
11770 -- This expansion routine converts it into a procedure and sets the
11771 -- elaboration flag for the procedure to true, to represent the fact
11772 -- that the task body is now elaborated:
11774 -- procedure tnameB (_Task : access tnameV) is
11775 -- discriminal : dtype renames _Task.discriminant;
11777 -- procedure _clean is
11779 -- Abort_Defer.all;
11781 -- Abort_Undefer.all;
11786 -- Abort_Undefer.all;
11788 -- System.Task_Stages.Complete_Activation;
11796 -- In addition, if the task body is an activator, then a call to activate
11797 -- tasks is added at the start of the statements, before the call to
11798 -- Complete_Activation, and if in addition the task is a master then it
11799 -- must be established as a master. These calls are inserted and analyzed
11800 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11803 -- There is one discriminal declaration line generated for each
11804 -- discriminant that is present to provide an easy reference point for
11805 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11807 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11808 -- task body procedures have a profile (Arg : System.Address). That is
11809 -- needed because GNARLI has to use the same access-to-subprogram type
11810 -- for all task types. We depend here on knowing that in GNAT, passing
11811 -- an address argument by value is identical to passing a record value
11812 -- by access (in either case a single pointer is passed), so even though
11813 -- this procedure has the wrong profile. In fact it's all OK, since the
11814 -- callings sequence is identical.
11816 procedure Expand_N_Task_Body (N : Node_Id) is
11817 Loc : constant Source_Ptr := Sloc (N);
11818 Ttyp : constant Entity_Id := Corresponding_Spec (N);
11822 Insert_Nod : Node_Id;
11823 -- Used to determine the proper location of wrapper body insertions
11826 -- if no task body procedure, means we had an error in configurable
11827 -- run-time mode, and there is no point in proceeding further.
11829 if No (Task_Body_Procedure (Ttyp)) then
11833 -- Add renaming declarations for discriminals and a declaration for the
11834 -- entry family index (if applicable).
11836 Install_Private_Data_Declarations
11837 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N));
11839 -- Add a call to Abort_Undefer at the very beginning of the task
11840 -- body since this body is called with abort still deferred.
11842 if Abort_Allowed then
11843 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
11845 (First (Statements (Handled_Statement_Sequence (N))), Call);
11849 -- The statement part has already been protected with an at_end and
11850 -- cleanup actions. The call to Complete_Activation must be placed
11851 -- at the head of the sequence of statements of that block. The
11852 -- declarations have been merged in this sequence of statements but
11853 -- the first real statement is accessible from the First_Real_Statement
11854 -- field (which was set for exactly this purpose).
11856 if Restricted_Profile then
11857 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
11859 Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
11863 (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
11867 Make_Subprogram_Body (Loc,
11868 Specification => Build_Task_Proc_Specification (Ttyp),
11869 Declarations => Declarations (N),
11870 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
11871 Set_Is_Task_Body_Procedure (New_N);
11873 -- If the task contains generic instantiations, cleanup actions are
11874 -- delayed until after instantiation. Transfer the activation chain to
11875 -- the subprogram, to insure that the activation call is properly
11876 -- generated. It the task body contains inner tasks, indicate that the
11877 -- subprogram is a task master.
11879 if Delay_Cleanups (Ttyp) then
11880 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
11881 Set_Is_Task_Master (New_N, Is_Task_Master (N));
11884 Rewrite (N, New_N);
11887 -- Set elaboration flag immediately after task body. If the body is a
11888 -- subunit, the flag is set in the declarative part containing the stub.
11890 if Nkind (Parent (N)) /= N_Subunit then
11892 Make_Assignment_Statement (Loc,
11894 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
11895 Expression => New_Occurrence_Of (Standard_True, Loc)));
11898 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11899 -- the task body. At this point all wrapper specs have been created,
11900 -- frozen and included in the dispatch table for the task type.
11902 if Ada_Version >= Ada_2005 then
11903 if Nkind (Parent (N)) = N_Subunit then
11904 Insert_Nod := Corresponding_Stub (Parent (N));
11909 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
11911 end Expand_N_Task_Body;
11913 ------------------------------------
11914 -- Expand_N_Task_Type_Declaration --
11915 ------------------------------------
11917 -- We have several things to do. First we must create a Boolean flag used
11918 -- to mark if the body is elaborated yet. This variable gets set to True
11919 -- when the body of the task is elaborated (we can't rely on the normal
11920 -- ABE mechanism for the task body, since we need to pass an access to
11921 -- this elaboration boolean to the runtime routines).
11923 -- taskE : aliased Boolean := False;
11925 -- Next a variable is declared to hold the task stack size (either the
11926 -- default : Unspecified_Size, or a value that is set by a pragma
11927 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11928 -- the variable is initialized with this value:
11930 -- taskZ : Size_Type := Unspecified_Size;
11932 -- taskZ : Size_Type := Size_Type (size_expression);
11934 -- Note: No variable is needed to hold the task relative deadline since
11935 -- its value would never be static because the parameter is of a private
11936 -- type (Ada.Real_Time.Time_Span).
11938 -- Next we create a corresponding record type declaration used to represent
11939 -- values of this task. The general form of this type declaration is
11941 -- type taskV (discriminants) is record
11942 -- _Task_Id : Task_Id;
11943 -- entry_family : array (bounds) of Void;
11944 -- _Priority : Integer := priority_expression;
11945 -- _Size : Size_Type := size_expression;
11946 -- _Secondary_Stack_Size : Size_Type := size_expression;
11947 -- _Task_Info : Task_Info_Type := task_info_expression;
11948 -- _CPU : Integer := cpu_range_expression;
11949 -- _Relative_Deadline : Time_Span := time_span_expression;
11950 -- _Domain : Dispatching_Domain := dd_expression;
11953 -- The discriminants are present only if the corresponding task type has
11954 -- discriminants, and they exactly mirror the task type discriminants.
11956 -- The Id field is always present. It contains the Task_Id value, as set by
11957 -- the call to Create_Task. Note that although the task is limited, the
11958 -- task value record type is not limited, so there is no problem in passing
11959 -- this field as an out parameter to Create_Task.
11961 -- One entry_family component is present for each entry family in the task
11962 -- definition. The bounds correspond to the bounds of the entry family
11963 -- (which may depend on discriminants). The element type is void, since we
11964 -- only need the bounds information for determining the entry index. Note
11965 -- that the use of an anonymous array would normally be illegal in this
11966 -- context, but this is a parser check, and the semantics is quite prepared
11967 -- to handle such a case.
11969 -- The _Size field is present only if a Storage_Size pragma appears in the
11970 -- task definition. The expression captures the argument that was present
11971 -- in the pragma, and is used to override the task stack size otherwise
11972 -- associated with the task type.
11974 -- The _Secondary_Stack_Size field is present only the task entity has a
11975 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11976 -- when the record init proc is built, to capture the expression of the
11977 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11978 -- be filled here since aspect evaluations are delayed till the freeze
11981 -- The _Priority field is present only if the task entity has a Priority or
11982 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11983 -- definition clause). It will be filled at the freeze point, when the
11984 -- record init proc is built, to capture the expression of the rep item
11985 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11986 -- here since aspect evaluations are delayed till the freeze point.
11988 -- The _Task_Info field is present only if a Task_Info pragma appears in
11989 -- the task definition. The expression captures the argument that was
11990 -- present in the pragma, and is used to provide the Task_Image parameter
11991 -- to the call to Create_Task.
11993 -- The _CPU field is present only if the task entity has a CPU rep item
11994 -- (pragma, aspect specification or attribute definition clause). It will
11995 -- be filled at the freeze point, when the record init proc is built, to
11996 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11997 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11998 -- are delayed till the freeze point.
12000 -- The _Relative_Deadline field is present only if a Relative_Deadline
12001 -- pragma appears in the task definition. The expression captures the
12002 -- argument that was present in the pragma, and is used to provide the
12003 -- Relative_Deadline parameter to the call to Create_Task.
12005 -- The _Domain field is present only if the task entity has a
12006 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
12007 -- definition clause). It will be filled at the freeze point, when the
12008 -- record init proc is built, to capture the expression of the rep item
12009 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
12010 -- here since aspect evaluations are delayed till the freeze point.
12012 -- When a task is declared, an instance of the task value record is
12013 -- created. The elaboration of this declaration creates the correct bounds
12014 -- for the entry families, and also evaluates the size, priority, and
12015 -- task_Info expressions if needed. The initialization routine for the task
12016 -- type itself then calls Create_Task with appropriate parameters to
12017 -- initialize the value of the Task_Id field.
12019 -- Note: the address of this record is passed as the "Discriminants"
12020 -- parameter for Create_Task. Since Create_Task merely passes this onto the
12021 -- body procedure, it does not matter that it does not quite match the
12022 -- GNARLI model of what is being passed (the record contains more than just
12023 -- the discriminants, but the discriminants can be found from the record
12026 -- The Entity_Id for this created record type is placed in the
12027 -- Corresponding_Record_Type field of the associated task type entity.
12029 -- Next we create a procedure specification for the task body procedure:
12031 -- procedure taskB (_Task : access taskV);
12033 -- Note that this must come after the record type declaration, since
12034 -- the spec refers to this type. It turns out that the initialization
12035 -- procedure for the value type references the task body spec, but that's
12036 -- fine, since it won't be generated till the freeze point for the type,
12037 -- which is certainly after the task body spec declaration.
12039 -- Finally, we set the task index value field of the entry attribute in
12040 -- the case of a simple entry.
12042 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
12043 Loc : constant Source_Ptr := Sloc (N);
12044 TaskId : constant Entity_Id := Defining_Identifier (N);
12045 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
12046 Tasknm : constant Name_Id := Chars (Tasktyp);
12047 Taskdef : constant Node_Id := Task_Definition (N);
12049 Body_Decl : Node_Id;
12051 Decl_Stack : Node_Id;
12053 Elab_Decl : Node_Id;
12054 Ent_Stack : Entity_Id;
12055 Proc_Spec : Node_Id;
12056 Rec_Decl : Node_Id;
12057 Rec_Ent : Entity_Id;
12058 Size_Decl : Entity_Id;
12059 Task_Size : Node_Id;
12061 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id;
12062 -- Searches the task definition T for the first occurrence of the pragma
12063 -- Relative Deadline. The caller has ensured that the pragma is present
12064 -- in the task definition. Note that this routine cannot be implemented
12065 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
12066 -- not chained because their expansion into a procedure call statement
12067 -- would cause a break in the chain.
12069 ----------------------------------
12070 -- Get_Relative_Deadline_Pragma --
12071 ----------------------------------
12073 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is
12077 N := First (Visible_Declarations (T));
12078 while Present (N) loop
12079 if Nkind (N) = N_Pragma
12080 and then Pragma_Name (N) = Name_Relative_Deadline
12088 N := First (Private_Declarations (T));
12089 while Present (N) loop
12090 if Nkind (N) = N_Pragma
12091 and then Pragma_Name (N) = Name_Relative_Deadline
12099 raise Program_Error;
12100 end Get_Relative_Deadline_Pragma;
12102 -- Start of processing for Expand_N_Task_Type_Declaration
12105 -- If already expanded, nothing to do
12107 if Present (Corresponding_Record_Type (Tasktyp)) then
12111 -- Here we will do the expansion
12113 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
12115 Rec_Ent := Defining_Identifier (Rec_Decl);
12116 Cdecls := Component_Items (Component_List
12117 (Type_Definition (Rec_Decl)));
12119 Qualify_Entity_Names (N);
12121 -- First create the elaboration variable
12124 Make_Object_Declaration (Loc,
12125 Defining_Identifier =>
12126 Make_Defining_Identifier (Sloc (Tasktyp),
12127 Chars => New_External_Name (Tasknm, 'E')),
12128 Aliased_Present => True,
12129 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
12130 Expression => New_Occurrence_Of (Standard_False, Loc));
12132 Insert_After (N, Elab_Decl);
12134 -- Next create the declaration of the size variable (tasknmZ)
12136 Set_Storage_Size_Variable (Tasktyp,
12137 Make_Defining_Identifier (Sloc (Tasktyp),
12138 Chars => New_External_Name (Tasknm, 'Z')));
12140 if Present (Taskdef)
12141 and then Has_Storage_Size_Pragma (Taskdef)
12143 Is_OK_Static_Expression
12145 (First (Pragma_Argument_Associations
12146 (Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
12149 Make_Object_Declaration (Loc,
12150 Defining_Identifier => Storage_Size_Variable (Tasktyp),
12151 Object_Definition =>
12152 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
12154 Convert_To (RTE (RE_Size_Type),
12156 (Expression (First (Pragma_Argument_Associations
12158 (TaskId, Name_Storage_Size)))))));
12162 Make_Object_Declaration (Loc,
12163 Defining_Identifier => Storage_Size_Variable (Tasktyp),
12164 Object_Definition =>
12165 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
12167 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
12170 Insert_After (Elab_Decl, Size_Decl);
12172 -- Next build the rest of the corresponding record declaration. This is
12173 -- done last, since the corresponding record initialization procedure
12174 -- will reference the previously created entities.
12176 -- Fill in the component declarations -- first the _Task_Id field
12179 Make_Component_Declaration (Loc,
12180 Defining_Identifier =>
12181 Make_Defining_Identifier (Loc, Name_uTask_Id),
12182 Component_Definition =>
12183 Make_Component_Definition (Loc,
12184 Aliased_Present => False,
12185 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id),
12188 -- Declare static ATCB (that is, created by the expander) if we are
12189 -- using the Restricted run time.
12191 if Restricted_Profile then
12193 Make_Component_Declaration (Loc,
12194 Defining_Identifier =>
12195 Make_Defining_Identifier (Loc, Name_uATCB),
12197 Component_Definition =>
12198 Make_Component_Definition (Loc,
12199 Aliased_Present => True,
12200 Subtype_Indication => Make_Subtype_Indication (Loc,
12202 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc),
12205 Make_Index_Or_Discriminant_Constraint (Loc,
12207 New_List (Make_Integer_Literal (Loc, 0)))))));
12211 -- Declare static stack (that is, created by the expander) if we are
12212 -- using the Restricted run time on a bare board configuration.
12214 if Restricted_Profile and then Preallocated_Stacks_On_Target then
12216 -- First we need to extract the appropriate stack size
12218 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
12220 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12222 Expr_N : constant Node_Id :=
12223 Expression (First (
12224 Pragma_Argument_Associations (
12225 Get_Rep_Pragma (TaskId, Name_Storage_Size))));
12226 Etyp : constant Entity_Id := Etype (Expr_N);
12227 P : constant Node_Id := Parent (Expr_N);
12230 -- The stack is defined inside the corresponding record.
12231 -- Therefore if the size of the stack is set by means of
12232 -- a discriminant, we must reference the discriminant of the
12233 -- corresponding record type.
12235 if Nkind (Expr_N) in N_Has_Entity
12236 and then Present (Discriminal_Link (Entity (Expr_N)))
12240 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
12242 Set_Parent (Task_Size, P);
12243 Set_Etype (Task_Size, Etyp);
12244 Set_Analyzed (Task_Size);
12247 Task_Size := New_Copy_Tree (Expr_N);
12253 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc);
12256 Decl_Stack := Make_Component_Declaration (Loc,
12257 Defining_Identifier => Ent_Stack,
12259 Component_Definition =>
12260 Make_Component_Definition (Loc,
12261 Aliased_Present => True,
12262 Subtype_Indication => Make_Subtype_Indication (Loc,
12264 New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
12267 Make_Index_Or_Discriminant_Constraint (Loc,
12268 Constraints => New_List (Make_Range (Loc,
12269 Low_Bound => Make_Integer_Literal (Loc, 1),
12270 High_Bound => Convert_To (RTE (RE_Storage_Offset),
12273 Append_To (Cdecls, Decl_Stack);
12275 -- The appropriate alignment for the stack is ensured by the run-time
12276 -- code in charge of task creation.
12280 -- Declare a static secondary stack if the conditions for a statically
12281 -- generated stack are met.
12283 if Create_Secondary_Stack_For_Task (TaskId) then
12285 Size_Expr : constant Node_Id :=
12286 Expression (First (
12287 Pragma_Argument_Associations (
12288 Get_Rep_Pragma (TaskId,
12289 Name_Secondary_Stack_Size))));
12291 Stack_Size : Node_Id;
12294 -- The secondary stack is defined inside the corresponding
12295 -- record. Therefore if the size of the stack is set by means
12296 -- of a discriminant, we must reference the discriminant of the
12297 -- corresponding record type.
12299 if Nkind (Size_Expr) in N_Has_Entity
12300 and then Present (Discriminal_Link (Entity (Size_Expr)))
12304 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))),
12306 Set_Parent (Stack_Size, Parent (Size_Expr));
12307 Set_Etype (Stack_Size, Etype (Size_Expr));
12308 Set_Analyzed (Stack_Size);
12311 Stack_Size := New_Copy_Tree (Size_Expr);
12314 -- Create the secondary stack for the task
12317 Make_Component_Declaration (Loc,
12318 Defining_Identifier =>
12319 Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
12320 Component_Definition =>
12321 Make_Component_Definition (Loc,
12322 Aliased_Present => True,
12323 Subtype_Indication =>
12324 Make_Subtype_Indication (Loc,
12326 New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
12328 Make_Index_Or_Discriminant_Constraint (Loc,
12329 Constraints => New_List (
12330 Convert_To (RTE (RE_Size_Type),
12333 Append_To (Cdecls, Decl_SS);
12337 -- Add components for entry families
12339 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
12341 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12342 -- item is present.
12344 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then
12346 Make_Component_Declaration (Loc,
12347 Defining_Identifier =>
12348 Make_Defining_Identifier (Loc, Name_uPriority),
12349 Component_Definition =>
12350 Make_Component_Definition (Loc,
12351 Aliased_Present => False,
12352 Subtype_Indication =>
12353 New_Occurrence_Of (Standard_Integer, Loc))));
12356 -- Add the _Size component if a Storage_Size pragma is present
12358 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12360 Make_Component_Declaration (Loc,
12361 Defining_Identifier =>
12362 Make_Defining_Identifier (Loc, Name_uSize),
12364 Component_Definition =>
12365 Make_Component_Definition (Loc,
12366 Aliased_Present => False,
12367 Subtype_Indication =>
12368 New_Occurrence_Of (RTE (RE_Size_Type), Loc)),
12371 Convert_To (RTE (RE_Size_Type),
12373 Expression (First (
12374 Pragma_Argument_Associations (
12375 Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
12378 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
12379 -- pragma is present.
12382 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False)
12385 Make_Component_Declaration (Loc,
12386 Defining_Identifier =>
12387 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size),
12389 Component_Definition =>
12390 Make_Component_Definition (Loc,
12391 Aliased_Present => False,
12392 Subtype_Indication =>
12393 New_Occurrence_Of (RTE (RE_Size_Type), Loc))));
12396 -- Add the _Task_Info component if a Task_Info pragma is present
12398 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then
12400 Make_Component_Declaration (Loc,
12401 Defining_Identifier =>
12402 Make_Defining_Identifier (Loc, Name_uTask_Info),
12404 Component_Definition =>
12405 Make_Component_Definition (Loc,
12406 Aliased_Present => False,
12407 Subtype_Indication =>
12408 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)),
12410 Expression => New_Copy (
12411 Expression (First (
12412 Pragma_Argument_Associations (
12414 (TaskId, Name_Task_Info, Check_Parents => False)))))));
12417 -- Add the _CPU component if a CPU rep item is present
12419 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then
12421 Make_Component_Declaration (Loc,
12422 Defining_Identifier =>
12423 Make_Defining_Identifier (Loc, Name_uCPU),
12425 Component_Definition =>
12426 Make_Component_Definition (Loc,
12427 Aliased_Present => False,
12428 Subtype_Indication =>
12429 New_Occurrence_Of (RTE (RE_CPU_Range), Loc))));
12432 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12433 -- present. If we are using a restricted run time this component will
12434 -- not be added (deadlines are not allowed by the Ravenscar profile),
12435 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
12438 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E')
12439 and then Present (Taskdef)
12440 and then Has_Relative_Deadline_Pragma (Taskdef)
12443 Make_Component_Declaration (Loc,
12444 Defining_Identifier =>
12445 Make_Defining_Identifier (Loc, Name_uRelative_Deadline),
12447 Component_Definition =>
12448 Make_Component_Definition (Loc,
12449 Aliased_Present => False,
12450 Subtype_Indication =>
12451 New_Occurrence_Of (RTE (RE_Time_Span), Loc)),
12454 Convert_To (RTE (RE_Time_Span),
12456 Expression (First (
12457 Pragma_Argument_Associations (
12458 Get_Relative_Deadline_Pragma (Taskdef))))))));
12461 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12462 -- item is present. If we are using a restricted run time this component
12463 -- will not be added (dispatching domains are not allowed by the
12464 -- Ravenscar profile).
12466 if not Restricted_Profile
12469 (TaskId, Name_Dispatching_Domain, Check_Parents => False)
12472 Make_Component_Declaration (Loc,
12473 Defining_Identifier =>
12474 Make_Defining_Identifier (Loc, Name_uDispatching_Domain),
12476 Component_Definition =>
12477 Make_Component_Definition (Loc,
12478 Aliased_Present => False,
12479 Subtype_Indication =>
12481 (RTE (RE_Dispatching_Domain_Access), Loc))));
12484 Insert_After (Size_Decl, Rec_Decl);
12486 -- Analyze the record declaration immediately after construction,
12487 -- because the initialization procedure is needed for single task
12488 -- declarations before the next entity is analyzed.
12490 Analyze (Rec_Decl);
12492 -- Create the declaration of the task body procedure
12494 Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
12496 Make_Subprogram_Declaration (Loc,
12497 Specification => Proc_Spec);
12498 Set_Is_Task_Body_Procedure (Body_Decl);
12500 Insert_After (Rec_Decl, Body_Decl);
12502 -- The subprogram does not comes from source, so we have to indicate the
12503 -- need for debugging information explicitly.
12505 if Comes_From_Source (Original_Node (N)) then
12506 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec));
12509 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12510 -- the corresponding record has been frozen.
12512 if Ada_Version >= Ada_2005 then
12513 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
12516 -- Ada 2005 (AI-345): We must defer freezing to allow further
12517 -- declaration of primitive subprograms covering task interfaces
12519 if Ada_Version <= Ada_95 then
12521 -- Now we can freeze the corresponding record. This needs manually
12522 -- freezing, since it is really part of the task type, and the task
12523 -- type is frozen at this stage. We of course need the initialization
12524 -- procedure for this corresponding record type and we won't get it
12525 -- in time if we don't freeze now.
12528 L : constant List_Id := Freeze_Entity (Rec_Ent, N);
12530 if Is_Non_Empty_List (L) then
12531 Insert_List_After (Body_Decl, L);
12536 -- Complete the expansion of access types to the current task type, if
12537 -- any were declared.
12539 Expand_Previous_Access_Type (Tasktyp);
12541 -- Create wrappers for entries that have contract cases, preconditions
12542 -- and postconditions.
12548 Ent := First_Entity (Tasktyp);
12549 while Present (Ent) loop
12550 if Ekind (Ent) in E_Entry | E_Entry_Family then
12551 Build_Contract_Wrapper (Ent, N);
12557 end Expand_N_Task_Type_Declaration;
12559 -------------------------------
12560 -- Expand_N_Timed_Entry_Call --
12561 -------------------------------
12563 -- A timed entry call in normal case is not implemented using ATC mechanism
12564 -- anymore for efficiency reason.
12574 -- is expanded as follows:
12576 -- 1) When T.E is a task entry_call;
12580 -- X : Task_Entry_Index := <entry index>;
12581 -- DX : Duration := To_Duration (D);
12582 -- M : Delay_Mode := <discriminant>;
12583 -- P : parms := (parm, parm, parm);
12586 -- Timed_Protected_Entry_Call
12587 -- (<acceptor-task>, X, P'Address, DX, M, B);
12595 -- 2) When T.E is a protected entry_call;
12599 -- X : Protected_Entry_Index := <entry index>;
12600 -- DX : Duration := To_Duration (D);
12601 -- M : Delay_Mode := <discriminant>;
12602 -- P : parms := (parm, parm, parm);
12605 -- Timed_Protected_Entry_Call
12606 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12614 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12615 -- is no delay and the triggering statements are executed. We first
12616 -- determine the kind of the triggering call and then execute a
12617 -- synchronized operation or a direct call.
12620 -- B : Boolean := False;
12621 -- C : Ada.Tags.Prim_Op_Kind;
12622 -- DX : Duration := To_Duration (D)
12623 -- K : Ada.Tags.Tagged_Kind :=
12624 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12625 -- M : Integer :=...;
12626 -- P : Parameters := (Param1 .. ParamN);
12630 -- if K = Ada.Tags.TK_Limited_Tagged
12631 -- or else K = Ada.Tags.TK_Tagged
12633 -- <dispatching-call>;
12638 -- Ada.Tags.Get_Offset_Index
12639 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12641 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12643 -- if C = POK_Protected_Entry
12644 -- or else C = POK_Task_Entry
12646 -- Param1 := P.Param1;
12648 -- ParamN := P.ParamN;
12652 -- if C = POK_Procedure
12653 -- or else C = POK_Protected_Procedure
12654 -- or else C = POK_Task_Procedure
12656 -- <dispatching-call>;
12662 -- <triggering-statements>
12664 -- <timed-statements>
12668 -- The triggering statement and the sequence of timed statements have not
12669 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12670 -- global references if within an instantiation.
12672 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
12674 Blk_Typ : Entity_Id;
12676 Call_Ent : Entity_Id;
12677 Conc_Typ_Stmts : List_Id;
12678 Concval : Node_Id := Empty; -- init to avoid warning
12679 D_Alt : constant Node_Id := Delay_Alternative (N);
12682 D_Stat : Node_Id := Delay_Statement (D_Alt);
12684 D_Type : Entity_Id;
12687 E_Alt : constant Node_Id := Entry_Call_Alternative (N);
12688 E_Call : Node_Id := Entry_Call_Statement (E_Alt);
12693 Is_Disp_Select : Boolean;
12694 Lim_Typ_Stmts : List_Id;
12695 Loc : constant Source_Ptr := Sloc (D_Stat);
12704 B : Entity_Id; -- Call status flag
12705 C : Entity_Id; -- Call kind
12706 D : Entity_Id; -- Delay
12707 K : Entity_Id; -- Tagged kind
12708 M : Entity_Id; -- Delay mode
12709 P : Entity_Id; -- Parameter block
12710 S : Entity_Id; -- Primitive operation slot
12712 -- Start of processing for Expand_N_Timed_Entry_Call
12715 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12716 -- was already reported on spec, so do not attempt to expand the call.
12718 if Restriction_Active (No_Select_Statements) then
12722 Process_Statements_For_Controlled_Objects (E_Alt);
12723 Process_Statements_For_Controlled_Objects (D_Alt);
12725 Ensure_Statement_Present (Sloc (D_Stat), D_Alt);
12727 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12728 -- may wrap them in blocks.
12730 E_Stats := Statements (E_Alt);
12731 D_Stats := Statements (D_Alt);
12733 -- The arguments in the call may require dynamic allocation, and the
12734 -- call statement may have been transformed into a block. The block
12735 -- may contain additional declarations for internal entities, and the
12736 -- original call is found by sequential search.
12738 if Nkind (E_Call) = N_Block_Statement then
12739 E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
12740 while Nkind (E_Call) not in
12741 N_Procedure_Call_Statement | N_Entry_Call_Statement
12748 Ada_Version >= Ada_2005
12749 and then Nkind (E_Call) = N_Procedure_Call_Statement;
12751 if Is_Disp_Select then
12752 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
12758 -- B : Boolean := False;
12760 B := Build_B (Loc, Decls);
12763 -- C : Ada.Tags.Prim_Op_Kind;
12765 C := Build_C (Loc, Decls);
12767 -- Because the analysis of all statements was disabled, manually
12768 -- analyze the delay statement.
12771 D_Stat := Original_Node (D_Stat);
12774 -- Build an entry call using Simple_Entry_Call
12776 Extract_Entry (E_Call, Concval, Ename, Index);
12777 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
12779 Decls := Declarations (E_Call);
12780 Stmts := Statements (Handled_Statement_Sequence (E_Call));
12789 B := Make_Defining_Identifier (Loc, Name_uB);
12792 Make_Object_Declaration (Loc,
12793 Defining_Identifier => B,
12794 Object_Definition =>
12795 New_Occurrence_Of (Standard_Boolean, Loc)));
12798 -- Duration and mode processing
12800 D_Type := Base_Type (Etype (Expression (D_Stat)));
12802 -- Use the type of the delay expression (Calendar or Real_Time) to
12803 -- generate the appropriate conversion.
12805 if Nkind (D_Stat) = N_Delay_Relative_Statement then
12806 D_Disc := Make_Integer_Literal (Loc, 0);
12807 D_Conv := Relocate_Node (Expression (D_Stat));
12809 elsif Is_RTE (D_Type, RO_CA_Time) then
12810 D_Disc := Make_Integer_Literal (Loc, 1);
12812 Make_Function_Call (Loc,
12813 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
12814 Parameter_Associations =>
12815 New_List (New_Copy (Expression (D_Stat))));
12817 else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
12818 D_Disc := Make_Integer_Literal (Loc, 2);
12820 Make_Function_Call (Loc,
12821 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
12822 Parameter_Associations =>
12823 New_List (New_Copy (Expression (D_Stat))));
12826 D := Make_Temporary (Loc, 'D');
12832 Make_Object_Declaration (Loc,
12833 Defining_Identifier => D,
12834 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc)));
12836 M := Make_Temporary (Loc, 'M');
12839 -- M : Integer := (0 | 1 | 2);
12842 Make_Object_Declaration (Loc,
12843 Defining_Identifier => M,
12844 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
12845 Expression => D_Disc));
12847 -- Parameter block processing
12849 -- Manually create the parameter block for dispatching calls. In the
12850 -- case of entries, the block has already been created during the call
12851 -- to Build_Simple_Entry_Call.
12853 if Is_Disp_Select then
12855 -- Compute the delay at this stage because the evaluation of its
12856 -- expression must not occur earlier (see ACVC C97302A).
12859 Make_Assignment_Statement (Loc,
12860 Name => New_Occurrence_Of (D, Loc),
12861 Expression => D_Conv));
12863 -- Tagged kind processing, generate:
12864 -- K : Ada.Tags.Tagged_Kind :=
12865 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12867 K := Build_K (Loc, Decls, Obj);
12869 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
12871 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
12873 -- Dispatch table slot processing, generate:
12876 S := Build_S (Loc, Decls);
12879 -- S := Ada.Tags.Get_Offset_Index
12880 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12883 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
12886 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12888 -- where Obj is the controlling formal parameter, S is the dispatch
12889 -- table slot number of the dispatching operation, P is the wrapped
12890 -- parameter block, D is the duration, M is the duration mode, C is
12891 -- the call kind and B is the call status.
12893 Params := New_List;
12895 Append_To (Params, New_Copy_Tree (Obj));
12896 Append_To (Params, New_Occurrence_Of (S, Loc));
12898 Make_Attribute_Reference (Loc,
12899 Prefix => New_Occurrence_Of (P, Loc),
12900 Attribute_Name => Name_Address));
12901 Append_To (Params, New_Occurrence_Of (D, Loc));
12902 Append_To (Params, New_Occurrence_Of (M, Loc));
12903 Append_To (Params, New_Occurrence_Of (C, Loc));
12904 Append_To (Params, New_Occurrence_Of (B, Loc));
12906 Append_To (Conc_Typ_Stmts,
12907 Make_Procedure_Call_Statement (Loc,
12911 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc),
12912 Parameter_Associations => Params));
12915 -- if C = POK_Protected_Entry
12916 -- or else C = POK_Task_Entry
12918 -- Param1 := P.Param1;
12920 -- ParamN := P.ParamN;
12923 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
12925 -- Generate the if statement only when the packed parameters need
12926 -- explicit assignments to their corresponding actuals.
12928 if Present (Unpack) then
12929 Append_To (Conc_Typ_Stmts,
12930 Make_Implicit_If_Statement (N,
12936 Left_Opnd => New_Occurrence_Of (C, Loc),
12939 (RTE (RE_POK_Protected_Entry), Loc)),
12943 Left_Opnd => New_Occurrence_Of (C, Loc),
12945 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
12947 Then_Statements => Unpack));
12953 -- if C = POK_Procedure
12954 -- or else C = POK_Protected_Procedure
12955 -- or else C = POK_Task_Procedure
12957 -- <dispatching-call>
12961 N_Stats := New_List (
12962 Make_Implicit_If_Statement (N,
12967 Left_Opnd => New_Occurrence_Of (C, Loc),
12969 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
12975 Left_Opnd => New_Occurrence_Of (C, Loc),
12977 New_Occurrence_Of (RTE (
12978 RE_POK_Protected_Procedure), Loc)),
12981 Left_Opnd => New_Occurrence_Of (C, Loc),
12984 (RTE (RE_POK_Task_Procedure), Loc)))),
12986 Then_Statements => New_List (E_Call)));
12988 Append_To (Conc_Typ_Stmts,
12989 Make_Implicit_If_Statement (N,
12990 Condition => New_Occurrence_Of (B, Loc),
12991 Then_Statements => N_Stats));
12994 -- <dispatching-call>;
12998 New_List (New_Copy_Tree (E_Call),
12999 Make_Assignment_Statement (Loc,
13000 Name => New_Occurrence_Of (B, Loc),
13001 Expression => New_Occurrence_Of (Standard_True, Loc)));
13004 -- if K = Ada.Tags.TK_Limited_Tagged
13005 -- or else K = Ada.Tags.TK_Tagged
13013 Make_Implicit_If_Statement (N,
13014 Condition => Build_Dispatching_Tag_Check (K, N),
13015 Then_Statements => Lim_Typ_Stmts,
13016 Else_Statements => Conc_Typ_Stmts));
13021 -- <triggering-statements>
13023 -- <timed-statements>
13027 Make_Implicit_If_Statement (N,
13028 Condition => New_Occurrence_Of (B, Loc),
13029 Then_Statements => E_Stats,
13030 Else_Statements => D_Stats));
13033 -- Simple case of a nondispatching trigger. Skip assignments to
13034 -- temporaries created for in-out parameters.
13036 -- This makes unwarranted assumptions about the shape of the expanded
13037 -- tree for the call, and should be cleaned up ???
13039 Stmt := First (Stmts);
13040 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
13044 -- Compute the delay at this stage because the evaluation of
13045 -- its expression must not occur earlier (see ACVC C97302A).
13047 Insert_Before (Stmt,
13048 Make_Assignment_Statement (Loc,
13049 Name => New_Occurrence_Of (D, Loc),
13050 Expression => D_Conv));
13053 Params := Parameter_Associations (Call);
13055 -- For a protected type, we build a Timed_Protected_Entry_Call
13057 if Is_Protected_Type (Etype (Concval)) then
13059 -- Create a new call statement
13061 Param := First (Params);
13062 while Present (Param)
13063 and then not Is_RTE (Etype (Param), RE_Call_Modes)
13068 Dummy := Remove_Next (Next (Param));
13070 -- Remove garbage is following the Cancel_Param if present
13072 Dummy := Next (Param);
13074 -- Remove the mode of the Protected_Entry_Call call, then remove
13075 -- the Communication_Block of the Protected_Entry_Call call, and
13076 -- finally add Duration and a Delay_Mode parameter
13078 pragma Assert (Present (Param));
13079 Rewrite (Param, New_Occurrence_Of (D, Loc));
13081 Rewrite (Dummy, New_Occurrence_Of (M, Loc));
13083 -- Add a Boolean flag for successful entry call
13085 Append_To (Params, New_Occurrence_Of (B, Loc));
13087 case Corresponding_Runtime_Package (Etype (Concval)) is
13088 when System_Tasking_Protected_Objects_Entries =>
13090 Make_Procedure_Call_Statement (Loc,
13093 (RTE (RE_Timed_Protected_Entry_Call), Loc),
13094 Parameter_Associations => Params));
13097 raise Program_Error;
13100 -- For the task case, build a Timed_Task_Entry_Call
13103 -- Create a new call statement
13105 Append_To (Params, New_Occurrence_Of (D, Loc));
13106 Append_To (Params, New_Occurrence_Of (M, Loc));
13107 Append_To (Params, New_Occurrence_Of (B, Loc));
13110 Make_Procedure_Call_Statement (Loc,
13112 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
13113 Parameter_Associations => Params));
13117 Make_Implicit_If_Statement (N,
13118 Condition => New_Occurrence_Of (B, Loc),
13119 Then_Statements => E_Stats,
13120 Else_Statements => D_Stats));
13124 Make_Block_Statement (Loc,
13125 Declarations => Decls,
13126 Handled_Statement_Sequence =>
13127 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
13131 -- Some items in Decls used to be in the N_Block in E_Call that is
13132 -- constructed in Expand_Entry_Call, and are now in the new Block
13133 -- into which N has been rewritten. Adjust their scopes to reflect that.
13135 if Nkind (E_Call) = N_Block_Statement then
13136 Obj := First_Entity (Entity (Identifier (E_Call)));
13137 while Present (Obj) loop
13138 Set_Scope (Obj, Entity (Identifier (N)));
13143 Reset_Scopes_To (N, Entity (Identifier (N)));
13144 end Expand_N_Timed_Entry_Call;
13146 ----------------------------------------
13147 -- Expand_Protected_Body_Declarations --
13148 ----------------------------------------
13150 procedure Expand_Protected_Body_Declarations
13152 Spec_Id : Entity_Id)
13155 if No_Run_Time_Mode then
13156 Error_Msg_CRT ("protected body", N);
13159 elsif Expander_Active then
13161 -- Associate discriminals with the first subprogram or entry body to
13164 if Present (First_Protected_Operation (Declarations (N))) then
13165 Set_Discriminals (Parent (Spec_Id));
13168 end Expand_Protected_Body_Declarations;
13170 -------------------------
13171 -- External_Subprogram --
13172 -------------------------
13174 function External_Subprogram (E : Entity_Id) return Entity_Id is
13175 Subp : constant Entity_Id := Protected_Body_Subprogram (E);
13178 -- The internal and external subprograms follow each other on the entity
13179 -- chain. Note that previously private operations had no separate
13180 -- external subprogram. We now create one in all cases, because a
13181 -- private operation may actually appear in an external call, through
13182 -- a 'Access reference used for a callback.
13184 -- If the operation is a function that returns an anonymous access type,
13185 -- the corresponding itype appears before the operation, and must be
13188 -- This mechanism is fragile, there should be a real link between the
13189 -- two versions of the operation, but there is no place to put it ???
13191 if Is_Access_Type (Next_Entity (Subp)) then
13192 return Next_Entity (Next_Entity (Subp));
13194 return Next_Entity (Subp);
13196 end External_Subprogram;
13198 ------------------------------
13199 -- Extract_Dispatching_Call --
13200 ------------------------------
13202 procedure Extract_Dispatching_Call
13204 Call_Ent : out Entity_Id;
13205 Object : out Entity_Id;
13206 Actuals : out List_Id;
13207 Formals : out List_Id)
13209 Call_Nam : Node_Id;
13212 pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
13214 if Present (Original_Node (N)) then
13215 Call_Nam := Name (Original_Node (N));
13217 Call_Nam := Name (N);
13220 -- Retrieve the name of the dispatching procedure. It contains the
13221 -- dispatch table slot number.
13224 case Nkind (Call_Nam) is
13225 when N_Identifier =>
13228 when N_Selected_Component =>
13229 Call_Nam := Selector_Name (Call_Nam);
13232 raise Program_Error;
13236 Actuals := Parameter_Associations (N);
13237 Call_Ent := Entity (Call_Nam);
13238 Formals := Parameter_Specifications (Parent (Call_Ent));
13239 Object := First (Actuals);
13241 if Present (Original_Node (Object)) then
13242 Object := Original_Node (Object);
13245 -- If the type of the dispatching object is an access type then return
13246 -- an explicit dereference of a copy of the object, and note that this
13247 -- is the controlling actual of the call.
13249 if Is_Access_Type (Etype (Object)) then
13251 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object));
13253 Set_Is_Controlling_Actual (Object);
13255 end Extract_Dispatching_Call;
13257 -------------------
13258 -- Extract_Entry --
13259 -------------------
13261 procedure Extract_Entry
13263 Concval : out Node_Id;
13264 Ename : out Node_Id;
13265 Index : out Node_Id)
13267 Nam : constant Node_Id := Name (N);
13270 -- For a simple entry, the name is a selected component, with the
13271 -- prefix being the task value, and the selector being the entry.
13273 if Nkind (Nam) = N_Selected_Component then
13274 Concval := Prefix (Nam);
13275 Ename := Selector_Name (Nam);
13278 -- For a member of an entry family, the name is an indexed component
13279 -- where the prefix is a selected component, whose prefix in turn is
13280 -- the task value, and whose selector is the entry family. The single
13281 -- expression in the expressions list of the indexed component is the
13282 -- subscript for the family.
13284 else pragma Assert (Nkind (Nam) = N_Indexed_Component);
13285 Concval := Prefix (Prefix (Nam));
13286 Ename := Selector_Name (Prefix (Nam));
13287 Index := First (Expressions (Nam));
13290 -- Through indirection, the type may actually be a limited view of a
13291 -- concurrent type. When compiling a call, the non-limited view of the
13292 -- type is visible.
13294 if From_Limited_With (Etype (Concval)) then
13295 Set_Etype (Concval, Non_Limited_View (Etype (Concval)));
13299 -------------------
13300 -- Family_Offset --
13301 -------------------
13303 function Family_Offset
13308 Cap : Boolean) return Node_Id
13314 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
13315 -- If one of the bounds is a reference to a discriminant, replace with
13316 -- corresponding discriminal of type. Within the body of a task retrieve
13317 -- the renamed discriminant by simple visibility, using its generated
13318 -- name. Within a protected object, find the original discriminant and
13319 -- replace it with the discriminal of the current protected operation.
13321 ------------------------------
13322 -- Convert_Discriminant_Ref --
13323 ------------------------------
13325 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
13326 Loc : constant Source_Ptr := Sloc (Bound);
13331 if Is_Entity_Name (Bound)
13332 and then Ekind (Entity (Bound)) = E_Discriminant
13334 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then
13335 B := Make_Identifier (Loc, Chars (Entity (Bound)));
13336 Find_Direct_Name (B);
13338 elsif Is_Protected_Type (Ttyp) then
13339 D := First_Discriminant (Ttyp);
13340 while Chars (D) /= Chars (Entity (Bound)) loop
13341 Next_Discriminant (D);
13344 B := New_Occurrence_Of (Discriminal (D), Loc);
13347 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
13350 elsif Nkind (Bound) = N_Attribute_Reference then
13354 B := New_Copy_Tree (Bound);
13358 Make_Attribute_Reference (Loc,
13359 Attribute_Name => Name_Pos,
13360 Prefix => New_Occurrence_Of (Etype (Bound), Loc),
13361 Expressions => New_List (B));
13362 end Convert_Discriminant_Ref;
13364 -- Start of processing for Family_Offset
13367 Real_Hi := Convert_Discriminant_Ref (Hi);
13368 Real_Lo := Convert_Discriminant_Ref (Lo);
13371 if Is_Task_Type (Ttyp) then
13372 Ityp := RTE (RE_Task_Entry_Index);
13374 Ityp := RTE (RE_Protected_Entry_Index);
13378 Make_Attribute_Reference (Loc,
13379 Prefix => New_Occurrence_Of (Ityp, Loc),
13380 Attribute_Name => Name_Min,
13381 Expressions => New_List (
13383 Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
13386 Make_Attribute_Reference (Loc,
13387 Prefix => New_Occurrence_Of (Ityp, Loc),
13388 Attribute_Name => Name_Max,
13389 Expressions => New_List (
13391 Make_Integer_Literal (Loc, -Entry_Family_Bound)));
13394 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
13401 function Family_Size
13406 Cap : Boolean) return Node_Id
13411 if Is_Task_Type (Ttyp) then
13412 Ityp := RTE (RE_Task_Entry_Index);
13414 Ityp := RTE (RE_Protected_Entry_Index);
13418 Make_Attribute_Reference (Loc,
13419 Prefix => New_Occurrence_Of (Ityp, Loc),
13420 Attribute_Name => Name_Max,
13421 Expressions => New_List (
13423 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
13424 Right_Opnd => Make_Integer_Literal (Loc, 1)),
13425 Make_Integer_Literal (Loc, 0)));
13428 ----------------------------
13429 -- Find_Enclosing_Context --
13430 ----------------------------
13432 procedure Find_Enclosing_Context
13434 Context : out Node_Id;
13435 Context_Id : out Entity_Id;
13436 Context_Decls : out List_Id)
13439 -- Traverse the parent chain looking for an enclosing body, block,
13440 -- package or return statement.
13442 Context := Parent (N);
13443 while Present (Context) loop
13444 if Nkind (Context) in N_Entry_Body
13445 | N_Extended_Return_Statement
13447 | N_Package_Declaration
13448 | N_Subprogram_Body
13453 -- Do not consider block created to protect a list of statements with
13454 -- an Abort_Defer / Abort_Undefer_Direct pair.
13456 elsif Nkind (Context) = N_Block_Statement
13457 and then not Is_Abort_Block (Context)
13462 Context := Parent (Context);
13465 pragma Assert (Present (Context));
13467 -- Extract the constituents of the context
13469 if Nkind (Context) = N_Extended_Return_Statement then
13470 Context_Decls := Return_Object_Declarations (Context);
13471 Context_Id := Return_Statement_Entity (Context);
13473 -- Package declarations and bodies use a common library-level activation
13474 -- chain or task master, therefore return the package declaration as the
13475 -- proper carrier for the appropriate flag.
13477 elsif Nkind (Context) = N_Package_Body then
13478 Context_Decls := Declarations (Context);
13479 Context_Id := Corresponding_Spec (Context);
13480 Context := Parent (Context_Id);
13482 if Nkind (Context) = N_Defining_Program_Unit_Name then
13483 Context := Parent (Parent (Context));
13485 Context := Parent (Context);
13488 elsif Nkind (Context) = N_Package_Declaration then
13489 Context_Decls := Visible_Declarations (Specification (Context));
13490 Context_Id := Defining_Unit_Name (Specification (Context));
13492 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13493 Context_Id := Defining_Identifier (Context_Id);
13497 if Nkind (Context) = N_Block_Statement then
13498 Context_Id := Entity (Identifier (Context));
13500 if No (Declarations (Context)) then
13501 Set_Declarations (Context, New_List);
13504 elsif Nkind (Context) = N_Entry_Body then
13505 Context_Id := Defining_Identifier (Context);
13507 elsif Nkind (Context) = N_Subprogram_Body then
13508 if Present (Corresponding_Spec (Context)) then
13509 Context_Id := Corresponding_Spec (Context);
13511 Context_Id := Defining_Unit_Name (Specification (Context));
13513 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13514 Context_Id := Defining_Identifier (Context_Id);
13518 elsif Nkind (Context) = N_Task_Body then
13519 Context_Id := Corresponding_Spec (Context);
13522 raise Program_Error;
13525 Context_Decls := Declarations (Context);
13528 pragma Assert (Present (Context_Id));
13529 pragma Assert (Present (Context_Decls));
13530 end Find_Enclosing_Context;
13532 -----------------------
13533 -- Find_Master_Scope --
13534 -----------------------
13536 function Find_Master_Scope (E : Entity_Id) return Entity_Id is
13540 -- In Ada 2005, the master is the innermost enclosing scope that is not
13541 -- transient. If the enclosing block is the rewriting of a call or the
13542 -- scope is an extended return statement this is valid master. The
13543 -- master in an extended return is only used within the return, and is
13544 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13545 -- now before that overwriting occurs.
13549 if Ada_Version >= Ada_2005 then
13550 while Is_Internal (S) loop
13551 if Nkind (Parent (S)) = N_Block_Statement
13552 and then Has_Master_Entity (S)
13556 elsif Ekind (S) = E_Return_Statement then
13566 end Find_Master_Scope;
13568 -------------------------------
13569 -- First_Protected_Operation --
13570 -------------------------------
13572 function First_Protected_Operation (D : List_Id) return Node_Id is
13573 First_Op : Node_Id;
13576 First_Op := First (D);
13577 while Present (First_Op)
13578 and then Nkind (First_Op) not in N_Subprogram_Body | N_Entry_Body
13584 end First_Protected_Operation;
13586 ---------------------------------------
13587 -- Install_Private_Data_Declarations --
13588 ---------------------------------------
13590 procedure Install_Private_Data_Declarations
13592 Spec_Id : Entity_Id;
13593 Conc_Typ : Entity_Id;
13594 Body_Nod : Node_Id;
13596 Barrier : Boolean := False;
13597 Family : Boolean := False)
13599 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ);
13602 Insert_Node : Node_Id := Empty;
13603 Obj_Ent : Entity_Id;
13605 procedure Add (Decl : Node_Id);
13606 -- Add a single declaration after Insert_Node. If this is the first
13607 -- addition, Decl is added to the front of Decls and it becomes the
13610 function Replace_Bound (Bound : Node_Id) return Node_Id;
13611 -- The bounds of an entry index may depend on discriminants, create a
13612 -- reference to the corresponding prival. Otherwise return a duplicate
13613 -- of the original bound.
13619 procedure Add (Decl : Node_Id) is
13621 if No (Insert_Node) then
13622 Prepend_To (Decls, Decl);
13624 Insert_After (Insert_Node, Decl);
13627 Insert_Node := Decl;
13630 -------------------
13631 -- Replace_Bound --
13632 -------------------
13634 function Replace_Bound (Bound : Node_Id) return Node_Id is
13636 if Nkind (Bound) = N_Identifier
13637 and then Is_Discriminal (Entity (Bound))
13639 return Make_Identifier (Loc, Chars (Entity (Bound)));
13641 return Duplicate_Subexpr (Bound);
13645 -- Start of processing for Install_Private_Data_Declarations
13648 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13649 -- formal parameter _O, _object or _task depending on the context.
13651 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ);
13653 -- Special processing of _O for barrier functions, protected entries
13660 (Ekind (Spec_Id) = E_Entry
13661 or else Ekind (Spec_Id) = E_Entry_Family))
13664 Conc_Rec : constant Entity_Id :=
13665 Corresponding_Record_Type (Conc_Typ);
13666 Typ_Id : constant Entity_Id :=
13667 Make_Defining_Identifier (Loc,
13668 New_External_Name (Chars (Conc_Rec), 'P'));
13671 -- type prot_typVP is access prot_typV;
13674 Make_Full_Type_Declaration (Loc,
13675 Defining_Identifier => Typ_Id,
13677 Make_Access_To_Object_Definition (Loc,
13678 Subtype_Indication =>
13679 New_Occurrence_Of (Conc_Rec, Loc)));
13683 -- _object : prot_typVP := prot_typV (_O);
13686 Make_Object_Declaration (Loc,
13687 Defining_Identifier =>
13688 Make_Defining_Identifier (Loc, Name_uObject),
13689 Object_Definition => New_Occurrence_Of (Typ_Id, Loc),
13691 Unchecked_Convert_To (Typ_Id,
13692 New_Occurrence_Of (Obj_Ent, Loc)));
13695 -- Set the reference to the concurrent object
13697 Obj_Ent := Defining_Identifier (Decl);
13701 -- Step 2: Create the Protection object and build its declaration for
13702 -- any protected entry (family) of subprogram. Note for the lock-free
13703 -- implementation, the Protection object is not needed anymore.
13705 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then
13707 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
13711 Set_Protection_Object (Spec_Id, Prot_Ent);
13713 -- Determine the proper protection type
13715 if Has_Attach_Handler (Conc_Typ)
13716 and then not Restricted_Profile
13718 Prot_Typ := RE_Static_Interrupt_Protection;
13720 elsif Has_Interrupt_Handler (Conc_Typ)
13721 and then not Restriction_Active (No_Dynamic_Attachment)
13723 Prot_Typ := RE_Dynamic_Interrupt_Protection;
13726 case Corresponding_Runtime_Package (Conc_Typ) is
13727 when System_Tasking_Protected_Objects_Entries =>
13728 Prot_Typ := RE_Protection_Entries;
13730 when System_Tasking_Protected_Objects_Single_Entry =>
13731 Prot_Typ := RE_Protection_Entry;
13733 when System_Tasking_Protected_Objects =>
13734 Prot_Typ := RE_Protection;
13737 raise Program_Error;
13742 -- conc_typR : protection_typ renames _object._object;
13745 Make_Object_Renaming_Declaration (Loc,
13746 Defining_Identifier => Prot_Ent,
13748 New_Occurrence_Of (RTE (Prot_Typ), Loc),
13750 Make_Selected_Component (Loc,
13751 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13752 Selector_Name => Make_Identifier (Loc, Name_uObject)));
13757 -- Step 3: Add discriminant renamings (if any)
13759 if Has_Discriminants (Conc_Typ) then
13764 D := First_Discriminant (Conc_Typ);
13765 while Present (D) loop
13767 -- Adjust the source location
13769 Set_Sloc (Discriminal (D), Loc);
13772 -- discr_name : discr_typ renames _object.discr_name;
13774 -- discr_name : discr_typ renames _task.discr_name;
13777 Make_Object_Renaming_Declaration (Loc,
13778 Defining_Identifier => Discriminal (D),
13779 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
13781 Make_Selected_Component (Loc,
13782 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13783 Selector_Name => Make_Identifier (Loc, Chars (D))));
13786 -- Set debug info needed on this renaming declaration even
13787 -- though it does not come from source, so that the debugger
13788 -- will get the right information for these generated names.
13790 Set_Debug_Info_Needed (Discriminal (D));
13792 Next_Discriminant (D);
13797 -- Step 4: Add private component renamings (if any)
13799 if Is_Protected then
13800 Def := Protected_Definition (Parent (Conc_Typ));
13802 if Present (Private_Declarations (Def)) then
13805 Comp_Id : Entity_Id;
13806 Decl_Id : Entity_Id;
13809 Comp := First (Private_Declarations (Def));
13810 while Present (Comp) loop
13811 if Nkind (Comp) = N_Component_Declaration then
13812 Comp_Id := Defining_Identifier (Comp);
13814 Make_Defining_Identifier (Loc, Chars (Comp_Id));
13816 -- Minimal decoration
13818 if Ekind (Spec_Id) = E_Function then
13819 Set_Ekind (Decl_Id, E_Constant);
13821 Set_Ekind (Decl_Id, E_Variable);
13824 Set_Prival (Comp_Id, Decl_Id);
13825 Set_Prival_Link (Decl_Id, Comp_Id);
13826 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
13827 Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id));
13830 -- comp_name : comp_typ renames _object.comp_name;
13833 Make_Object_Renaming_Declaration (Loc,
13834 Defining_Identifier => Decl_Id,
13836 New_Occurrence_Of (Etype (Comp_Id), Loc),
13838 Make_Selected_Component (Loc,
13840 New_Occurrence_Of (Obj_Ent, Loc),
13842 Make_Identifier (Loc, Chars (Comp_Id))));
13852 -- Step 5: Add the declaration of the entry index and the associated
13853 -- type for barrier functions and entry families.
13855 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then
13857 E : constant Entity_Id := Index_Object (Spec_Id);
13858 Index : constant Entity_Id :=
13859 Defining_Identifier
13860 (Entry_Index_Specification
13861 (Entry_Body_Formal_Part (Body_Nod)));
13862 Index_Con : constant Entity_Id :=
13863 Make_Defining_Identifier (Loc, Chars (Index));
13865 Index_Typ : Entity_Id;
13869 -- Minimal decoration
13871 Set_Ekind (Index_Con, E_Constant);
13872 Set_Entry_Index_Constant (Index, Index_Con);
13873 Set_Discriminal_Link (Index_Con, Index);
13875 -- Retrieve the bounds of the entry family
13877 High := Type_High_Bound (Etype (Index));
13878 Low := Type_Low_Bound (Etype (Index));
13880 -- In the simple case the entry family is given by a subtype mark
13881 -- and the index constant has the same type.
13883 if Is_Entity_Name (Original_Node (
13884 Discrete_Subtype_Definition (Parent (Index))))
13886 Index_Typ := Etype (Index);
13888 -- Otherwise a new subtype declaration is required
13891 High := Replace_Bound (High);
13892 Low := Replace_Bound (Low);
13894 Index_Typ := Make_Temporary (Loc, 'J');
13897 -- subtype Jnn is <Etype of Index> range Low .. High;
13900 Make_Subtype_Declaration (Loc,
13901 Defining_Identifier => Index_Typ,
13902 Subtype_Indication =>
13903 Make_Subtype_Indication (Loc,
13905 New_Occurrence_Of (Base_Type (Etype (Index)), Loc),
13907 Make_Range_Constraint (Loc,
13908 Range_Expression =>
13909 Make_Range (Loc, Low, High))));
13913 Set_Etype (Index_Con, Index_Typ);
13915 -- Create the object which designates the index:
13916 -- J : constant Jnn :=
13917 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13919 -- where Jnn is the subtype created above or the original type of
13920 -- the index, _E is a formal of the protected body subprogram and
13921 -- <index expr> is the index of the first family member.
13924 Make_Object_Declaration (Loc,
13925 Defining_Identifier => Index_Con,
13926 Constant_Present => True,
13927 Object_Definition =>
13928 New_Occurrence_Of (Index_Typ, Loc),
13931 Make_Attribute_Reference (Loc,
13933 New_Occurrence_Of (Index_Typ, Loc),
13934 Attribute_Name => Name_Val,
13936 Expressions => New_List (
13940 Make_Op_Subtract (Loc,
13941 Left_Opnd => New_Occurrence_Of (E, Loc),
13943 Entry_Index_Expression (Loc,
13944 Defining_Identifier (Body_Nod),
13948 Make_Attribute_Reference (Loc,
13950 New_Occurrence_Of (Index_Typ, Loc),
13951 Attribute_Name => Name_Pos,
13952 Expressions => New_List (
13953 Make_Attribute_Reference (Loc,
13955 New_Occurrence_Of (Index_Typ, Loc),
13956 Attribute_Name => Name_First)))))));
13960 end Install_Private_Data_Declarations;
13962 ---------------------------------
13963 -- Is_Potentially_Large_Family --
13964 ---------------------------------
13966 function Is_Potentially_Large_Family
13967 (Base_Index : Entity_Id;
13968 Conctyp : Entity_Id;
13970 Hi : Node_Id) return Boolean
13973 return Scope (Base_Index) = Standard_Standard
13974 and then Base_Index = Base_Type (Standard_Integer)
13975 and then Has_Defaulted_Discriminants (Conctyp)
13977 (Denotes_Discriminant (Lo, True)
13979 Denotes_Discriminant (Hi, True));
13980 end Is_Potentially_Large_Family;
13982 -------------------------------------
13983 -- Is_Private_Primitive_Subprogram --
13984 -------------------------------------
13986 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
13989 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
13990 and then Is_Private_Primitive (Id);
13991 end Is_Private_Primitive_Subprogram;
13997 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is
13998 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id);
13999 Formal : Entity_Id;
14002 Formal := First_Formal (Bod_Subp);
14003 while Present (Formal) loop
14005 -- Look for formal parameter _E
14007 if Chars (Formal) = Name_uE then
14011 Next_Formal (Formal);
14014 -- A protected body subprogram should always have the parameter in
14017 raise Program_Error;
14020 --------------------------------
14021 -- Make_Initialize_Protection --
14022 --------------------------------
14024 function Make_Initialize_Protection
14025 (Protect_Rec : Entity_Id) return List_Id
14027 Loc : constant Source_Ptr := Sloc (Protect_Rec);
14030 Ptyp : constant Node_Id :=
14031 Corresponding_Concurrent_Type (Protect_Rec);
14033 L : constant List_Id := New_List;
14034 Has_Entry : constant Boolean := Has_Entries (Ptyp);
14035 Prio_Type : Entity_Id;
14036 Prio_Var : Entity_Id := Empty;
14037 Restricted : constant Boolean := Restricted_Profile;
14040 -- We may need two calls to properly initialize the object, one to
14041 -- Initialize_Protection, and possibly one to Install_Handlers if we
14042 -- have a pragma Attach_Handler.
14044 -- Get protected declaration. In the case of a task type declaration,
14045 -- this is simply the parent of the protected type entity. In the single
14046 -- protected object declaration, this parent will be the implicit type,
14047 -- and we can find the corresponding single protected object declaration
14048 -- by searching forward in the declaration list in the tree.
14050 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
14051 -- of this type should have been removed during semantic analysis.
14053 Pdec := Parent (Ptyp);
14054 while Nkind (Pdec) not in
14055 N_Protected_Type_Declaration | N_Single_Protected_Declaration
14060 -- Build the parameter list for the call. Note that _Init is the name
14061 -- of the formal for the object to be initialized, which is the task
14062 -- value record itself.
14066 -- For lock-free implementation, skip initializations of the Protection
14069 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
14071 -- Object parameter. This is a pointer to the object of type
14072 -- Protection used by the GNARL to control the protected object.
14075 Make_Attribute_Reference (Loc,
14077 Make_Selected_Component (Loc,
14078 Prefix => Make_Identifier (Loc, Name_uInit),
14079 Selector_Name => Make_Identifier (Loc, Name_uObject)),
14080 Attribute_Name => Name_Unchecked_Access));
14082 -- Priority parameter. Set to Unspecified_Priority unless there is a
14083 -- Priority rep item, in which case we take the value from the pragma
14084 -- or attribute definition clause, or there is an Interrupt_Priority
14085 -- rep item and no Priority rep item, and we set the ceiling to
14086 -- Interrupt_Priority'Last, an implementation-defined value, see
14089 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then
14091 Prio_Clause : constant Node_Id :=
14093 (Ptyp, Name_Priority, Check_Parents => False);
14100 if Nkind (Prio_Clause) = N_Pragma then
14103 (First (Pragma_Argument_Associations (Prio_Clause)));
14105 -- Get_Rep_Item returns either priority pragma
14107 if Pragma_Name (Prio_Clause) = Name_Priority then
14108 Prio_Type := RTE (RE_Any_Priority);
14110 Prio_Type := RTE (RE_Interrupt_Priority);
14113 -- Attribute definition clause Priority
14116 if Chars (Prio_Clause) = Name_Priority then
14117 Prio_Type := RTE (RE_Any_Priority);
14119 Prio_Type := RTE (RE_Interrupt_Priority);
14122 Prio := Expression (Prio_Clause);
14125 -- Always create a locale variable to capture the priority.
14126 -- The priority is also passed to Install_Restriced_Handlers.
14127 -- Note that it is really necessary to create this variable
14128 -- explicitly. It might be thought that removing side effects
14129 -- would the appropriate approach, but that could generate
14130 -- declarations improperly placed in the enclosing scope.
14132 Prio_Var := Make_Temporary (Loc, 'R', Prio);
14134 Make_Object_Declaration (Loc,
14135 Defining_Identifier => Prio_Var,
14136 Object_Definition => New_Occurrence_Of (Prio_Type, Loc),
14137 Expression => Relocate_Node (Prio)));
14139 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
14142 -- When no priority is specified but an xx_Handler pragma is, we
14143 -- default to System.Interrupts.Default_Interrupt_Priority, see
14146 elsif Has_Attach_Handler (Ptyp)
14147 or else Has_Interrupt_Handler (Ptyp)
14150 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc));
14152 -- Normal case, no priority or xx_Handler specified, default priority
14156 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14159 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
14161 if Restricted_Profile and Task_Dispatching_Policy = 'E' then
14162 Deadline_Floor : declare
14163 Item : constant Node_Id :=
14165 (Ptyp, Name_Deadline_Floor, Check_Parents => False);
14167 Deadline : Node_Id;
14170 if Present (Item) then
14172 -- Pragma Deadline_Floor
14174 if Nkind (Item) = N_Pragma then
14177 (First (Pragma_Argument_Associations (Item)));
14179 -- Attribute definition clause Deadline_Floor
14183 (Nkind (Item) = N_Attribute_Definition_Clause);
14185 Deadline := Expression (Item);
14188 Append_To (Args, Deadline);
14190 -- Unusual case: default deadline
14194 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14196 end Deadline_Floor;
14199 -- Test for Compiler_Info parameter. This parameter allows entry body
14200 -- procedures and barrier functions to be called from the runtime. It
14201 -- is a pointer to the record generated by the compiler to represent
14202 -- the protected object.
14204 -- A protected type without entries that covers an interface and
14205 -- overrides the abstract routines with protected procedures is
14206 -- considered equivalent to a protected type with entries in the
14207 -- context of dispatching select statements.
14209 -- Protected types with interrupt handlers (when not using a
14210 -- restricted profile) are also considered equivalent to protected
14211 -- types with entries.
14213 -- The types which are used (Static_Interrupt_Protection and
14214 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14217 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
14219 Called_Subp : RE_Id;
14223 when System_Tasking_Protected_Objects_Entries =>
14224 Called_Subp := RE_Initialize_Protection_Entries;
14226 -- Argument Compiler_Info
14229 Make_Attribute_Reference (Loc,
14230 Prefix => Make_Identifier (Loc, Name_uInit),
14231 Attribute_Name => Name_Address));
14233 when System_Tasking_Protected_Objects_Single_Entry =>
14234 Called_Subp := RE_Initialize_Protection_Entry;
14236 -- Argument Compiler_Info
14239 Make_Attribute_Reference (Loc,
14240 Prefix => Make_Identifier (Loc, Name_uInit),
14241 Attribute_Name => Name_Address));
14243 when System_Tasking_Protected_Objects =>
14244 Called_Subp := RE_Initialize_Protection;
14247 raise Program_Error;
14250 -- Entry_Queue_Maxes parameter. This is an access to an array of
14251 -- naturals representing the entry queue maximums for each entry
14252 -- in the protected type. Zero represents no max. The access is
14253 -- null if there is no limit for all entries (usual case).
14256 and then Pkg_Id = System_Tasking_Protected_Objects_Entries
14258 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then
14260 Make_Attribute_Reference (Loc,
14263 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
14264 Attribute_Name => Name_Unrestricted_Access));
14266 Append_To (Args, Make_Null (Loc));
14269 -- Edge cases exist where entry initialization functions are
14270 -- called, but no entries exist, so null is appended.
14272 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
14273 Append_To (Args, Make_Null (Loc));
14276 -- Entry_Bodies parameter. This is a pointer to an array of
14277 -- pointers to the entry body procedures and barrier functions of
14278 -- the object. If the protected type has no entries this object
14279 -- will not exist, in this case, pass a null (it can happen when
14280 -- there are protected interrupt handlers or interfaces).
14283 P_Arr := Entry_Bodies_Array (Ptyp);
14285 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14286 -- multiple entries).
14289 Make_Attribute_Reference (Loc,
14290 Prefix => New_Occurrence_Of (P_Arr, Loc),
14291 Attribute_Name => Name_Unrestricted_Access));
14293 if Pkg_Id = System_Tasking_Protected_Objects_Entries then
14295 -- Find index mapping function (clumsy but ok for now)
14297 while Ekind (P_Arr) /= E_Function loop
14298 Next_Entity (P_Arr);
14302 Make_Attribute_Reference (Loc,
14303 Prefix => New_Occurrence_Of (P_Arr, Loc),
14304 Attribute_Name => Name_Unrestricted_Access));
14307 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
14309 -- This is the case where we have a protected object with
14310 -- interfaces and no entries, and the single entry restriction
14311 -- is in effect. We pass a null pointer for the entry
14312 -- parameter because there is no actual entry.
14314 Append_To (Args, Make_Null (Loc));
14316 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
14318 -- This is the case where we have a protected object with no
14320 -- - either interrupt handlers with non restricted profile,
14322 -- Note that the types which are used for interrupt handlers
14323 -- (Static/Dynamic_Interrupt_Protection) are derived from
14324 -- Protection_Entries. We pass two null pointers because there
14325 -- is no actual entry, and the initialization procedure needs
14326 -- both Entry_Bodies and Find_Body_Index.
14328 Append_To (Args, Make_Null (Loc));
14329 Append_To (Args, Make_Null (Loc));
14333 Make_Procedure_Call_Statement (Loc,
14335 New_Occurrence_Of (RTE (Called_Subp), Loc),
14336 Parameter_Associations => Args));
14340 if Has_Attach_Handler (Ptyp) then
14342 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14343 -- make the following call:
14345 -- Install_Handlers (_object,
14346 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14348 -- or, in the case of Ravenscar:
14350 -- Install_Restricted_Handlers
14351 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14354 Args : constant List_Id := New_List;
14355 Table : constant List_Id := New_List;
14356 Ritem : Node_Id := First_Rep_Item (Ptyp);
14359 -- Build the Priority parameter (only for ravenscar)
14363 -- Priority comes from a pragma
14365 if Present (Prio_Var) then
14366 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
14368 -- Priority is the default one
14373 (RTE (RE_Default_Interrupt_Priority), Loc));
14377 -- Build the Attach_Handler table argument
14379 while Present (Ritem) loop
14380 if Nkind (Ritem) = N_Pragma
14381 and then Pragma_Name (Ritem) = Name_Attach_Handler
14384 Handler : constant Node_Id :=
14385 First (Pragma_Argument_Associations (Ritem));
14387 Interrupt : constant Node_Id := Next (Handler);
14388 Expr : constant Node_Id := Expression (Interrupt);
14392 Make_Aggregate (Loc, Expressions => New_List (
14393 Unchecked_Convert_To
14394 (RTE (RE_System_Interrupt_Id), Expr),
14395 Make_Attribute_Reference (Loc,
14397 Make_Selected_Component (Loc,
14399 Make_Identifier (Loc, Name_uInit),
14401 Duplicate_Subexpr_No_Checks
14402 (Expression (Handler))),
14403 Attribute_Name => Name_Access))));
14407 Next_Rep_Item (Ritem);
14410 -- Append the table argument we just built
14412 Append_To (Args, Make_Aggregate (Loc, Table));
14414 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14415 -- call to the statements.
14418 -- Call a simplified version of Install_Handlers to be used
14419 -- when the Ravenscar restrictions are in effect
14420 -- (Install_Restricted_Handlers).
14423 Make_Procedure_Call_Statement (Loc,
14426 (RTE (RE_Install_Restricted_Handlers), Loc),
14427 Parameter_Associations => Args));
14430 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
14432 -- First, prepends the _object argument
14435 Make_Attribute_Reference (Loc,
14437 Make_Selected_Component (Loc,
14438 Prefix => Make_Identifier (Loc, Name_uInit),
14440 Make_Identifier (Loc, Name_uObject)),
14441 Attribute_Name => Name_Unchecked_Access));
14444 -- Then, insert call to Install_Handlers
14447 Make_Procedure_Call_Statement (Loc,
14449 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc),
14450 Parameter_Associations => Args));
14456 end Make_Initialize_Protection;
14458 ---------------------------
14459 -- Make_Task_Create_Call --
14460 ---------------------------
14462 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
14463 Loc : constant Source_Ptr := Sloc (Task_Rec);
14473 Ttyp := Corresponding_Concurrent_Type (Task_Rec);
14474 Tnam := Chars (Ttyp);
14476 -- Get task declaration. In the case of a task type declaration, this is
14477 -- simply the parent of the task type entity. In the single task
14478 -- declaration, this parent will be the implicit type, and we can find
14479 -- the corresponding single task declaration by searching forward in the
14480 -- declaration list in the tree.
14482 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14483 -- this type should have been removed during semantic analysis.
14485 Tdec := Parent (Ttyp);
14486 while Nkind (Tdec) not in
14487 N_Task_Type_Declaration | N_Single_Task_Declaration
14492 -- Now we can find the task definition from this declaration
14494 Tdef := Task_Definition (Tdec);
14496 -- Build the parameter list for the call. Note that _Init is the name
14497 -- of the formal for the object to be initialized, which is the task
14498 -- value record itself.
14502 -- Priority parameter. Set to Unspecified_Priority unless there is a
14503 -- Priority rep item, in which case we take the value from the rep item.
14504 -- Not used on Ravenscar_EDF profile.
14506 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then
14507 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
14509 Make_Selected_Component (Loc,
14510 Prefix => Make_Identifier (Loc, Name_uInit),
14511 Selector_Name => Make_Identifier (Loc, Name_uPriority)));
14514 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14518 -- Optional Stack parameter
14520 if Restricted_Profile then
14522 -- If the stack has been preallocated by the expander then
14523 -- pass its address. Otherwise, pass a null address.
14525 if Preallocated_Stacks_On_Target then
14527 Make_Attribute_Reference (Loc,
14529 Make_Selected_Component (Loc,
14530 Prefix => Make_Identifier (Loc, Name_uInit),
14531 Selector_Name => Make_Identifier (Loc, Name_uStack)),
14532 Attribute_Name => Name_Address));
14536 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
14540 -- Size parameter. If no Storage_Size pragma is present, then
14541 -- the size is taken from the taskZ variable for the type, which
14542 -- is either Unspecified_Size, or has been reset by the use of
14543 -- a Storage_Size attribute definition clause. If a pragma is
14544 -- present, then the size is taken from the _Size field of the
14545 -- task value record, which was set from the pragma value.
14547 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then
14549 Make_Selected_Component (Loc,
14550 Prefix => Make_Identifier (Loc, Name_uInit),
14551 Selector_Name => Make_Identifier (Loc, Name_uSize)));
14555 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc));
14558 -- Secondary_Stack parameter used for restricted profiles
14560 if Restricted_Profile then
14562 -- If the secondary stack has been allocated by the expander then
14563 -- pass its access pointer. Otherwise, pass null.
14565 if Create_Secondary_Stack_For_Task (Ttyp) then
14567 Make_Attribute_Reference (Loc,
14569 Make_Selected_Component (Loc,
14570 Prefix => Make_Identifier (Loc, Name_uInit),
14572 Make_Identifier (Loc, Name_uSecondary_Stack)),
14573 Attribute_Name => Name_Unrestricted_Access));
14576 Append_To (Args, Make_Null (Loc));
14580 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
14581 -- is a Secondary_Stack_Size pragma, in which case take the value from
14582 -- the pragma. If the restriction No_Secondary_Stack is active then a
14583 -- size of 0 is passed regardless to prevent the allocation of the
14586 if Restriction_Active (No_Secondary_Stack) then
14587 Append_To (Args, Make_Integer_Literal (Loc, 0));
14589 elsif Has_Rep_Pragma
14590 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False)
14593 Make_Selected_Component (Loc,
14594 Prefix => Make_Identifier (Loc, Name_uInit),
14596 Make_Identifier (Loc, Name_uSecondary_Stack_Size)));
14600 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
14603 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14604 -- Task_Info pragma, in which case we take the value from the pragma.
14606 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then
14608 Make_Selected_Component (Loc,
14609 Prefix => Make_Identifier (Loc, Name_uInit),
14610 Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
14614 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc));
14617 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14618 -- in which case we take the value from the rep item. The parameter is
14619 -- passed as an Integer because in the case of unspecified CPU the
14620 -- value is not in the range of CPU_Range.
14622 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then
14624 Convert_To (Standard_Integer,
14625 Make_Selected_Component (Loc,
14626 Prefix => Make_Identifier (Loc, Name_uInit),
14627 Selector_Name => Make_Identifier (Loc, Name_uCPU))));
14630 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc));
14633 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then
14635 -- Deadline parameter. If no Relative_Deadline pragma is present,
14636 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14637 -- the deadline is taken from the _Relative_Deadline field of the
14638 -- task value record, which was set from the pragma value. Note that
14639 -- this parameter must not be generated for the restricted profiles
14640 -- since Ravenscar does not allow deadlines.
14642 -- Case where pragma Relative_Deadline applies: use given value
14644 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
14646 Make_Selected_Component (Loc,
14647 Prefix => Make_Identifier (Loc, Name_uInit),
14649 Make_Identifier (Loc, Name_uRelative_Deadline)));
14651 -- No pragma Relative_Deadline apply to the task
14655 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14659 if not Restricted_Profile then
14661 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14662 -- present, then the dispatching domain is null. If a rep item is
14663 -- present, then the dispatching domain is taken from the
14664 -- _Dispatching_Domain field of the task value record, which was set
14665 -- from the rep item value.
14667 -- Case where Dispatching_Domain rep item applies: use given value
14670 (Ttyp, Name_Dispatching_Domain, Check_Parents => False)
14673 Make_Selected_Component (Loc,
14675 Make_Identifier (Loc, Name_uInit),
14677 Make_Identifier (Loc, Name_uDispatching_Domain)));
14679 -- No pragma or aspect Dispatching_Domain applies to the task
14682 Append_To (Args, Make_Null (Loc));
14685 -- Number of entries. This is an expression of the form:
14687 -- n + _Init.a'Length + _Init.a'B'Length + ...
14689 -- where a,b... are the entry family names for the task definition
14692 Build_Entry_Count_Expression
14697 (Parent (Corresponding_Record_Type (Ttyp))))),
14699 Append_To (Args, Ecount);
14701 -- Master parameter. This is a reference to the _Master parameter of
14702 -- the initialization procedure, except in the case of the pragma
14703 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14704 -- System.Tasking.Library_Task_Level.
14706 if Restriction_Active (No_Task_Hierarchy) = False then
14707 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
14710 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
14714 -- State parameter. This is a pointer to the task body procedure. The
14715 -- required value is obtained by taking 'Unrestricted_Access of the task
14716 -- body procedure and converting it (with an unchecked conversion) to
14717 -- the type required by the task kernel. For further details, see the
14718 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14719 -- than 'Address in order to avoid creating trampolines.
14722 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp);
14723 Subp_Ptr_Typ : constant Node_Id :=
14724 Create_Itype (E_Access_Subprogram_Type, Tdec);
14725 Ref : constant Node_Id := Make_Itype_Reference (Loc);
14728 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc);
14729 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
14731 -- Be sure to freeze a reference to the access-to-subprogram type,
14732 -- otherwise gigi will complain that it's in the wrong scope, because
14733 -- it's actually inside the init procedure for the record type that
14734 -- corresponds to the task type.
14736 Set_Itype (Ref, Subp_Ptr_Typ);
14737 Append_Freeze_Action (Task_Rec, Ref);
14740 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
14741 Make_Qualified_Expression (Loc,
14742 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc),
14744 Make_Attribute_Reference (Loc,
14745 Prefix => New_Occurrence_Of (Body_Proc, Loc),
14746 Attribute_Name => Name_Unrestricted_Access))));
14749 -- Discriminants parameter. This is just the address of the task
14750 -- value record itself (which contains the discriminant values
14753 Make_Attribute_Reference (Loc,
14754 Prefix => Make_Identifier (Loc, Name_uInit),
14755 Attribute_Name => Name_Address));
14757 -- Elaborated parameter. This is an access to the elaboration Boolean
14760 Make_Attribute_Reference (Loc,
14761 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
14762 Attribute_Name => Name_Unchecked_Access));
14764 -- Add Chain parameter (not done for sequential elaboration policy, see
14765 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14767 if Partition_Elaboration_Policy /= 'S' then
14768 Append_To (Args, Make_Identifier (Loc, Name_uChain));
14771 -- Task name parameter. Take this from the _Task_Id parameter to the
14772 -- init call unless there is a Task_Name pragma, in which case we take
14773 -- the value from the pragma.
14775 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then
14776 -- Copy expression in full, because it may be dynamic and have
14783 (Pragma_Argument_Associations
14785 (Ttyp, Name_Task_Name, Check_Parents => False))))));
14788 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
14791 -- Created_Task parameter. This is the _Task_Id field of the task
14795 Make_Selected_Component (Loc,
14796 Prefix => Make_Identifier (Loc, Name_uInit),
14797 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
14803 if Restricted_Profile then
14804 if Partition_Elaboration_Policy = 'S' then
14805 Create_RE := RE_Create_Restricted_Task_Sequential;
14807 Create_RE := RE_Create_Restricted_Task;
14810 Create_RE := RE_Create_Task;
14813 Name := New_Occurrence_Of (RTE (Create_RE), Loc);
14817 Make_Procedure_Call_Statement (Loc,
14819 Parameter_Associations => Args);
14820 end Make_Task_Create_Call;
14822 ------------------------------
14823 -- Next_Protected_Operation --
14824 ------------------------------
14826 function Next_Protected_Operation (N : Node_Id) return Node_Id is
14830 -- Check whether there is a subsequent body for a protected operation
14831 -- in the current protected body. In Ada2012 that includes expression
14832 -- functions that are completions.
14834 Next_Op := Next (N);
14835 while Present (Next_Op)
14836 and then Nkind (Next_Op) not in
14837 N_Subprogram_Body | N_Entry_Body | N_Expression_Function
14843 end Next_Protected_Operation;
14845 ---------------------
14846 -- Null_Statements --
14847 ---------------------
14849 function Null_Statements (Stats : List_Id) return Boolean is
14853 Stmt := First (Stats);
14854 while Nkind (Stmt) /= N_Empty
14855 and then (Nkind (Stmt) in N_Null_Statement | N_Label
14857 (Nkind (Stmt) = N_Pragma
14859 Pragma_Name_Unmapped (Stmt) in Name_Unreferenced
14866 return Nkind (Stmt) = N_Empty;
14867 end Null_Statements;
14869 --------------------------
14870 -- Parameter_Block_Pack --
14871 --------------------------
14873 function Parameter_Block_Pack
14875 Blk_Typ : Entity_Id;
14879 Stmts : List_Id) return Node_Id
14881 Actual : Entity_Id;
14882 Expr : Node_Id := Empty;
14883 Formal : Entity_Id;
14884 Has_Param : Boolean := False;
14887 Temp_Asn : Node_Id;
14888 Temp_Nam : Node_Id;
14891 Actual := First (Actuals);
14892 Formal := Defining_Identifier (First (Formals));
14893 Params := New_List;
14894 while Present (Actual) loop
14895 if Is_By_Copy_Type (Etype (Actual)) then
14897 -- Jnn : aliased <formal-type>
14899 Temp_Nam := Make_Temporary (Loc, 'J');
14902 Make_Object_Declaration (Loc,
14903 Aliased_Present => True,
14904 Defining_Identifier => Temp_Nam,
14905 Object_Definition =>
14906 New_Occurrence_Of (Etype (Formal), Loc)));
14908 -- The object is initialized with an explicit assignment
14909 -- later. Indicate that it does not need an initialization
14910 -- to prevent spurious warnings if the type excludes null.
14912 Set_No_Initialization (Last (Decls));
14914 if Ekind (Formal) /= E_Out_Parameter then
14920 New_Occurrence_Of (Temp_Nam, Loc);
14922 Set_Assignment_OK (Temp_Asn);
14925 Make_Assignment_Statement (Loc,
14927 Expression => New_Copy_Tree (Actual)));
14930 -- If the actual is not controlling, generate:
14932 -- Jnn'unchecked_access
14934 -- and add it to aggegate for access to formals. Note that the
14935 -- actual may be by-copy but still be a controlling actual if it
14936 -- is an access to class-wide interface.
14938 if not Is_Controlling_Actual (Actual) then
14940 Make_Attribute_Reference (Loc,
14941 Attribute_Name => Name_Unchecked_Access,
14942 Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
14947 -- The controlling parameter is omitted
14950 if not Is_Controlling_Actual (Actual) then
14952 Make_Reference (Loc, New_Copy_Tree (Actual)));
14958 Next_Actual (Actual);
14959 Next_Formal_With_Extras (Formal);
14963 Expr := Make_Aggregate (Loc, Params);
14968 -- J1'unchecked_access;
14969 -- <actual2>'reference;
14972 P := Make_Temporary (Loc, 'P');
14975 Make_Object_Declaration (Loc,
14976 Defining_Identifier => P,
14977 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc),
14978 Expression => Expr));
14981 end Parameter_Block_Pack;
14983 ----------------------------
14984 -- Parameter_Block_Unpack --
14985 ----------------------------
14987 function Parameter_Block_Unpack
14991 Formals : List_Id) return List_Id
14993 Actual : Entity_Id;
14995 Formal : Entity_Id;
14996 Has_Asnmt : Boolean := False;
14997 Result : constant List_Id := New_List;
15000 Actual := First (Actuals);
15001 Formal := Defining_Identifier (First (Formals));
15002 while Present (Actual) loop
15003 if Is_By_Copy_Type (Etype (Actual))
15004 and then Ekind (Formal) /= E_In_Parameter
15007 -- <actual> := P.<formal>;
15010 Make_Assignment_Statement (Loc,
15014 Make_Explicit_Dereference (Loc,
15015 Make_Selected_Component (Loc,
15017 New_Occurrence_Of (P, Loc),
15019 Make_Identifier (Loc, Chars (Formal)))));
15021 Set_Assignment_OK (Name (Asnmt));
15022 Append_To (Result, Asnmt);
15027 Next_Actual (Actual);
15028 Next_Formal_With_Extras (Formal);
15034 return New_List (Make_Null_Statement (Loc));
15036 end Parameter_Block_Unpack;
15038 ---------------------
15039 -- Reset_Scopes_To --
15040 ---------------------
15042 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is
15043 function Reset_Scope (N : Node_Id) return Traverse_Result;
15044 -- Temporaries may have been declared during expansion of the procedure
15045 -- created for an entry body or an accept alternative. Indicate that
15046 -- their scope is the new body, to ensure proper generation of uplevel
15047 -- references where needed during unnesting.
15049 procedure Reset_Scopes is new Traverse_Proc (Reset_Scope);
15055 function Reset_Scope (N : Node_Id) return Traverse_Result is
15059 -- If this is a block statement with an Identifier, it forms a scope,
15060 -- so we want to reset its scope but not look inside.
15063 and then Nkind (N) = N_Block_Statement
15064 and then Present (Identifier (N))
15066 Set_Scope (Entity (Identifier (N)), E);
15069 -- Ditto for a package declaration or a full type declaration, etc.
15071 elsif (Nkind (N) = N_Package_Declaration
15072 and then N /= Specification (N))
15073 or else Nkind (N) in N_Declaration
15074 or else Nkind (N) in N_Renaming_Declaration
15076 Set_Scope (Defining_Entity (N), E);
15081 -- Scan declarations in new body. Declarations in the statement
15082 -- part will be handled during later traversal.
15084 Decl := First (Declarations (N));
15085 while Present (Decl) loop
15086 Reset_Scopes (Decl);
15090 elsif Nkind (N) = N_Freeze_Entity then
15092 -- Scan the actions associated with a freeze node, which may
15093 -- actually be declarations with entities that need to have
15094 -- their scopes reset.
15096 Decl := First (Actions (N));
15097 while Present (Decl) loop
15098 Reset_Scopes (Decl);
15102 elsif N /= Bod and then Nkind (N) in N_Proper_Body then
15104 -- A subprogram without a separate declaration may be encountered,
15105 -- and we need to reset the subprogram's entity's scope.
15107 if Nkind (N) = N_Subprogram_Body then
15108 Set_Scope (Defining_Entity (Specification (N)), E);
15117 -- Start of processing for Reset_Scopes_To
15120 Reset_Scopes (Bod);
15121 end Reset_Scopes_To;
15123 ----------------------
15124 -- Set_Discriminals --
15125 ----------------------
15127 procedure Set_Discriminals (Dec : Node_Id) is
15130 D_Minal : Entity_Id;
15133 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
15134 Pdef := Defining_Identifier (Dec);
15136 if Has_Discriminants (Pdef) then
15137 D := First_Discriminant (Pdef);
15138 while Present (D) loop
15140 Make_Defining_Identifier (Sloc (D),
15141 Chars => New_External_Name (Chars (D), 'D'));
15143 Set_Ekind (D_Minal, E_Constant);
15144 Set_Etype (D_Minal, Etype (D));
15145 Set_Scope (D_Minal, Pdef);
15146 Set_Discriminal (D, D_Minal);
15147 Set_Discriminal_Link (D_Minal, D);
15149 Next_Discriminant (D);
15152 end Set_Discriminals;
15154 -----------------------
15155 -- Trivial_Accept_OK --
15156 -----------------------
15158 function Trivial_Accept_OK return Boolean is
15160 case Opt.Task_Dispatching_Policy is
15162 -- If we have the default task dispatching policy in effect, we can
15163 -- definitely do the optimization (one way of looking at this is to
15164 -- think of the formal definition of the default policy being allowed
15165 -- to run any task it likes after a rendezvous, so even if notionally
15166 -- a full rescheduling occurs, we can say that our dispatching policy
15167 -- (i.e. the default dispatching policy) reorders the queue to be the
15168 -- same as just before the call.
15173 -- FIFO_Within_Priorities certainly does not permit this
15174 -- optimization since the Rendezvous is a scheduling action that may
15175 -- require some other task to be run.
15180 -- For now, disallow the optimization for all other policies. This
15181 -- may be over-conservative, but it is certainly not incorrect.
15186 end Trivial_Accept_OK;