1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Exp_Ch3; use Exp_Ch3;
32 with Exp_Ch6; use Exp_Ch6;
33 with Exp_Ch11; use Exp_Ch11;
34 with Exp_Dbug; use Exp_Dbug;
35 with Exp_Disp; use Exp_Disp;
36 with Exp_Sel; use Exp_Sel;
37 with Exp_Smem; use Exp_Smem;
38 with Exp_Tss; use Exp_Tss;
39 with Exp_Util; use Exp_Util;
40 with Freeze; use Freeze;
42 with Itypes; use Itypes;
43 with Namet; use Namet;
44 with Nlists; use Nlists;
45 with Nmake; use Nmake;
47 with Restrict; use Restrict;
48 with Rident; use Rident;
49 with Rtsfind; use Rtsfind;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Ch6; use Sem_Ch6;
53 with Sem_Ch8; use Sem_Ch8;
54 with Sem_Ch11; use Sem_Ch11;
55 with Sem_Elab; use Sem_Elab;
56 with Sem_Eval; use Sem_Eval;
57 with Sem_Res; use Sem_Res;
58 with Sem_Util; use Sem_Util;
59 with Sinfo; use Sinfo;
60 with Snames; use Snames;
61 with Stand; use Stand;
62 with Stringt; use Stringt;
63 with Targparm; use Targparm;
64 with Tbuild; use Tbuild;
65 with Uintp; use Uintp;
67 package body Exp_Ch9 is
69 -- The following constant establishes the upper bound for the index of
70 -- an entry family. It is used to limit the allocated size of protected
71 -- types with defaulted discriminant of an integer type, when the bound
72 -- of some entry family depends on a discriminant. The limitation to
73 -- entry families of 128K should be reasonable in all cases, and is a
74 -- documented implementation restriction. It will be lifted when protected
75 -- entry families are re-implemented as a single ordered queue.
77 Entry_Family_Bound : constant Int := 2**16;
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Actual_Index_Expression
87 Tsk : Entity_Id) return Node_Id;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
92 procedure Add_Object_Pointer
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
101 procedure Add_Formal_Renamings
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
113 function Build_Accept_Body (Astat : Node_Id) return Node_Id;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
118 function Build_Barrier_Function
121 Pid : Node_Id) return Node_Id;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
125 function Build_Barrier_Function_Specification
127 Def_Id : Entity_Id) return Node_Id;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
131 function Build_Corresponding_Record
134 Loc : Source_Ptr) return Node_Id;
135 -- Common to tasks and protected types. Copy discriminant specifications,
136 -- build record declaration. N is the type declaration, Ctyp is the
137 -- concurrent entity (task type or protected type).
139 function Build_Entry_Count_Expression
140 (Concurrent_Type : Node_Id;
141 Component_List : List_Id;
142 Loc : Source_Ptr) return Node_Id;
143 -- Compute number of entries for concurrent object. This is a count of
144 -- simple entries, followed by an expression that computes the length
145 -- of the range of each entry family. A single array with that size is
146 -- allocated for each concurrent object of the type.
148 function Build_Parameter_Block
152 Decls : List_Id) return Entity_Id;
153 -- Generate an access type for each actual parameter in the list Actuals.
154 -- Create an encapsulating record that contains all the actuals and return
155 -- its type. Generate:
156 -- type Ann1 is access all <actual1-type>
158 -- type AnnN is access all <actualN-type>
159 -- type Pnn is record
165 procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id);
166 -- Build body of wrapper procedure for an entry or entry family that has
167 -- pre/postconditions. The body gathers the PPC's and expands them in the
168 -- usual way, and performs the entry call itself. This way preconditions
169 -- are evaluated before the call is queued. E is the entry in question,
170 -- and Decl is the enclosing synchronized type declaration at whose
171 -- freeze point the generated body is analyzed.
173 function Build_Renamed_Formal_Declaration
177 Renamed_Formal : Node_Id) return Node_Id;
178 -- Create a renaming declaration for a formal, within a protected entry
179 -- body or an accept body. The renamed object is a component of the
180 -- parameter block that is a parameter in the entry call.
182 -- In Ada2012, If the formal is an incomplete tagged type, the renaming
183 -- does not dereference the corresponding component to prevent an illegal
184 -- use of the incomplete type (AI05-0151).
186 procedure Build_Wrapper_Bodies
190 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
191 -- record of a concurrent type. N is the insertion node where all bodies
192 -- will be placed. This routine builds the bodies of the subprograms which
193 -- serve as an indirection mechanism to overriding primitives of concurrent
194 -- types, entries and protected procedures. Any new body is analyzed.
196 procedure Build_Wrapper_Specs
200 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
201 -- record of a concurrent type. N is the insertion node where all specs
202 -- will be placed. This routine builds the specs of the subprograms which
203 -- serve as an indirection mechanism to overriding primitives of concurrent
204 -- types, entries and protected procedures. Any new spec is analyzed.
206 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
207 -- Build the function that translates the entry index in the call
208 -- (which depends on the size of entry families) into an index into the
209 -- Entry_Bodies_Array, to determine the body and barrier function used
210 -- in a protected entry call. A pointer to this function appears in every
213 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
214 -- Build subprogram declaration for previous one
216 function Build_Protected_Entry
219 Pid : Node_Id) return Node_Id;
220 -- Build the procedure implementing the statement sequence of the specified
223 function Build_Protected_Entry_Specification
226 Ent_Id : Entity_Id) return Node_Id;
227 -- Build a specification for the procedure implementing the statements of
228 -- the specified entry body. Add attributes associating it with the entry
229 -- defining identifier Ent_Id.
231 function Build_Protected_Spec
233 Obj_Type : Entity_Id;
235 Unprotected : Boolean := False) return List_Id;
236 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
237 -- Subprogram_Type. Builds signature of protected subprogram, adding the
238 -- formal that corresponds to the object itself. For an access to protected
239 -- subprogram, there is no object type to specify, so the parameter has
240 -- type Address and mode In. An indirect call through such a pointer will
241 -- convert the address to a reference to the actual object. The object is
242 -- a limited record and therefore a by_reference type.
244 function Build_Protected_Subprogram_Body
247 N_Op_Spec : Node_Id) return Node_Id;
248 -- This function is used to construct the protected version of a protected
249 -- subprogram. Its statement sequence first defers abort, then locks
250 -- the associated protected object, and then enters a block that contains
251 -- a call to the unprotected version of the subprogram (for details, see
252 -- Build_Unprotected_Subprogram_Body). This block statement requires
253 -- a cleanup handler that unlocks the object in all cases.
254 -- (see Exp_Ch7.Expand_Cleanup_Actions).
256 function Build_Selected_Name
258 Selector : Entity_Id;
259 Append_Char : Character := ' ') return Name_Id;
260 -- Build a name in the form of Prefix__Selector, with an optional
261 -- character appended. This is used for internal subprograms generated
262 -- for operations of protected types, including barrier functions.
263 -- For the subprograms generated for entry bodies and entry barriers,
264 -- the generated name includes a sequence number that makes names
265 -- unique in the presence of entry overloading. This is necessary
266 -- because entry body procedures and barrier functions all have the
269 procedure Build_Simple_Entry_Call
274 -- Some comments here would be useful ???
276 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
277 -- This routine constructs a specification for the procedure that we will
278 -- build for the task body for task type T. The spec has the form:
280 -- procedure tnameB (_Task : access tnameV);
282 -- where name is the character name taken from the task type entity that
283 -- is passed as the argument to the procedure, and tnameV is the task
284 -- value type that is associated with the task type.
286 function Build_Unprotected_Subprogram_Body
288 Pid : Node_Id) return Node_Id;
289 -- This routine constructs the unprotected version of a protected
290 -- subprogram body, which is contains all of the code in the
291 -- original, unexpanded body. This is the version of the protected
292 -- subprogram that is called from all protected operations on the same
293 -- object, including the protected version of the same subprogram.
295 procedure Collect_Entry_Families
298 Current_Node : in out Node_Id;
299 Conctyp : Entity_Id);
300 -- For each entry family in a concurrent type, create an anonymous array
301 -- type of the right size, and add a component to the corresponding_record.
303 function Concurrent_Object
304 (Spec_Id : Entity_Id;
305 Conc_Typ : Entity_Id) return Entity_Id;
306 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
307 -- the entity associated with the concurrent object in the Protected_Body_
308 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
309 -- denotes formal parameter _O, _object or _task.
311 function Copy_Result_Type (Res : Node_Id) return Node_Id;
312 -- Copy the result type of a function specification, when building the
313 -- internal operation corresponding to a protected function, or when
314 -- expanding an access to protected function. If the result is an anonymous
315 -- access to subprogram itself, we need to create a new signature with the
316 -- same parameter names and the same resolved types, but with new entities
319 procedure Debug_Private_Data_Declarations (Decls : List_Id);
320 -- Decls is a list which may contain the declarations created by Install_
321 -- Private_Data_Declarations. All generated entities are marked as needing
322 -- debug info and debug nodes are manually generation where necessary. This
323 -- step of the expansion must to be done after private data has been moved
324 -- to its final resting scope to ensure proper visibility of debug objects.
326 function Family_Offset
331 Cap : Boolean) return Node_Id;
332 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in
333 -- an accept statement, or the upper bound in the discrete subtype of
334 -- an entry declaration. Lo is the corresponding lower bound. Ttyp is
335 -- the concurrent type of the entry. If Cap is true, the result is
336 -- capped according to Entry_Family_Bound.
343 Cap : Boolean) return Node_Id;
344 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
345 -- a family, and handle properly the superflat case. This is equivalent
346 -- to the use of 'Length on the index type, but must use Family_Offset
347 -- to handle properly the case of bounds that depend on discriminants.
348 -- If Cap is true, the result is capped according to Entry_Family_Bound.
350 procedure Extract_Dispatching_Call
352 Call_Ent : out Entity_Id;
353 Object : out Entity_Id;
354 Actuals : out List_Id;
355 Formals : out List_Id);
356 -- Given a dispatching call, extract the entity of the name of the call,
357 -- its actual dispatching object, its actual parameters and the formal
358 -- parameters of the overridden interface-level version. If the type of
359 -- the dispatching object is an access type then an explicit dereference
360 -- is returned in Object.
362 procedure Extract_Entry
364 Concval : out Node_Id;
366 Index : out Node_Id);
367 -- Given an entry call, returns the associated concurrent object,
368 -- the entry name, and the entry family index.
370 function Find_Task_Or_Protected_Pragma
372 P : Name_Id) return Node_Id;
373 -- Searches the task or protected definition T for the first occurrence
374 -- of the pragma whose name is given by P. The caller has ensured that
375 -- the pragma is present in the task definition. A special case is that
376 -- when P is Name_uPriority, the call will also find Interrupt_Priority.
377 -- ??? Should be implemented with the rep item chain mechanism.
379 function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
380 -- Given a subprogram identifier, return the entity which is associated
381 -- with the protection entry index in the Protected_Body_Subprogram or the
382 -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal
385 function Is_Potentially_Large_Family
386 (Base_Index : Entity_Id;
389 Hi : Node_Id) return Boolean;
391 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
392 -- Determine whether Id is a function or a procedure and is marked as a
393 -- private primitive.
395 function Null_Statements (Stats : List_Id) return Boolean;
396 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
397 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as
398 -- well to still count as null. Returns True for a null sequence. The
399 -- argument is the list of statements from the DO-END sequence.
401 function Parameter_Block_Pack
407 Stmts : List_Id) return Entity_Id;
408 -- Set the components of the generated parameter block with the values of
409 -- the actual parameters. Generate aliased temporaries to capture the
410 -- values for types that are passed by copy. Otherwise generate a reference
411 -- to the actual's value. Return the address of the aggregate block.
413 -- Jnn1 : alias <formal-type1>;
414 -- Jnn1 := <actual1>;
417 -- Jnn1'unchecked_access;
418 -- <actual2>'reference;
421 function Parameter_Block_Unpack
425 Formals : List_Id) return List_Id;
426 -- Retrieve the values of the components from the parameter block and
427 -- assign then to the original actual parameters. Generate:
428 -- <actual1> := P.<formal1>;
430 -- <actualN> := P.<formalN>;
432 function Trivial_Accept_OK return Boolean;
433 -- If there is no DO-END block for an accept, or if the DO-END block has
434 -- only null statements, then it is possible to do the Rendezvous with much
435 -- less overhead using the Accept_Trivial routine in the run-time library.
436 -- However, this is not always a valid optimization. Whether it is valid or
437 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
438 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
439 -- a rescheduling is required, so this optimization is not allowed. This
440 -- function returns True if the optimization is permitted.
442 -----------------------------
443 -- Actual_Index_Expression --
444 -----------------------------
446 function Actual_Index_Expression
450 Tsk : Entity_Id) return Node_Id
452 Ttyp : constant Entity_Id := Etype (Tsk);
460 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
461 -- Compute difference between bounds of entry family
463 --------------------------
464 -- Actual_Family_Offset --
465 --------------------------
467 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
469 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
470 -- Replace a reference to a discriminant with a selected component
471 -- denoting the discriminant of the target task.
473 -----------------------------
474 -- Actual_Discriminant_Ref --
475 -----------------------------
477 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
478 Typ : constant Entity_Id := Etype (Bound);
482 if not Is_Entity_Name (Bound)
483 or else Ekind (Entity (Bound)) /= E_Discriminant
485 if Nkind (Bound) = N_Attribute_Reference then
488 B := New_Copy_Tree (Bound);
493 Make_Selected_Component (Sloc,
494 Prefix => New_Copy_Tree (Tsk),
495 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
497 Analyze_And_Resolve (B, Typ);
501 Make_Attribute_Reference (Sloc,
502 Attribute_Name => Name_Pos,
503 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
504 Expressions => New_List (B));
505 end Actual_Discriminant_Ref;
507 -- Start of processing for Actual_Family_Offset
511 Make_Op_Subtract (Sloc,
512 Left_Opnd => Actual_Discriminant_Ref (Hi),
513 Right_Opnd => Actual_Discriminant_Ref (Lo));
514 end Actual_Family_Offset;
516 -- Start of processing for Actual_Index_Expression
519 -- The queues of entries and entry families appear in textual order in
520 -- the associated record. The entry index is computed as the sum of the
521 -- number of queues for all entries that precede the designated one, to
522 -- which is added the index expression, if this expression denotes a
523 -- member of a family.
525 -- The following is a place holder for the count of simple entries
527 Num := Make_Integer_Literal (Sloc, 1);
529 -- We construct an expression which is a series of addition operations.
530 -- See comments in Entry_Index_Expression, which is identical in
533 if Present (Index) then
534 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
541 Actual_Family_Offset (
542 Make_Attribute_Reference (Sloc,
543 Attribute_Name => Name_Pos,
544 Prefix => New_Reference_To (Base_Type (S), Sloc),
545 Expressions => New_List (Relocate_Node (Index))),
546 Type_Low_Bound (S)));
551 -- Now add lengths of preceding entries and entry families
553 Prev := First_Entity (Ttyp);
555 while Chars (Prev) /= Chars (Ent)
556 or else (Ekind (Prev) /= Ekind (Ent))
557 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
559 if Ekind (Prev) = E_Entry then
560 Set_Intval (Num, Intval (Num) + 1);
562 elsif Ekind (Prev) = E_Entry_Family then
564 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
566 -- The need for the following full view retrieval stems from
567 -- this complex case of nested generics and tasking:
570 -- type Formal_Index is range <>;
573 -- type Index is private;
580 -- type Index is new Formal_Index range 1 .. 10;
583 -- package body Outer is
585 -- entry Fam (Index); -- (2)
588 -- package body Inner is -- (3)
596 -- We are currently building the index expression for the entry
597 -- call "T.E" (1). Part of the expansion must mention the range
598 -- of the discrete type "Index" (2) of entry family "Fam".
599 -- However only the private view of type "Index" is available to
600 -- the inner generic (3) because there was no prior mention of
601 -- the type inside "Inner". This visibility requirement is
602 -- implicit and cannot be detected during the construction of
603 -- the generic trees and needs special handling.
606 and then Is_Private_Type (S)
607 and then Present (Full_View (S))
612 Lo := Type_Low_Bound (S);
613 Hi := Type_High_Bound (S);
621 Actual_Family_Offset (Hi, Lo),
623 Make_Integer_Literal (Sloc, 1)));
625 -- Other components are anonymous types to be ignored
635 end Actual_Index_Expression;
637 --------------------------
638 -- Add_Formal_Renamings --
639 --------------------------
641 procedure Add_Formal_Renamings
647 Ptr : constant Entity_Id :=
649 (Next (First (Parameter_Specifications (Spec))));
650 -- The name of the formal that holds the address of the parameter block
657 Renamed_Formal : Node_Id;
660 Formal := First_Formal (Ent);
661 while Present (Formal) loop
662 Comp := Entry_Component (Formal);
664 Make_Defining_Identifier (Sloc (Formal),
665 Chars => Chars (Formal));
666 Set_Etype (New_F, Etype (Formal));
667 Set_Scope (New_F, Ent);
669 -- Now we set debug info needed on New_F even though it does not
670 -- come from source, so that the debugger will get the right
671 -- information for these generated names.
673 Set_Debug_Info_Needed (New_F);
675 if Ekind (Formal) = E_In_Parameter then
676 Set_Ekind (New_F, E_Constant);
678 Set_Ekind (New_F, E_Variable);
679 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
682 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
685 Make_Selected_Component (Loc,
687 Unchecked_Convert_To (Entry_Parameters_Type (Ent),
688 Make_Identifier (Loc, Chars (Ptr))),
689 Selector_Name => New_Reference_To (Comp, Loc));
692 Build_Renamed_Formal_Declaration
693 (New_F, Formal, Comp, Renamed_Formal);
695 Append (Decl, Decls);
696 Set_Renamed_Object (Formal, New_F);
697 Next_Formal (Formal);
699 end Add_Formal_Renamings;
701 ------------------------
702 -- Add_Object_Pointer --
703 ------------------------
705 procedure Add_Object_Pointer
707 Conc_Typ : Entity_Id;
710 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ);
715 -- Create the renaming declaration for the Protection object of a
716 -- protected type. _Object is used by Complete_Entry_Body.
717 -- ??? An attempt to make this a renaming was unsuccessful.
719 -- Build the entity for the access type
722 Make_Defining_Identifier (Loc,
723 New_External_Name (Chars (Rec_Typ), 'P'));
726 -- _object : poVP := poVP!O;
729 Make_Object_Declaration (Loc,
730 Defining_Identifier =>
731 Make_Defining_Identifier (Loc, Name_uObject),
733 New_Reference_To (Obj_Ptr, Loc),
735 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO)));
736 Set_Debug_Info_Needed (Defining_Identifier (Decl));
737 Prepend_To (Decls, Decl);
740 -- type poVP is access poV;
743 Make_Full_Type_Declaration (Loc,
744 Defining_Identifier =>
747 Make_Access_To_Object_Definition (Loc,
748 Subtype_Indication =>
749 New_Reference_To (Rec_Typ, Loc)));
750 Set_Debug_Info_Needed (Defining_Identifier (Decl));
751 Prepend_To (Decls, Decl);
752 end Add_Object_Pointer;
754 -----------------------
755 -- Build_Accept_Body --
756 -----------------------
758 function Build_Accept_Body (Astat : Node_Id) return Node_Id is
759 Loc : constant Source_Ptr := Sloc (Astat);
760 Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
767 -- At the end of the statement sequence, Complete_Rendezvous is called.
768 -- A label skipping the Complete_Rendezvous, and all other accept
769 -- processing, has already been added for the expansion of requeue
770 -- statements. The Sloc is copied from the last statement since it
771 -- is really part of this last statement.
775 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
776 Insert_Before (Last (Statements (Stats)), Call);
779 -- If exception handlers are present, then append Complete_Rendezvous
780 -- calls to the handlers, and construct the required outer block. As
781 -- above, the Sloc is copied from the last statement in the sequence.
783 if Present (Exception_Handlers (Stats)) then
784 Hand := First (Exception_Handlers (Stats));
785 while Present (Hand) loop
788 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
789 Append (Call, Statements (Hand));
795 Make_Handled_Sequence_Of_Statements (Loc,
796 Statements => New_List (
797 Make_Block_Statement (Loc,
798 Handled_Statement_Sequence => Stats)));
804 -- At this stage we know that the new statement sequence does not
805 -- have an exception handler part, so we supply one to call
806 -- Exceptional_Complete_Rendezvous. This handler is
808 -- when all others =>
809 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
811 -- We handle Abort_Signal to make sure that we properly catch the abort
812 -- case and wake up the caller.
814 Ohandle := Make_Others_Choice (Loc);
815 Set_All_Others (Ohandle);
817 Set_Exception_Handlers (New_S,
819 Make_Implicit_Exception_Handler (Loc,
820 Exception_Choices => New_List (Ohandle),
822 Statements => New_List (
823 Make_Procedure_Call_Statement (Sloc (Stats),
824 Name => New_Reference_To (
825 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
826 Parameter_Associations => New_List (
827 Make_Function_Call (Sloc (Stats),
828 Name => New_Reference_To (
829 RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
831 Set_Parent (New_S, Astat); -- temp parent for Analyze call
832 Analyze_Exception_Handlers (Exception_Handlers (New_S));
833 Expand_Exception_Handlers (New_S);
835 -- Exceptional_Complete_Rendezvous must be called with abort
836 -- still deferred, which is the case for a "when all others" handler.
839 end Build_Accept_Body;
841 -----------------------------------
842 -- Build_Activation_Chain_Entity --
843 -----------------------------------
845 procedure Build_Activation_Chain_Entity (N : Node_Id) is
851 -- Loop to find enclosing construct containing activation chain variable
852 -- The construct is a body, a block, or an extended return.
856 while not Nkind_In (P, N_Subprogram_Body,
858 N_Package_Declaration,
862 N_Extended_Return_Statement)
867 -- If we are in a package body, the activation chain variable is
868 -- declared in the body, but the Activation_Chain_Entity is attached
871 if Nkind (P) = N_Package_Body then
872 Decls := Declarations (P);
873 P := Unit_Declaration_Node (Corresponding_Spec (P));
875 elsif Nkind (P) = N_Package_Declaration then
876 Decls := Visible_Declarations (Specification (P));
878 elsif Nkind (P) = N_Extended_Return_Statement then
879 Decls := Return_Object_Declarations (P);
882 Decls := Declarations (P);
885 -- If activation chain entity not already declared, declare it
887 if Nkind (P) = N_Extended_Return_Statement
888 or else No (Activation_Chain_Entity (P))
890 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
892 -- Note: An extended return statement is not really a task activator,
893 -- but it does have an activation chain on which to store the tasks
894 -- temporarily. On successful return, the tasks on this chain are
895 -- moved to the chain passed in by the caller. We do not build an
896 -- Activation_Chain_Entity for an N_Extended_Return_Statement,
897 -- because we do not want to build a call to Activate_Tasks. Task
898 -- activation is the responsibility of the caller.
900 if Nkind (P) /= N_Extended_Return_Statement then
901 Set_Activation_Chain_Entity (P, Chain);
905 Make_Object_Declaration (Sloc (P),
906 Defining_Identifier => Chain,
907 Aliased_Present => True,
909 New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
911 Analyze (First (Decls));
913 end Build_Activation_Chain_Entity;
915 ----------------------------
916 -- Build_Barrier_Function --
917 ----------------------------
919 function Build_Barrier_Function
922 Pid : Node_Id) return Node_Id
924 Loc : constant Source_Ptr := Sloc (N);
925 Func_Id : constant Entity_Id := Barrier_Function (Ent);
926 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
927 Op_Decls : constant List_Id := New_List;
931 -- Add a declaration for the Protection object, renaming declarations
932 -- for the discriminals and privals and finally a declaration for the
933 -- entry family index (if applicable).
935 Install_Private_Data_Declarations
936 (Loc, Func_Id, Pid, N, Op_Decls, True, Ekind (Ent) = E_Entry_Family);
938 -- Note: the condition in the barrier function needs to be properly
939 -- processed for the C/Fortran boolean possibility, but this happens
940 -- automatically since the return statement does this normalization.
943 Make_Subprogram_Body (Loc,
945 Build_Barrier_Function_Specification (Loc,
946 Make_Defining_Identifier (Loc, Chars (Func_Id))),
947 Declarations => Op_Decls,
948 Handled_Statement_Sequence =>
949 Make_Handled_Sequence_Of_Statements (Loc,
950 Statements => New_List (
951 Make_Simple_Return_Statement (Loc,
952 Expression => Condition (Ent_Formals)))));
953 Set_Is_Entry_Barrier_Function (Func_Body);
956 end Build_Barrier_Function;
958 ------------------------------------------
959 -- Build_Barrier_Function_Specification --
960 ------------------------------------------
962 function Build_Barrier_Function_Specification
964 Def_Id : Entity_Id) return Node_Id
967 Set_Debug_Info_Needed (Def_Id);
969 return Make_Function_Specification (Loc,
970 Defining_Unit_Name => Def_Id,
971 Parameter_Specifications => New_List (
972 Make_Parameter_Specification (Loc,
973 Defining_Identifier =>
974 Make_Defining_Identifier (Loc, Name_uO),
976 New_Reference_To (RTE (RE_Address), Loc)),
978 Make_Parameter_Specification (Loc,
979 Defining_Identifier =>
980 Make_Defining_Identifier (Loc, Name_uE),
982 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
985 New_Reference_To (Standard_Boolean, Loc));
986 end Build_Barrier_Function_Specification;
988 --------------------------
989 -- Build_Call_With_Task --
990 --------------------------
992 function Build_Call_With_Task
994 E : Entity_Id) return Node_Id
996 Loc : constant Source_Ptr := Sloc (N);
999 Make_Function_Call (Loc,
1000 Name => New_Reference_To (E, Loc),
1001 Parameter_Associations => New_List (Concurrent_Ref (N)));
1002 end Build_Call_With_Task;
1004 --------------------------------
1005 -- Build_Corresponding_Record --
1006 --------------------------------
1008 function Build_Corresponding_Record
1011 Loc : Source_Ptr) return Node_Id
1013 Rec_Ent : constant Entity_Id :=
1014 Make_Defining_Identifier
1015 (Loc, New_External_Name (Chars (Ctyp), 'V'));
1018 New_Disc : Entity_Id;
1022 Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
1023 Set_Ekind (Rec_Ent, E_Record_Type);
1024 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
1025 Set_Is_Concurrent_Record_Type (Rec_Ent, True);
1026 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
1027 Set_Stored_Constraint (Rec_Ent, No_Elist);
1030 -- Use discriminals to create list of discriminants for record, and
1031 -- create new discriminals for use in default expressions, etc. It is
1032 -- worth noting that a task discriminant gives rise to 5 entities;
1034 -- a) The original discriminant.
1035 -- b) The discriminal for use in the task.
1036 -- c) The discriminant of the corresponding record.
1037 -- d) The discriminal for the init proc of the corresponding record.
1038 -- e) The local variable that renames the discriminant in the procedure
1039 -- for the task body.
1041 -- In fact the discriminals b) are used in the renaming declarations
1042 -- for e). See details in einfo (Handling of Discriminants).
1044 if Present (Discriminant_Specifications (N)) then
1046 Disc := First_Discriminant (Ctyp);
1048 while Present (Disc) loop
1049 New_Disc := CR_Discriminant (Disc);
1052 Make_Discriminant_Specification (Loc,
1053 Defining_Identifier => New_Disc,
1054 Discriminant_Type =>
1055 New_Occurrence_Of (Etype (Disc), Loc),
1057 New_Copy (Discriminant_Default_Value (Disc))));
1059 Next_Discriminant (Disc);
1066 -- Now we can construct the record type declaration. Note that this
1067 -- record is "limited tagged". It is "limited" to reflect the underlying
1068 -- limitedness of the task or protected object that it represents, and
1069 -- ensuring for example that it is properly passed by reference. It is
1070 -- "tagged" to give support to dispatching calls through interfaces. We
1071 -- propagate here the list of interfaces covered by the concurrent type
1072 -- (Ada 2005: AI-345).
1075 Make_Full_Type_Declaration (Loc,
1076 Defining_Identifier => Rec_Ent,
1077 Discriminant_Specifications => Dlist,
1079 Make_Record_Definition (Loc,
1081 Make_Component_List (Loc,
1082 Component_Items => Cdecls),
1084 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp),
1085 Interface_List => Interface_List (N),
1086 Limited_Present => True));
1087 end Build_Corresponding_Record;
1089 ----------------------------------
1090 -- Build_Entry_Count_Expression --
1091 ----------------------------------
1093 function Build_Entry_Count_Expression
1094 (Concurrent_Type : Node_Id;
1095 Component_List : List_Id;
1096 Loc : Source_Ptr) return Node_Id
1108 -- Count number of non-family entries
1111 Ent := First_Entity (Concurrent_Type);
1112 while Present (Ent) loop
1113 if Ekind (Ent) = E_Entry then
1120 Ecount := Make_Integer_Literal (Loc, Eindx);
1122 -- Loop through entry families building the addition nodes
1124 Ent := First_Entity (Concurrent_Type);
1125 Comp := First (Component_List);
1126 while Present (Ent) loop
1127 if Ekind (Ent) = E_Entry_Family then
1128 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
1132 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1133 Hi := Type_High_Bound (Typ);
1134 Lo := Type_Low_Bound (Typ);
1135 Large := Is_Potentially_Large_Family
1136 (Base_Type (Typ), Concurrent_Type, Lo, Hi);
1139 Left_Opnd => Ecount,
1140 Right_Opnd => Family_Size
1141 (Loc, Hi, Lo, Concurrent_Type, Large));
1148 end Build_Entry_Count_Expression;
1150 -----------------------
1151 -- Build_Entry_Names --
1152 -----------------------
1154 function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is
1155 Loc : constant Source_Ptr := Sloc (Conc_Typ);
1161 Typ : Entity_Id := Conc_Typ;
1163 procedure Build_Entry_Family_Name (Id : Entity_Id);
1165 -- for Lnn in Family_Low .. Family_High loop
1168 -- (_init._object <or> _init._task_id,
1170 -- new String ("<Entry name>(" & Lnn'Img & ")"));
1172 -- Note that the bounds of the range may reference discriminants. The
1173 -- above construct is added directly to the statements of the block.
1175 procedure Build_Entry_Name (Id : Entity_Id);
1179 -- (_init._object <or>_init._task_id,
1181 -- new String ("<Entry name>");
1182 -- The above construct is added directly to the statements of the block.
1184 function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id;
1185 -- Generate the call to the runtime routine Set_Entry_Name with actuals
1186 -- _init._task_id or _init._object, Inn and Arg3.
1188 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id;
1189 -- Given a protected type or its corresponding record, find the type of
1192 procedure Increment_Index (Stmts : List_Id);
1193 -- Generate the following and add it to Stmts
1196 -----------------------------
1197 -- Build_Entry_Family_Name --
1198 -----------------------------
1200 procedure Build_Entry_Family_Name (Id : Entity_Id) is
1201 Def : constant Node_Id :=
1202 Discrete_Subtype_Definition (Parent (Id));
1203 L_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
1204 L_Stmts : constant List_Id := New_List;
1207 function Build_Range (Def : Node_Id) return Node_Id;
1208 -- Given a discrete subtype definition of an entry family, generate a
1209 -- range node which covers the range of Def's type.
1215 function Build_Range (Def : Node_Id) return Node_Id is
1216 High : Node_Id := Type_High_Bound (Etype (Def));
1217 Low : Node_Id := Type_Low_Bound (Etype (Def));
1220 -- If a bound references a discriminant, generate an identifier
1221 -- with the same name. Resolution will map it to the formals of
1224 if Is_Entity_Name (Low)
1225 and then Ekind (Entity (Low)) = E_Discriminant
1227 Low := Make_Identifier (Loc, Chars (Low));
1229 Low := New_Copy_Tree (Low);
1232 if Is_Entity_Name (High)
1233 and then Ekind (Entity (High)) = E_Discriminant
1235 High := Make_Identifier (Loc, Chars (High));
1237 High := New_Copy_Tree (High);
1243 High_Bound => High);
1246 -- Start of processing for Build_Entry_Family_Name
1249 Get_Name_String (Chars (Id));
1251 -- Add a leading '('
1253 Add_Char_To_Name_Buffer ('(');
1256 -- new String'("<Entry name>(" & Lnn'Img & ")");
1258 -- This is an implicit heap allocation, and Comes_From_Source is
1259 -- False, which ensures that it will get flagged as a violation of
1260 -- No_Implicit_Heap_Allocations when that restriction applies.
1263 Make_Allocator (Loc,
1264 Make_Qualified_Expression (Loc,
1266 New_Reference_To (Standard_String, Loc),
1268 Make_Op_Concat (Loc,
1270 Make_Op_Concat (Loc,
1272 Make_String_Literal (Loc,
1273 Strval => String_From_Name_Buffer),
1275 Make_Attribute_Reference (Loc,
1277 New_Reference_To (L_Id, Loc),
1278 Attribute_Name => Name_Img)),
1280 Make_String_Literal (Loc,
1283 Increment_Index (L_Stmts);
1284 Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
1287 -- for Lnn in Family_Low .. Family_High loop
1290 -- (_init._object <or> _init._task_id, Inn, <Val>);
1294 Make_Loop_Statement (Loc,
1296 Make_Iteration_Scheme (Loc,
1297 Loop_Parameter_Specification =>
1298 Make_Loop_Parameter_Specification (Loc,
1299 Defining_Identifier => L_Id,
1300 Discrete_Subtype_Definition => Build_Range (Def))),
1301 Statements => L_Stmts,
1302 End_Label => Empty));
1303 end Build_Entry_Family_Name;
1305 ----------------------
1306 -- Build_Entry_Name --
1307 ----------------------
1309 procedure Build_Entry_Name (Id : Entity_Id) is
1313 Get_Name_String (Chars (Id));
1315 -- This is an implicit heap allocation, and Comes_From_Source is
1316 -- False, which ensures that it will get flagged as a violation of
1317 -- No_Implicit_Heap_Allocations when that restriction applies.
1320 Make_Allocator (Loc,
1321 Make_Qualified_Expression (Loc,
1323 New_Reference_To (Standard_String, Loc),
1325 Make_String_Literal (Loc,
1326 String_From_Name_Buffer)));
1328 Increment_Index (B_Stmts);
1329 Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val));
1330 end Build_Entry_Name;
1332 -------------------------------
1333 -- Build_Set_Entry_Name_Call --
1334 -------------------------------
1336 function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is
1341 -- Determine the proper name for the first argument and the RTS
1344 if Is_Protected_Type (Typ) then
1345 Arg1 := Name_uObject;
1346 Proc := RO_PE_Set_Entry_Name;
1348 else pragma Assert (Is_Task_Type (Typ));
1349 Arg1 := Name_uTask_Id;
1350 Proc := RO_TS_Set_Entry_Name;
1354 -- Set_Entry_Name (_init.Arg1, Inn, Arg3);
1357 Make_Procedure_Call_Statement (Loc,
1359 New_Reference_To (RTE (Proc), Loc),
1360 Parameter_Associations => New_List (
1361 Make_Selected_Component (Loc, -- _init._object
1362 Prefix => -- _init._task_id
1363 Make_Identifier (Loc, Name_uInit),
1365 Make_Identifier (Loc, Arg1)),
1366 New_Reference_To (Index, Loc), -- Inn
1368 end Build_Set_Entry_Name_Call;
1370 --------------------------
1371 -- Find_Protection_Type --
1372 --------------------------
1374 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
1376 Typ : Entity_Id := Conc_Typ;
1379 if Is_Concurrent_Type (Typ) then
1380 Typ := Corresponding_Record_Type (Typ);
1383 Comp := First_Component (Typ);
1384 while Present (Comp) loop
1385 if Chars (Comp) = Name_uObject then
1386 return Base_Type (Etype (Comp));
1389 Next_Component (Comp);
1392 -- The corresponding record of a protected type should always have an
1395 raise Program_Error;
1396 end Find_Protection_Type;
1398 ---------------------
1399 -- Increment_Index --
1400 ---------------------
1402 procedure Increment_Index (Stmts : List_Id) is
1408 Make_Assignment_Statement (Loc,
1410 New_Reference_To (Index, Loc),
1414 New_Reference_To (Index, Loc),
1416 Make_Integer_Literal (Loc, 1))));
1417 end Increment_Index;
1419 -- Start of processing for Build_Entry_Names
1422 -- Retrieve the original concurrent type
1424 if Is_Concurrent_Record_Type (Typ) then
1425 Typ := Corresponding_Concurrent_Type (Typ);
1428 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
1430 -- Nothing to do if the type has no entries
1432 if not Has_Entries (Typ) then
1436 -- Avoid generating entry names for a protected type with only one entry
1438 if Is_Protected_Type (Typ)
1439 and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries)
1444 Index := Make_Temporary (Loc, 'I');
1446 -- Step 1: Generate the declaration of the index variable:
1447 -- Inn : Protected_Entry_Index := 0;
1449 -- Inn : Task_Entry_Index := 0;
1451 if Is_Protected_Type (Typ) then
1452 Index_Typ := RE_Protected_Entry_Index;
1454 Index_Typ := RE_Task_Entry_Index;
1457 B_Decls := New_List;
1459 Make_Object_Declaration (Loc,
1460 Defining_Identifier => Index,
1461 Object_Definition => New_Reference_To (RTE (Index_Typ), Loc),
1462 Expression => Make_Integer_Literal (Loc, 0)));
1464 B_Stmts := New_List;
1466 -- Step 2: Generate a call to Set_Entry_Name for each entry and entry
1469 Comp := First_Entity (Typ);
1470 while Present (Comp) loop
1471 if Ekind (Comp) = E_Entry then
1472 Build_Entry_Name (Comp);
1474 elsif Ekind (Comp) = E_Entry_Family then
1475 Build_Entry_Family_Name (Comp);
1481 -- Step 3: Wrap the statements in a block
1484 Make_Block_Statement (Loc,
1485 Declarations => B_Decls,
1486 Handled_Statement_Sequence =>
1487 Make_Handled_Sequence_Of_Statements (Loc,
1488 Statements => B_Stmts));
1489 end Build_Entry_Names;
1491 ---------------------------
1492 -- Build_Parameter_Block --
1493 ---------------------------
1495 function Build_Parameter_Block
1499 Decls : List_Id) return Entity_Id
1505 Has_Comp : Boolean := False;
1509 Actual := First (Actuals);
1511 Formal := Defining_Identifier (First (Formals));
1513 while Present (Actual) loop
1514 if not Is_Controlling_Actual (Actual) then
1517 -- type Ann is access all <actual-type>
1519 Comp_Nam := Make_Temporary (Loc, 'A');
1522 Make_Full_Type_Declaration (Loc,
1523 Defining_Identifier => Comp_Nam,
1525 Make_Access_To_Object_Definition (Loc,
1526 All_Present => True,
1527 Constant_Present => Ekind (Formal) = E_In_Parameter,
1528 Subtype_Indication =>
1529 New_Reference_To (Etype (Actual), Loc))));
1535 Make_Component_Declaration (Loc,
1536 Defining_Identifier =>
1537 Make_Defining_Identifier (Loc, Chars (Formal)),
1538 Component_Definition =>
1539 Make_Component_Definition (Loc,
1542 Subtype_Indication =>
1543 New_Reference_To (Comp_Nam, Loc))));
1548 Next_Actual (Actual);
1549 Next_Formal_With_Extras (Formal);
1552 Rec_Nam := Make_Temporary (Loc, 'P');
1557 -- type Pnn is record
1562 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1563 -- the original parameter names and Ann1 .. AnnN are the access to
1567 Make_Full_Type_Declaration (Loc,
1568 Defining_Identifier =>
1571 Make_Record_Definition (Loc,
1573 Make_Component_List (Loc, Comps))));
1576 -- type Pnn is null record;
1579 Make_Full_Type_Declaration (Loc,
1580 Defining_Identifier =>
1583 Make_Record_Definition (Loc,
1584 Null_Present => True,
1585 Component_List => Empty)));
1589 end Build_Parameter_Block;
1591 --------------------------------------
1592 -- Build_Renamed_Formal_Declaration --
1593 --------------------------------------
1595 function Build_Renamed_Formal_Declaration
1599 Renamed_Formal : Node_Id) return Node_Id
1601 Loc : constant Source_Ptr := Sloc (New_F);
1605 -- If the formal is a tagged incomplete type, it is already passed
1606 -- by reference, so it is sufficient to rename the pointer component
1607 -- that corresponds to the actual. Otherwise we need to dereference
1608 -- the pointer component to obtain the actual.
1610 if Is_Incomplete_Type (Etype (Formal))
1611 and then Is_Tagged_Type (Etype (Formal))
1614 Make_Object_Renaming_Declaration (Loc,
1615 Defining_Identifier => New_F,
1616 Subtype_Mark => New_Reference_To (Etype (Comp), Loc),
1617 Name => Renamed_Formal);
1621 Make_Object_Renaming_Declaration (Loc,
1622 Defining_Identifier => New_F,
1623 Subtype_Mark => New_Reference_To (Etype (Formal), Loc),
1625 Make_Explicit_Dereference (Loc, Renamed_Formal));
1629 end Build_Renamed_Formal_Declaration;
1631 -----------------------
1632 -- Build_PPC_Wrapper --
1633 -----------------------
1635 procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id) is
1636 Loc : constant Source_Ptr := Sloc (E);
1637 Synch_Type : constant Entity_Id := Scope (E);
1639 Wrapper_Id : constant Entity_Id :=
1640 Make_Defining_Identifier (Loc,
1641 Chars => New_External_Name (Chars (E), 'E'));
1642 -- the wrapper procedure name
1644 Wrapper_Body : Node_Id;
1646 Synch_Id : constant Entity_Id :=
1647 Make_Defining_Identifier (Loc,
1648 Chars => New_External_Name (Chars (Scope (E)), 'A'));
1649 -- The parameter that designates the synchronized object in the call
1651 Actuals : constant List_Id := New_List;
1652 -- the actuals in the entry call.
1654 Decls : constant List_Id := New_List;
1656 Entry_Call : Node_Id;
1657 Entry_Name : Node_Id;
1660 -- The specification of the wrapper procedure
1664 -- Only build the wrapper if entry has pre/postconditions.
1665 -- Should this be done unconditionally instead ???
1671 P := Spec_PPC_List (E);
1676 -- Transfer ppc pragmas to the declarations of the wrapper
1678 while Present (P) loop
1679 if Pragma_Name (P) = Name_Precondition
1680 or else Pragma_Name (P) = Name_Postcondition
1682 Append (Relocate_Node (P), Decls);
1683 Set_Analyzed (Last (Decls), False);
1686 P := Next_Pragma (P);
1690 -- First formal is synchronized object
1693 Make_Parameter_Specification (Loc,
1694 Defining_Identifier => Synch_Id,
1695 Out_Present => True,
1697 Parameter_Type => New_Occurrence_Of (Scope (E), Loc)));
1700 Make_Selected_Component (Loc,
1701 Prefix => New_Occurrence_Of (Synch_Id, Loc),
1702 Selector_Name => New_Occurrence_Of (E, Loc));
1704 -- If entity is entry family, second formal is the corresponding index,
1705 -- and entry name is an indexed component.
1707 if Ekind (E) = E_Entry_Family then
1709 Index : constant Entity_Id :=
1710 Make_Defining_Identifier (Loc, Name_I);
1713 Make_Parameter_Specification (Loc,
1714 Defining_Identifier => Index,
1716 New_Occurrence_Of (Entry_Index_Type (E), Loc)));
1719 Make_Indexed_Component (Loc,
1720 Prefix => Entry_Name,
1721 Expressions => New_List (New_Occurrence_Of (Index, Loc)));
1726 Make_Procedure_Call_Statement (Loc,
1728 Parameter_Associations => Actuals);
1730 -- Now add formals that match those of the entry, and build actuals for
1731 -- the nested entry call.
1735 New_Form : Entity_Id;
1736 Parm_Spec : Node_Id;
1739 Form := First_Formal (E);
1740 while Present (Form) loop
1741 New_Form := Make_Defining_Identifier (Loc, Chars (Form));
1743 Make_Parameter_Specification (Loc,
1744 Defining_Identifier => New_Form,
1745 Out_Present => Out_Present (Parent (Form)),
1746 In_Present => In_Present (Parent (Form)),
1747 Parameter_Type => New_Occurrence_Of (Etype (Form), Loc));
1749 Append (Parm_Spec, Specs);
1750 Append (New_Occurrence_Of (New_Form, Loc), Actuals);
1755 -- Add renaming declarations for the discriminants of the enclosing
1756 -- type, which may be visible in the preconditions.
1758 if Has_Discriminants (Synch_Type) then
1764 D := First_Discriminant (Synch_Type);
1765 while Present (D) loop
1767 Make_Object_Renaming_Declaration (Loc,
1768 Defining_Identifier =>
1769 Make_Defining_Identifier (Loc, Chars (D)),
1770 Subtype_Mark => New_Reference_To (Etype (D), Loc),
1772 Make_Selected_Component (Loc,
1773 Prefix => New_Reference_To (Synch_Id, Loc),
1774 Selector_Name => Make_Identifier (Loc, Chars (D))));
1775 Prepend (Decl, Decls);
1776 Next_Discriminant (D);
1781 Set_PPC_Wrapper (E, Wrapper_Id);
1783 Make_Subprogram_Body (Loc,
1785 Make_Procedure_Specification (Loc,
1786 Defining_Unit_Name => Wrapper_Id,
1787 Parameter_Specifications => Specs),
1788 Declarations => Decls,
1789 Handled_Statement_Sequence =>
1790 Make_Handled_Sequence_Of_Statements (Loc,
1791 Statements => New_List (Entry_Call)));
1793 -- The wrapper body is analyzed when the enclosing type is frozen
1795 Append_Freeze_Action (Defining_Entity (Decl), Wrapper_Body);
1796 end Build_PPC_Wrapper;
1798 --------------------------
1799 -- Build_Wrapper_Bodies --
1800 --------------------------
1802 procedure Build_Wrapper_Bodies
1807 Rec_Typ : Entity_Id;
1809 function Build_Wrapper_Body
1811 Subp_Id : Entity_Id;
1812 Obj_Typ : Entity_Id;
1813 Formals : List_Id) return Node_Id;
1814 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1815 -- associated with a protected or task type. Subp_Id is the subprogram
1816 -- name which will be wrapped. Obj_Typ is the type of the new formal
1817 -- parameter which handles dispatching and object notation. Formals are
1818 -- the original formals of Subp_Id which will be explicitly replicated.
1820 ------------------------
1821 -- Build_Wrapper_Body --
1822 ------------------------
1824 function Build_Wrapper_Body
1826 Subp_Id : Entity_Id;
1827 Obj_Typ : Entity_Id;
1828 Formals : List_Id) return Node_Id
1830 Body_Spec : Node_Id;
1833 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals);
1835 -- The subprogram is not overriding or is not a primitive declared
1836 -- between two views.
1838 if No (Body_Spec) then
1843 Actuals : List_Id := No_List;
1845 First_Form : Node_Id;
1850 -- Map formals to actuals. Use the list built for the wrapper
1851 -- spec, skipping the object notation parameter.
1853 First_Form := First (Parameter_Specifications (Body_Spec));
1855 Formal := First_Form;
1858 if Present (Formal) then
1859 Actuals := New_List;
1860 while Present (Formal) loop
1862 Make_Identifier (Loc,
1863 Chars => Chars (Defining_Identifier (Formal))));
1868 -- Special processing for primitives declared between a private
1869 -- type and its completion: the wrapper needs a properly typed
1870 -- parameter if the wrapped operation has a controlling first
1871 -- parameter. Note that this might not be the case for a function
1872 -- with a controlling result.
1874 if Is_Private_Primitive_Subprogram (Subp_Id) then
1875 if No (Actuals) then
1876 Actuals := New_List;
1879 if Is_Controlling_Formal (First_Formal (Subp_Id)) then
1880 Prepend_To (Actuals,
1881 Unchecked_Convert_To
1882 (Corresponding_Concurrent_Type (Obj_Typ),
1883 Make_Identifier (Loc, Name_uO)));
1886 Prepend_To (Actuals,
1887 Make_Identifier (Loc,
1888 Chars => Chars (Defining_Identifier (First_Form))));
1891 Nam := New_Reference_To (Subp_Id, Loc);
1893 -- An access-to-variable object parameter requires an explicit
1894 -- dereference in the unchecked conversion. This case occurs
1895 -- when a protected entry wrapper must override an interface
1896 -- level procedure with interface access as first parameter.
1898 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1900 if Nkind (Parameter_Type (First_Form)) =
1904 Make_Explicit_Dereference (Loc,
1905 Prefix => Make_Identifier (Loc, Name_uO));
1907 Conv_Id := Make_Identifier (Loc, Name_uO);
1911 Make_Selected_Component (Loc,
1913 Unchecked_Convert_To
1914 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id),
1915 Selector_Name => New_Reference_To (Subp_Id, Loc));
1918 -- Create the subprogram body. For a function, the call to the
1919 -- actual subprogram has to be converted to the corresponding
1920 -- record if it is a controlling result.
1922 if Ekind (Subp_Id) = E_Function then
1928 Make_Function_Call (Loc,
1930 Parameter_Associations => Actuals);
1932 if Has_Controlling_Result (Subp_Id) then
1934 Unchecked_Convert_To
1935 (Corresponding_Record_Type (Etype (Subp_Id)), Res);
1939 Make_Subprogram_Body (Loc,
1940 Specification => Body_Spec,
1941 Declarations => Empty_List,
1942 Handled_Statement_Sequence =>
1943 Make_Handled_Sequence_Of_Statements (Loc,
1944 Statements => New_List (
1945 Make_Simple_Return_Statement (Loc, Res))));
1950 Make_Subprogram_Body (Loc,
1951 Specification => Body_Spec,
1952 Declarations => Empty_List,
1953 Handled_Statement_Sequence =>
1954 Make_Handled_Sequence_Of_Statements (Loc,
1955 Statements => New_List (
1956 Make_Procedure_Call_Statement (Loc,
1958 Parameter_Associations => Actuals))));
1961 end Build_Wrapper_Body;
1963 -- Start of processing for Build_Wrapper_Bodies
1966 if Is_Concurrent_Type (Typ) then
1967 Rec_Typ := Corresponding_Record_Type (Typ);
1972 -- Generate wrapper bodies for a concurrent type which implements an
1975 if Present (Interfaces (Rec_Typ)) then
1977 Insert_Nod : Node_Id;
1979 Prim_Elmt : Elmt_Id;
1980 Prim_Decl : Node_Id;
1982 Wrap_Body : Node_Id;
1983 Wrap_Id : Entity_Id;
1988 -- Examine all primitive operations of the corresponding record
1989 -- type, looking for wrapper specs. Generate bodies in order to
1992 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ));
1993 while Present (Prim_Elmt) loop
1994 Prim := Node (Prim_Elmt);
1996 if (Ekind (Prim) = E_Function
1997 or else Ekind (Prim) = E_Procedure)
1998 and then Is_Primitive_Wrapper (Prim)
2000 Subp := Wrapped_Entity (Prim);
2001 Prim_Decl := Parent (Parent (Prim));
2004 Build_Wrapper_Body (Loc,
2007 Formals => Parameter_Specifications (Parent (Subp)));
2008 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body));
2010 Set_Corresponding_Spec (Wrap_Body, Prim);
2011 Set_Corresponding_Body (Prim_Decl, Wrap_Id);
2013 Insert_After (Insert_Nod, Wrap_Body);
2014 Insert_Nod := Wrap_Body;
2016 Analyze (Wrap_Body);
2019 Next_Elmt (Prim_Elmt);
2023 end Build_Wrapper_Bodies;
2025 ------------------------
2026 -- Build_Wrapper_Spec --
2027 ------------------------
2029 function Build_Wrapper_Spec
2030 (Subp_Id : Entity_Id;
2031 Obj_Typ : Entity_Id;
2032 Formals : List_Id) return Node_Id
2034 Loc : constant Source_Ptr := Sloc (Subp_Id);
2035 First_Param : Node_Id;
2037 Iface_Elmt : Elmt_Id;
2038 Iface_Op : Entity_Id;
2039 Iface_Op_Elmt : Elmt_Id;
2041 function Overriding_Possible
2042 (Iface_Op : Entity_Id;
2043 Wrapper : Entity_Id) return Boolean;
2044 -- Determine whether a primitive operation can be overridden by Wrapper.
2045 -- Iface_Op is the candidate primitive operation of an interface type,
2046 -- Wrapper is the generated entry wrapper.
2048 function Replicate_Formals
2050 Formals : List_Id) return List_Id;
2051 -- An explicit parameter replication is required due to the Is_Entry_
2052 -- Formal flag being set for all the formals of an entry. The explicit
2053 -- replication removes the flag that would otherwise cause a different
2054 -- path of analysis.
2056 -------------------------
2057 -- Overriding_Possible --
2058 -------------------------
2060 function Overriding_Possible
2061 (Iface_Op : Entity_Id;
2062 Wrapper : Entity_Id) return Boolean
2064 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op);
2065 Wrapper_Spec : constant Node_Id := Parent (Wrapper);
2067 function Type_Conformant_Parameters
2068 (Iface_Op_Params : List_Id;
2069 Wrapper_Params : List_Id) return Boolean;
2070 -- Determine whether the parameters of the generated entry wrapper
2071 -- and those of a primitive operation are type conformant. During
2072 -- this check, the first parameter of the primitive operation is
2073 -- skipped if it is a controlling argument: protected functions
2074 -- may have a controlling result.
2076 --------------------------------
2077 -- Type_Conformant_Parameters --
2078 --------------------------------
2080 function Type_Conformant_Parameters
2081 (Iface_Op_Params : List_Id;
2082 Wrapper_Params : List_Id) return Boolean
2084 Iface_Op_Param : Node_Id;
2085 Iface_Op_Typ : Entity_Id;
2086 Wrapper_Param : Node_Id;
2087 Wrapper_Typ : Entity_Id;
2090 -- Skip the first (controlling) parameter of primitive operation
2092 Iface_Op_Param := First (Iface_Op_Params);
2094 if Present (First_Formal (Iface_Op))
2095 and then Is_Controlling_Formal (First_Formal (Iface_Op))
2097 Iface_Op_Param := Next (Iface_Op_Param);
2100 Wrapper_Param := First (Wrapper_Params);
2101 while Present (Iface_Op_Param)
2102 and then Present (Wrapper_Param)
2104 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param);
2105 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param);
2107 -- The two parameters must be mode conformant
2109 if not Conforming_Types
2110 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant)
2115 Next (Iface_Op_Param);
2116 Next (Wrapper_Param);
2119 -- One of the lists is longer than the other
2121 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then
2126 end Type_Conformant_Parameters;
2128 -- Start of processing for Overriding_Possible
2131 if Chars (Iface_Op) /= Chars (Wrapper) then
2135 -- If an inherited subprogram is implemented by a protected procedure
2136 -- or an entry, then the first parameter of the inherited subprogram
2137 -- shall be of mode OUT or IN OUT, or access-to-variable parameter.
2139 if Ekind (Iface_Op) = E_Procedure
2140 and then Present (Parameter_Specifications (Iface_Op_Spec))
2143 Obj_Param : constant Node_Id :=
2144 First (Parameter_Specifications (Iface_Op_Spec));
2146 if not Out_Present (Obj_Param)
2147 and then Nkind (Parameter_Type (Obj_Param)) /=
2156 Type_Conformant_Parameters (
2157 Parameter_Specifications (Iface_Op_Spec),
2158 Parameter_Specifications (Wrapper_Spec));
2159 end Overriding_Possible;
2161 -----------------------
2162 -- Replicate_Formals --
2163 -----------------------
2165 function Replicate_Formals
2167 Formals : List_Id) return List_Id
2169 New_Formals : constant List_Id := New_List;
2171 Param_Type : Node_Id;
2174 Formal := First (Formals);
2176 -- Skip the object parameter when dealing with primitives declared
2177 -- between two views.
2179 if Is_Private_Primitive_Subprogram (Subp_Id)
2180 and then not Has_Controlling_Result (Subp_Id)
2182 Formal := Next (Formal);
2185 while Present (Formal) loop
2187 -- Create an explicit copy of the entry parameter
2189 -- When creating the wrapper subprogram for a primitive operation
2190 -- of a protected interface we must construct an equivalent
2191 -- signature to that of the overriding operation. For regular
2192 -- parameters we can just use the type of the formal, but for
2193 -- access to subprogram parameters we need to reanalyze the
2194 -- parameter type to create local entities for the signature of
2195 -- the subprogram type. Using the entities of the overriding
2196 -- subprogram will result in out-of-scope errors in the back-end.
2198 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then
2199 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal));
2202 New_Reference_To (Etype (Parameter_Type (Formal)), Loc);
2205 Append_To (New_Formals,
2206 Make_Parameter_Specification (Loc,
2207 Defining_Identifier =>
2208 Make_Defining_Identifier (Loc,
2209 Chars => Chars (Defining_Identifier (Formal))),
2210 In_Present => In_Present (Formal),
2211 Out_Present => Out_Present (Formal),
2212 Parameter_Type => Param_Type));
2218 end Replicate_Formals;
2220 -- Start of processing for Build_Wrapper_Spec
2223 -- There is no point in building wrappers for non-tagged concurrent
2226 pragma Assert (Is_Tagged_Type (Obj_Typ));
2228 -- An entry or a protected procedure can override a routine where the
2229 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2230 -- type. Since the wrapper must have the exact same signature as that of
2231 -- the overridden subprogram, we try to find the overriding candidate
2232 -- and use its controlling formal.
2234 First_Param := Empty;
2236 -- Check every implemented interface
2238 if Present (Interfaces (Obj_Typ)) then
2239 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
2240 Search : while Present (Iface_Elmt) loop
2241 Iface := Node (Iface_Elmt);
2243 -- Check every interface primitive
2245 if Present (Primitive_Operations (Iface)) then
2246 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
2247 while Present (Iface_Op_Elmt) loop
2248 Iface_Op := Node (Iface_Op_Elmt);
2250 -- Ignore predefined primitives
2252 if not Is_Predefined_Dispatching_Operation (Iface_Op) then
2253 Iface_Op := Ultimate_Alias (Iface_Op);
2255 -- The current primitive operation can be overridden by
2256 -- the generated entry wrapper.
2258 if Overriding_Possible (Iface_Op, Subp_Id) then
2260 First (Parameter_Specifications (Parent (Iface_Op)));
2266 Next_Elmt (Iface_Op_Elmt);
2270 Next_Elmt (Iface_Elmt);
2274 -- If the subprogram to be wrapped is not overriding anything or is not
2275 -- a primitive declared between two views, do not produce anything. This
2276 -- avoids spurious errors involving overriding.
2279 and then not Is_Private_Primitive_Subprogram (Subp_Id)
2285 Wrapper_Id : constant Entity_Id :=
2286 Make_Defining_Identifier (Loc, Chars (Subp_Id));
2287 New_Formals : List_Id;
2288 Obj_Param : Node_Id;
2289 Obj_Param_Typ : Entity_Id;
2292 -- Minimum decoration is needed to catch the entity in
2293 -- Sem_Ch6.Override_Dispatching_Operation.
2295 if Ekind (Subp_Id) = E_Function then
2296 Set_Ekind (Wrapper_Id, E_Function);
2298 Set_Ekind (Wrapper_Id, E_Procedure);
2301 Set_Is_Primitive_Wrapper (Wrapper_Id);
2302 Set_Wrapped_Entity (Wrapper_Id, Subp_Id);
2303 Set_Is_Private_Primitive (Wrapper_Id,
2304 Is_Private_Primitive_Subprogram (Subp_Id));
2306 -- Process the formals
2308 New_Formals := Replicate_Formals (Loc, Formals);
2310 -- A function with a controlling result and no first controlling
2311 -- formal needs no additional parameter.
2313 if Has_Controlling_Result (Subp_Id)
2315 (No (First_Formal (Subp_Id))
2316 or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
2320 -- Routine Subp_Id has been found to override an interface primitive.
2321 -- If the interface operation has an access parameter, create a copy
2322 -- of it, with the same null exclusion indicator if present.
2324 elsif Present (First_Param) then
2325 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
2327 Make_Access_Definition (Loc,
2329 New_Reference_To (Obj_Typ, Loc));
2330 Set_Null_Exclusion_Present (Obj_Param_Typ,
2331 Null_Exclusion_Present (Parameter_Type (First_Param)));
2334 Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc);
2338 Make_Parameter_Specification (Loc,
2339 Defining_Identifier =>
2340 Make_Defining_Identifier (Loc,
2342 In_Present => In_Present (First_Param),
2343 Out_Present => Out_Present (First_Param),
2344 Parameter_Type => Obj_Param_Typ);
2346 Prepend_To (New_Formals, Obj_Param);
2348 -- If we are dealing with a primitive declared between two views,
2349 -- implemented by a synchronized operation, we need to create
2350 -- a default parameter. The mode of the parameter must match that
2351 -- of the primitive operation.
2354 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
2356 Make_Parameter_Specification (Loc,
2357 Defining_Identifier =>
2358 Make_Defining_Identifier (Loc, Name_uO),
2359 In_Present => In_Present (Parent (First_Entity (Subp_Id))),
2360 Out_Present => Ekind (Subp_Id) /= E_Function,
2361 Parameter_Type => New_Reference_To (Obj_Typ, Loc));
2362 Prepend_To (New_Formals, Obj_Param);
2365 -- Build the final spec. If it is a function with a controlling
2366 -- result, it is a primitive operation of the corresponding
2367 -- record type, so mark the spec accordingly.
2369 if Ekind (Subp_Id) = E_Function then
2374 if Has_Controlling_Result (Subp_Id) then
2377 (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
2379 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
2383 Make_Function_Specification (Loc,
2384 Defining_Unit_Name => Wrapper_Id,
2385 Parameter_Specifications => New_Formals,
2386 Result_Definition => Res_Def);
2390 Make_Procedure_Specification (Loc,
2391 Defining_Unit_Name => Wrapper_Id,
2392 Parameter_Specifications => New_Formals);
2395 end Build_Wrapper_Spec;
2397 -------------------------
2398 -- Build_Wrapper_Specs --
2399 -------------------------
2401 procedure Build_Wrapper_Specs
2407 Rec_Typ : Entity_Id;
2408 procedure Scan_Declarations (L : List_Id);
2409 -- Common processing for visible and private declarations
2410 -- of a protected type.
2412 procedure Scan_Declarations (L : List_Id) is
2414 Wrap_Decl : Node_Id;
2415 Wrap_Spec : Node_Id;
2423 while Present (Decl) loop
2426 if Nkind (Decl) = N_Entry_Declaration
2427 and then Ekind (Defining_Identifier (Decl)) = E_Entry
2431 (Subp_Id => Defining_Identifier (Decl),
2433 Formals => Parameter_Specifications (Decl));
2435 elsif Nkind (Decl) = N_Subprogram_Declaration then
2438 (Subp_Id => Defining_Unit_Name (Specification (Decl)),
2441 Parameter_Specifications (Specification (Decl)));
2444 if Present (Wrap_Spec) then
2446 Make_Subprogram_Declaration (Loc,
2447 Specification => Wrap_Spec);
2449 Insert_After (N, Wrap_Decl);
2452 Analyze (Wrap_Decl);
2457 end Scan_Declarations;
2459 -- start of processing for Build_Wrapper_Specs
2462 if Is_Protected_Type (Typ) then
2463 Def := Protected_Definition (Parent (Typ));
2464 else pragma Assert (Is_Task_Type (Typ));
2465 Def := Task_Definition (Parent (Typ));
2468 Rec_Typ := Corresponding_Record_Type (Typ);
2470 -- Generate wrapper specs for a concurrent type which implements an
2471 -- interface. Operations in both the visible and private parts may
2472 -- implement progenitor operations.
2474 if Present (Interfaces (Rec_Typ))
2475 and then Present (Def)
2477 Scan_Declarations (Visible_Declarations (Def));
2478 Scan_Declarations (Private_Declarations (Def));
2480 end Build_Wrapper_Specs;
2482 ---------------------------
2483 -- Build_Find_Body_Index --
2484 ---------------------------
2486 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
2487 Loc : constant Source_Ptr := Sloc (Typ);
2490 Has_F : Boolean := False;
2492 If_St : Node_Id := Empty;
2495 Decls : List_Id := New_List;
2498 Siz : Node_Id := Empty;
2500 procedure Add_If_Clause (Expr : Node_Id);
2501 -- Add test for range of current entry
2503 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
2504 -- If a bound of an entry is given by a discriminant, retrieve the
2505 -- actual value of the discriminant from the enclosing object.
2511 procedure Add_If_Clause (Expr : Node_Id) is
2513 Stats : constant List_Id :=
2515 Make_Simple_Return_Statement (Loc,
2516 Expression => Make_Integer_Literal (Loc, Index + 1)));
2519 -- Index for current entry body
2523 -- Compute total length of entry queues so far
2531 Right_Opnd => Expr);
2536 Left_Opnd => Make_Identifier (Loc, Name_uE),
2539 -- Map entry queue indexes in the range of the current family
2540 -- into the current index, that designates the entry body.
2544 Make_Implicit_If_Statement (Typ,
2546 Then_Statements => Stats,
2547 Elsif_Parts => New_List);
2553 Make_Elsif_Part (Loc,
2555 Then_Statements => Stats),
2556 Elsif_Parts (If_St));
2560 ------------------------------
2561 -- Convert_Discriminant_Ref --
2562 ------------------------------
2564 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
2568 if Is_Entity_Name (Bound)
2569 and then Ekind (Entity (Bound)) = E_Discriminant
2572 Make_Selected_Component (Loc,
2574 Unchecked_Convert_To (Corresponding_Record_Type (Typ),
2575 Make_Explicit_Dereference (Loc,
2576 Make_Identifier (Loc, Name_uObject))),
2577 Selector_Name => Make_Identifier (Loc, Chars (Bound)));
2578 Set_Etype (B, Etype (Entity (Bound)));
2580 B := New_Copy_Tree (Bound);
2584 end Convert_Discriminant_Ref;
2586 -- Start of processing for Build_Find_Body_Index
2589 Spec := Build_Find_Body_Index_Spec (Typ);
2591 Ent := First_Entity (Typ);
2592 while Present (Ent) loop
2593 if Ekind (Ent) = E_Entry_Family then
2603 -- If the protected type has no entry families, there is a one-one
2604 -- correspondence between entry queue and entry body.
2607 Make_Simple_Return_Statement (Loc,
2608 Expression => Make_Identifier (Loc, Name_uE));
2611 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2614 -- if E <= l1 then return 1;
2615 -- elsif E <= l1 + l2 then return 2;
2620 Ent := First_Entity (Typ);
2622 Add_Object_Pointer (Loc, Typ, Decls);
2624 while Present (Ent) loop
2625 if Ekind (Ent) = E_Entry then
2626 Add_If_Clause (Make_Integer_Literal (Loc, 1));
2628 elsif Ekind (Ent) = E_Entry_Family then
2629 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
2630 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
2631 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
2632 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
2641 Make_Simple_Return_Statement (Loc,
2642 Expression => Make_Integer_Literal (Loc, 1));
2644 elsif Nkind (Ret) = N_If_Statement then
2646 -- Ranges are in increasing order, so last one doesn't need guard
2649 Nod : constant Node_Id := Last (Elsif_Parts (Ret));
2652 Set_Else_Statements (Ret, Then_Statements (Nod));
2658 Make_Subprogram_Body (Loc,
2659 Specification => Spec,
2660 Declarations => Decls,
2661 Handled_Statement_Sequence =>
2662 Make_Handled_Sequence_Of_Statements (Loc,
2663 Statements => New_List (Ret)));
2664 end Build_Find_Body_Index;
2666 --------------------------------
2667 -- Build_Find_Body_Index_Spec --
2668 --------------------------------
2670 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
2671 Loc : constant Source_Ptr := Sloc (Typ);
2672 Id : constant Entity_Id :=
2673 Make_Defining_Identifier (Loc,
2674 Chars => New_External_Name (Chars (Typ), 'F'));
2675 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
2676 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
2680 Make_Function_Specification (Loc,
2681 Defining_Unit_Name => Id,
2682 Parameter_Specifications => New_List (
2683 Make_Parameter_Specification (Loc,
2684 Defining_Identifier => Parm1,
2686 New_Reference_To (RTE (RE_Address), Loc)),
2688 Make_Parameter_Specification (Loc,
2689 Defining_Identifier => Parm2,
2691 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
2692 Result_Definition => New_Occurrence_Of (
2693 RTE (RE_Protected_Entry_Index), Loc));
2694 end Build_Find_Body_Index_Spec;
2696 -------------------------
2697 -- Build_Master_Entity --
2698 -------------------------
2700 procedure Build_Master_Entity (E : Entity_Id) is
2701 Loc : constant Source_Ptr := Sloc (E);
2707 S := Find_Master_Scope (E);
2709 -- Nothing to do if we already built a master entity for this scope
2710 -- or if there is no task hierarchy.
2712 if Has_Master_Entity (S)
2713 or else Restriction_Active (No_Task_Hierarchy)
2718 -- Otherwise first build the master entity
2719 -- _Master : constant Master_Id := Current_Master.all;
2720 -- and insert it just before the current declaration
2723 Make_Object_Declaration (Loc,
2724 Defining_Identifier =>
2725 Make_Defining_Identifier (Loc, Name_uMaster),
2726 Constant_Present => True,
2727 Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc),
2729 Make_Explicit_Dereference (Loc,
2730 New_Reference_To (RTE (RE_Current_Master), Loc)));
2733 Insert_Before (P, Decl);
2736 Set_Has_Master_Entity (S);
2738 -- Now mark the containing scope as a task master
2740 while Nkind (P) /= N_Compilation_Unit loop
2743 -- If we fall off the top, we are at the outer level, and the
2744 -- environment task is our effective master, so nothing to mark.
2747 (P, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
2749 Set_Is_Task_Master (P, True);
2752 elsif Nkind (Parent (P)) = N_Subunit then
2753 P := Corresponding_Stub (Parent (P));
2756 end Build_Master_Entity;
2758 -----------------------------------------
2759 -- Build_Private_Protected_Declaration --
2760 -----------------------------------------
2762 function Build_Private_Protected_Declaration
2763 (N : Node_Id) return Entity_Id
2765 Loc : constant Source_Ptr := Sloc (N);
2766 Body_Id : constant Entity_Id := Defining_Entity (N);
2771 Spec_Id : Entity_Id;
2774 Formal := First_Formal (Body_Id);
2776 -- The protected operation always has at least one formal, namely the
2777 -- object itself, but it is only placed in the parameter list if
2778 -- expansion is enabled.
2780 if Present (Formal) or else Expander_Active then
2781 Plist := Copy_Parameter_List (Body_Id);
2786 if Nkind (Specification (N)) = N_Procedure_Specification then
2788 Make_Procedure_Specification (Loc,
2789 Defining_Unit_Name =>
2790 Make_Defining_Identifier (Sloc (Body_Id),
2791 Chars => Chars (Body_Id)),
2792 Parameter_Specifications =>
2796 Make_Function_Specification (Loc,
2797 Defining_Unit_Name =>
2798 Make_Defining_Identifier (Sloc (Body_Id),
2799 Chars => Chars (Body_Id)),
2800 Parameter_Specifications => Plist,
2801 Result_Definition =>
2802 New_Occurrence_Of (Etype (Body_Id), Loc));
2805 Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec);
2806 Insert_Before (N, Decl);
2807 Spec_Id := Defining_Unit_Name (New_Spec);
2809 -- Indicate that the entity comes from source, to ensure that cross-
2810 -- reference information is properly generated. The body itself is
2811 -- rewritten during expansion, and the body entity will not appear in
2812 -- calls to the operation.
2814 Set_Comes_From_Source (Spec_Id, True);
2816 Set_Has_Completion (Spec_Id);
2817 Set_Convention (Spec_Id, Convention_Protected);
2819 end Build_Private_Protected_Declaration;
2821 ---------------------------
2822 -- Build_Protected_Entry --
2823 ---------------------------
2825 function Build_Protected_Entry
2828 Pid : Node_Id) return Node_Id
2830 Loc : constant Source_Ptr := Sloc (N);
2832 Decls : constant List_Id := Declarations (N);
2833 End_Lab : constant Node_Id :=
2834 End_Label (Handled_Statement_Sequence (N));
2835 End_Loc : constant Source_Ptr :=
2836 Sloc (Last (Statements (Handled_Statement_Sequence (N))));
2837 -- Used for the generated call to Complete_Entry_Body
2839 Han_Loc : Source_Ptr;
2840 -- Used for the exception handler, inserted at end of the body
2842 Op_Decls : constant List_Id := New_List;
2850 -- Set the source location on the exception handler only when debugging
2851 -- the expanded code (see Make_Implicit_Exception_Handler).
2853 if Debug_Generated_Code then
2856 -- Otherwise the inserted code should not be visible to the debugger
2859 Han_Loc := No_Location;
2863 Make_Defining_Identifier (Loc,
2864 Chars => Chars (Protected_Body_Subprogram (Ent)));
2866 Build_Protected_Entry_Specification (Loc, Edef, Empty);
2868 -- Add the following declarations:
2869 -- type poVP is access poV;
2870 -- _object : poVP := poVP (_O);
2872 -- where _O is the formal parameter associated with the concurrent
2873 -- object. These declarations are needed for Complete_Entry_Body.
2875 Add_Object_Pointer (Loc, Pid, Op_Decls);
2877 -- Add renamings for all formals, the Protection object, discriminals,
2878 -- privals and the entry index constant for use by debugger.
2880 Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc);
2881 Debug_Private_Data_Declarations (Decls);
2883 case Corresponding_Runtime_Package (Pid) is
2884 when System_Tasking_Protected_Objects_Entries =>
2886 New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
2888 when System_Tasking_Protected_Objects_Single_Entry =>
2890 New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc);
2893 raise Program_Error;
2896 Op_Stats := New_List (
2897 Make_Block_Statement (Loc,
2898 Declarations => Decls,
2899 Handled_Statement_Sequence =>
2900 Handled_Statement_Sequence (N)),
2902 Make_Procedure_Call_Statement (End_Loc,
2904 Parameter_Associations => New_List (
2905 Make_Attribute_Reference (End_Loc,
2907 Make_Selected_Component (End_Loc,
2908 Prefix => Make_Identifier (End_Loc, Name_uObject),
2909 Selector_Name => Make_Identifier (End_Loc, Name_uObject)),
2910 Attribute_Name => Name_Unchecked_Access))));
2912 -- When exceptions can not be propagated, we never need to call
2913 -- Exception_Complete_Entry_Body
2915 if No_Exception_Handlers_Set then
2917 Make_Subprogram_Body (Loc,
2918 Specification => Espec,
2919 Declarations => Op_Decls,
2920 Handled_Statement_Sequence =>
2921 Make_Handled_Sequence_Of_Statements (Loc,
2922 Statements => Op_Stats,
2923 End_Label => End_Lab));
2926 Ohandle := Make_Others_Choice (Loc);
2927 Set_All_Others (Ohandle);
2929 case Corresponding_Runtime_Package (Pid) is
2930 when System_Tasking_Protected_Objects_Entries =>
2933 (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
2935 when System_Tasking_Protected_Objects_Single_Entry =>
2938 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
2941 raise Program_Error;
2944 -- Establish link between subprogram body entity and source entry.
2946 Set_Corresponding_Protected_Entry (Edef, Ent);
2948 -- Create body of entry procedure. The renaming declarations are
2949 -- placed ahead of the block that contains the actual entry body.
2952 Make_Subprogram_Body (Loc,
2953 Specification => Espec,
2954 Declarations => Op_Decls,
2955 Handled_Statement_Sequence =>
2956 Make_Handled_Sequence_Of_Statements (Loc,
2957 Statements => Op_Stats,
2958 End_Label => End_Lab,
2959 Exception_Handlers => New_List (
2960 Make_Implicit_Exception_Handler (Han_Loc,
2961 Exception_Choices => New_List (Ohandle),
2963 Statements => New_List (
2964 Make_Procedure_Call_Statement (Han_Loc,
2966 Parameter_Associations => New_List (
2967 Make_Attribute_Reference (Han_Loc,
2969 Make_Selected_Component (Han_Loc,
2971 Make_Identifier (Han_Loc, Name_uObject),
2973 Make_Identifier (Han_Loc, Name_uObject)),
2974 Attribute_Name => Name_Unchecked_Access),
2976 Make_Function_Call (Han_Loc,
2977 Name => New_Reference_To (
2978 RTE (RE_Get_GNAT_Exception), Loc)))))))));
2980 end Build_Protected_Entry;
2982 -----------------------------------------
2983 -- Build_Protected_Entry_Specification --
2984 -----------------------------------------
2986 function Build_Protected_Entry_Specification
2989 Ent_Id : Entity_Id) return Node_Id
2991 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP);
2994 Set_Debug_Info_Needed (Def_Id);
2996 if Present (Ent_Id) then
2997 Append_Elmt (P, Accept_Address (Ent_Id));
3001 Make_Procedure_Specification (Loc,
3002 Defining_Unit_Name => Def_Id,
3003 Parameter_Specifications => New_List (
3004 Make_Parameter_Specification (Loc,
3005 Defining_Identifier =>
3006 Make_Defining_Identifier (Loc, Name_uO),
3008 New_Reference_To (RTE (RE_Address), Loc)),
3010 Make_Parameter_Specification (Loc,
3011 Defining_Identifier => P,
3013 New_Reference_To (RTE (RE_Address), Loc)),
3015 Make_Parameter_Specification (Loc,
3016 Defining_Identifier =>
3017 Make_Defining_Identifier (Loc, Name_uE),
3019 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))));
3020 end Build_Protected_Entry_Specification;
3022 --------------------------
3023 -- Build_Protected_Spec --
3024 --------------------------
3026 function Build_Protected_Spec
3028 Obj_Type : Entity_Id;
3030 Unprotected : Boolean := False) return List_Id
3032 Loc : constant Source_Ptr := Sloc (N);
3035 New_Plist : List_Id;
3036 New_Param : Node_Id;
3039 New_Plist := New_List;
3041 Formal := First_Formal (Ident);
3042 while Present (Formal) loop
3044 Make_Parameter_Specification (Loc,
3045 Defining_Identifier =>
3046 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
3047 In_Present => In_Present (Parent (Formal)),
3048 Out_Present => Out_Present (Parent (Formal)),
3049 Parameter_Type => New_Reference_To (Etype (Formal), Loc));
3052 Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
3055 Append (New_Param, New_Plist);
3056 Next_Formal (Formal);
3059 -- If the subprogram is a procedure and the context is not an access
3060 -- to protected subprogram, the parameter is in-out. Otherwise it is
3064 Make_Parameter_Specification (Loc,
3065 Defining_Identifier =>
3066 Make_Defining_Identifier (Loc, Name_uObject),
3069 (Etype (Ident) = Standard_Void_Type
3070 and then not Is_RTE (Obj_Type, RE_Address)),
3072 New_Reference_To (Obj_Type, Loc));
3073 Set_Debug_Info_Needed (Defining_Identifier (Decl));
3074 Prepend_To (New_Plist, Decl);
3077 end Build_Protected_Spec;
3079 ---------------------------------------
3080 -- Build_Protected_Sub_Specification --
3081 ---------------------------------------
3083 function Build_Protected_Sub_Specification
3085 Prot_Typ : Entity_Id;
3086 Mode : Subprogram_Protection_Mode) return Node_Id
3088 Loc : constant Source_Ptr := Sloc (N);
3092 New_Plist : List_Id;
3095 Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
3096 (Dispatching_Mode => ' ',
3097 Protected_Mode => 'P',
3098 Unprotected_Mode => 'N');
3101 if Ekind (Defining_Unit_Name (Specification (N))) =
3104 Decl := Unit_Declaration_Node (Corresponding_Spec (N));
3109 Def_Id := Defining_Unit_Name (Specification (Decl));
3112 Build_Protected_Spec
3113 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id,
3114 Mode = Unprotected_Mode);
3116 Make_Defining_Identifier (Loc,
3117 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
3119 -- The unprotected operation carries the user code, and debugging
3120 -- information must be generated for it, even though this spec does
3121 -- not come from source. It is also convenient to allow gdb to step
3122 -- into the protected operation, even though it only contains lock/
3125 Set_Debug_Info_Needed (New_Id);
3127 -- If a pragma Eliminate applies to the source entity, the internal
3128 -- subprograms will be eliminated as well.
3130 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
3132 if Nkind (Specification (Decl)) = N_Procedure_Specification then
3134 Make_Procedure_Specification (Loc,
3135 Defining_Unit_Name => New_Id,
3136 Parameter_Specifications => New_Plist);
3138 -- Create a new specification for the anonymous subprogram type
3142 Make_Function_Specification (Loc,
3143 Defining_Unit_Name => New_Id,
3144 Parameter_Specifications => New_Plist,
3145 Result_Definition =>
3146 Copy_Result_Type (Result_Definition (Specification (Decl))));
3148 Set_Return_Present (Defining_Unit_Name (New_Spec));
3152 end Build_Protected_Sub_Specification;
3154 -------------------------------------
3155 -- Build_Protected_Subprogram_Body --
3156 -------------------------------------
3158 function Build_Protected_Subprogram_Body
3161 N_Op_Spec : Node_Id) return Node_Id
3163 Loc : constant Source_Ptr := Sloc (N);
3165 P_Op_Spec : Node_Id;
3168 Unprot_Call : Node_Id;
3170 Lock_Name : Node_Id;
3171 Lock_Stmt : Node_Id;
3172 Service_Name : Node_Id;
3174 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
3175 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
3177 Object_Parm : Node_Id;
3180 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
3181 -- Tell whether a given subprogram cannot raise an exception
3183 -----------------------
3184 -- Is_Exception_Safe --
3185 -----------------------
3187 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
3189 function Has_Side_Effect (N : Node_Id) return Boolean;
3190 -- Return True whenever encountering a subprogram call or raise
3191 -- statement of any kind in the sequence of statements
3193 ---------------------
3194 -- Has_Side_Effect --
3195 ---------------------
3197 -- What is this doing buried two levels down in exp_ch9. It seems
3198 -- like a generally useful function, and indeed there may be code
3199 -- duplication going on here ???
3201 function Has_Side_Effect (N : Node_Id) return Boolean is
3205 function Is_Call_Or_Raise (N : Node_Id) return Boolean;
3206 -- Indicate whether N is a subprogram call or a raise statement
3208 ----------------------
3209 -- Is_Call_Or_Raise --
3210 ----------------------
3212 function Is_Call_Or_Raise (N : Node_Id) return Boolean is
3214 return Nkind_In (N, N_Procedure_Call_Statement,
3217 N_Raise_Constraint_Error,
3218 N_Raise_Program_Error,
3219 N_Raise_Storage_Error);
3220 end Is_Call_Or_Raise;
3222 -- Start of processing for Has_Side_Effect
3226 while Present (Stmt) loop
3227 if Is_Call_Or_Raise (Stmt) then
3231 -- An object declaration can also contain a function call
3232 -- or a raise statement
3234 if Nkind (Stmt) = N_Object_Declaration then
3235 Expr := Expression (Stmt);
3237 if Present (Expr) and then Is_Call_Or_Raise (Expr) then
3246 end Has_Side_Effect;
3248 -- Start of processing for Is_Exception_Safe
3251 -- If the checks handled by the back end are not disabled, we cannot
3252 -- ensure that no exception will be raised.
3254 if not Access_Checks_Suppressed (Empty)
3255 or else not Discriminant_Checks_Suppressed (Empty)
3256 or else not Range_Checks_Suppressed (Empty)
3257 or else not Index_Checks_Suppressed (Empty)
3258 or else Opt.Stack_Checking_Enabled
3263 if Has_Side_Effect (First (Declarations (Subprogram)))
3266 First (Statements (Handled_Statement_Sequence (Subprogram))))
3272 end Is_Exception_Safe;
3274 -- Start of processing for Build_Protected_Subprogram_Body
3277 Op_Spec := Specification (N);
3278 Exc_Safe := Is_Exception_Safe (N);
3281 Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
3283 -- Build a list of the formal parameters of the protected version of
3284 -- the subprogram to use as the actual parameters of the unprotected
3287 Uactuals := New_List;
3288 Pformal := First (Parameter_Specifications (P_Op_Spec));
3289 while Present (Pformal) loop
3290 Append_To (Uactuals,
3291 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
3295 -- Make a call to the unprotected version of the subprogram built above
3296 -- for use by the protected version built below.
3298 if Nkind (Op_Spec) = N_Function_Specification then
3300 R := Make_Temporary (Loc, 'R');
3302 Make_Object_Declaration (Loc,
3303 Defining_Identifier => R,
3304 Constant_Present => True,
3305 Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
3307 Make_Function_Call (Loc,
3308 Name => Make_Identifier (Loc,
3309 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
3310 Parameter_Associations => Uactuals));
3313 Make_Simple_Return_Statement (Loc,
3314 Expression => New_Reference_To (R, Loc));
3317 Unprot_Call := Make_Simple_Return_Statement (Loc,
3318 Expression => Make_Function_Call (Loc,
3320 Make_Identifier (Loc,
3321 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
3322 Parameter_Associations => Uactuals));
3327 Make_Procedure_Call_Statement (Loc,
3329 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
3330 Parameter_Associations => Uactuals);
3333 -- Wrap call in block that will be covered by an at_end handler
3335 if not Exc_Safe then
3336 Unprot_Call := Make_Block_Statement (Loc,
3337 Handled_Statement_Sequence =>
3338 Make_Handled_Sequence_Of_Statements (Loc,
3339 Statements => New_List (Unprot_Call)));
3342 -- Make the protected subprogram body. This locks the protected
3343 -- object and calls the unprotected version of the subprogram.
3345 case Corresponding_Runtime_Package (Pid) is
3346 when System_Tasking_Protected_Objects_Entries =>
3347 Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
3348 Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
3350 when System_Tasking_Protected_Objects_Single_Entry =>
3351 Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc);
3352 Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
3354 when System_Tasking_Protected_Objects =>
3355 Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
3356 Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
3359 raise Program_Error;
3363 Make_Attribute_Reference (Loc,
3365 Make_Selected_Component (Loc,
3366 Prefix => Make_Identifier (Loc, Name_uObject),
3367 Selector_Name => Make_Identifier (Loc, Name_uObject)),
3368 Attribute_Name => Name_Unchecked_Access);
3370 Lock_Stmt := Make_Procedure_Call_Statement (Loc,
3372 Parameter_Associations => New_List (Object_Parm));
3374 if Abort_Allowed then
3376 Make_Procedure_Call_Statement (Loc,
3377 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
3378 Parameter_Associations => Empty_List),
3382 Stmts := New_List (Lock_Stmt);
3385 if not Exc_Safe then
3386 Append (Unprot_Call, Stmts);
3388 if Nkind (Op_Spec) = N_Function_Specification then
3390 Stmts := Empty_List;
3392 Append (Unprot_Call, Stmts);
3396 Make_Procedure_Call_Statement (Loc,
3397 Name => Service_Name,
3398 Parameter_Associations =>
3399 New_List (New_Copy_Tree (Object_Parm))),
3402 if Abort_Allowed then
3404 Make_Procedure_Call_Statement (Loc,
3405 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
3406 Parameter_Associations => Empty_List),
3410 if Nkind (Op_Spec) = N_Function_Specification then
3411 Append (Return_Stmt, Stmts);
3412 Append (Make_Block_Statement (Loc,
3413 Declarations => New_List (Unprot_Call),
3414 Handled_Statement_Sequence =>
3415 Make_Handled_Sequence_Of_Statements (Loc,
3416 Statements => Stmts)), Pre_Stmts);
3422 Make_Subprogram_Body (Loc,
3423 Declarations => Empty_List,
3424 Specification => P_Op_Spec,
3425 Handled_Statement_Sequence =>
3426 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
3428 if not Exc_Safe then
3429 Set_Is_Protected_Subprogram_Body (Sub_Body);
3433 end Build_Protected_Subprogram_Body;
3435 -------------------------------------
3436 -- Build_Protected_Subprogram_Call --
3437 -------------------------------------
3439 procedure Build_Protected_Subprogram_Call
3443 External : Boolean := True)
3445 Loc : constant Source_Ptr := Sloc (N);
3446 Sub : constant Entity_Id := Entity (Name);
3452 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
3455 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
3458 if Present (Parameter_Associations (N)) then
3459 Params := New_Copy_List_Tree (Parameter_Associations (N));
3464 -- If the type is an untagged derived type, convert to the root type,
3465 -- which is the one on which the operations are defined.
3467 if Nkind (Rec) = N_Unchecked_Type_Conversion
3468 and then not Is_Tagged_Type (Etype (Rec))
3469 and then Is_Derived_Type (Etype (Rec))
3471 Set_Etype (Rec, Root_Type (Etype (Rec)));
3472 Set_Subtype_Mark (Rec,
3473 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
3476 Prepend (Rec, Params);
3478 if Ekind (Sub) = E_Procedure then
3480 Make_Procedure_Call_Statement (Loc,
3482 Parameter_Associations => Params));
3485 pragma Assert (Ekind (Sub) = E_Function);
3487 Make_Function_Call (Loc,
3489 Parameter_Associations => Params));
3493 and then Nkind (Rec) = N_Unchecked_Type_Conversion
3494 and then Is_Entity_Name (Expression (Rec))
3495 and then Is_Shared_Passive (Entity (Expression (Rec)))
3497 Add_Shared_Var_Lock_Procs (N);
3499 end Build_Protected_Subprogram_Call;
3501 -------------------------
3502 -- Build_Selected_Name --
3503 -------------------------
3505 function Build_Selected_Name
3506 (Prefix : Entity_Id;
3507 Selector : Entity_Id;
3508 Append_Char : Character := ' ') return Name_Id
3510 Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
3511 Select_Len : Natural;
3514 Get_Name_String (Chars (Selector));
3515 Select_Len := Name_Len;
3516 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
3517 Get_Name_String (Chars (Prefix));
3519 -- If scope is anonymous type, discard suffix to recover name of
3520 -- single protected object. Otherwise use protected type name.
3522 if Name_Buffer (Name_Len) = 'T' then
3523 Name_Len := Name_Len - 1;
3526 Add_Str_To_Name_Buffer ("__");
3527 for J in 1 .. Select_Len loop
3528 Add_Char_To_Name_Buffer (Select_Buffer (J));
3531 -- Now add the Append_Char if specified. The encoding to follow
3532 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
3533 -- then the entity is associated to a protected type subprogram.
3534 -- Otherwise, it is a protected type entry. For each case, the
3535 -- encoding to follow for the suffix is documented in exp_dbug.ads.
3537 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
3539 if Append_Char /= ' ' then
3540 if Append_Char = 'P' or Append_Char = 'N' then
3541 Add_Char_To_Name_Buffer (Append_Char);
3544 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
3545 return New_External_Name (Name_Find, ' ', -1);
3550 end Build_Selected_Name;
3552 -----------------------------
3553 -- Build_Simple_Entry_Call --
3554 -----------------------------
3556 -- A task entry call is converted to a call to Call_Simple
3559 -- P : parms := (parm, parm, parm);
3561 -- Call_Simple (acceptor-task, entry-index, P'Address);
3567 -- Here Pnn is an aggregate of the type constructed for the entry to hold
3568 -- the parameters, and the constructed aggregate value contains either the
3569 -- parameters or, in the case of non-elementary types, references to these
3570 -- parameters. Then the address of this aggregate is passed to the runtime
3571 -- routine, along with the task id value and the task entry index value.
3572 -- Pnn is only required if parameters are present.
3574 -- The assignments after the call are present only in the case of in-out
3575 -- or out parameters for elementary types, and are used to assign back the
3576 -- resulting values of such parameters.
3578 -- Note: the reason that we insert a block here is that in the context
3579 -- of selects, conditional entry calls etc. the entry call statement
3580 -- appears on its own, not as an element of a list.
3582 -- A protected entry call is converted to a Protected_Entry_Call:
3585 -- P : E1_Params := (param, param, param);
3587 -- Bnn : Communications_Block;
3590 -- P : E1_Params := (param, param, param);
3591 -- Bnn : Communications_Block;
3594 -- Protected_Entry_Call (
3595 -- Object => po._object'Access,
3596 -- E => <entry index>;
3597 -- Uninterpreted_Data => P'Address;
3598 -- Mode => Simple_Call;
3605 procedure Build_Simple_Entry_Call
3614 -- If call has been inlined, nothing left to do
3616 if Nkind (N) = N_Block_Statement then
3620 -- Convert entry call to Call_Simple call
3623 Loc : constant Source_Ptr := Sloc (N);
3624 Parms : constant List_Id := Parameter_Associations (N);
3625 Stats : constant List_Id := New_List;
3628 Comm_Name : Entity_Id;
3632 Ent_Acc : Entity_Id;
3634 Iface_Tag : Entity_Id;
3635 Iface_Typ : Entity_Id;
3648 -- Simple entry and entry family cases merge here
3650 Ent := Entity (Ename);
3651 Ent_Acc := Entry_Parameters_Type (Ent);
3652 Conctyp := Etype (Concval);
3654 -- If prefix is an access type, dereference to obtain the task type
3656 if Is_Access_Type (Conctyp) then
3657 Conctyp := Designated_Type (Conctyp);
3660 -- Special case for protected subprogram calls
3662 if Is_Protected_Type (Conctyp)
3663 and then Is_Subprogram (Entity (Ename))
3665 if not Is_Eliminated (Entity (Ename)) then
3666 Build_Protected_Subprogram_Call
3667 (N, Ename, Convert_Concurrent (Concval, Conctyp));
3674 -- First parameter is the Task_Id value from the task value or the
3675 -- Object from the protected object value, obtained by selecting
3676 -- the _Task_Id or _Object from the result of doing an unchecked
3677 -- conversion to convert the value to the corresponding record type.
3679 if Nkind (Concval) = N_Function_Call
3680 and then Is_Task_Type (Conctyp)
3681 and then Ada_Version >= Ada_2005
3684 ExpR : constant Node_Id := Relocate_Node (Concval);
3685 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR);
3690 Make_Object_Declaration (Loc,
3691 Defining_Identifier => Obj,
3692 Object_Definition => New_Occurrence_Of (Conctyp, Loc),
3693 Expression => ExpR);
3694 Set_Etype (Obj, Conctyp);
3695 Decls := New_List (Decl);
3696 Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
3703 Parm1 := Concurrent_Ref (Concval);
3705 -- Second parameter is the entry index, computed by the routine
3706 -- provided for this purpose. The value of this expression is
3707 -- assigned to an intermediate variable to assure that any entry
3708 -- family index expressions are evaluated before the entry
3712 or else Restriction_Active (No_Entry_Queue) = False
3713 or else not Is_Protected_Type (Conctyp)
3714 or else Number_Entries (Conctyp) > 1
3715 or else (Has_Attach_Handler (Conctyp)
3716 and then not Restricted_Profile)
3718 X := Make_Defining_Identifier (Loc, Name_uX);
3721 Make_Object_Declaration (Loc,
3722 Defining_Identifier => X,
3723 Object_Definition =>
3724 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3725 Expression => Actual_Index_Expression (
3726 Loc, Entity (Ename), Index, Concval));
3728 Append_To (Decls, Xdecl);
3729 Parm2 := New_Reference_To (X, Loc);
3736 -- The third parameter is the packaged parameters. If there are
3737 -- none, then it is just the null address, since nothing is passed.
3740 Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc);
3743 -- Case of parameters present, where third argument is the address
3744 -- of a packaged record containing the required parameter values.
3747 -- First build a list of parameter values, which are references to
3748 -- objects of the parameter types.
3752 Actual := First_Actual (N);
3753 Formal := First_Formal (Ent);
3755 while Present (Actual) loop
3757 -- If it is a by_copy_type, copy it to a new variable. The
3758 -- packaged record has a field that points to this variable.
3760 if Is_By_Copy_Type (Etype (Actual)) then
3762 Make_Object_Declaration (Loc,
3763 Defining_Identifier => Make_Temporary (Loc, 'J'),
3764 Aliased_Present => True,
3765 Object_Definition =>
3766 New_Reference_To (Etype (Formal), Loc));
3768 -- Mark the object as not needing initialization since the
3769 -- initialization is performed separately, avoiding errors
3770 -- on cases such as formals of null-excluding access types.
3772 Set_No_Initialization (N_Node);
3774 -- We must make an assignment statement separate for the
3775 -- case of limited type. We cannot assign it unless the
3776 -- Assignment_OK flag is set first. An out formal of an
3777 -- access type must also be initialized from the actual,
3778 -- as stated in RM 6.4.1 (13).
3780 if Ekind (Formal) /= E_Out_Parameter
3781 or else Is_Access_Type (Etype (Formal))
3784 New_Reference_To (Defining_Identifier (N_Node), Loc);
3785 Set_Assignment_OK (N_Var);
3787 Make_Assignment_Statement (Loc,
3789 Expression => Relocate_Node (Actual)));
3792 Append (N_Node, Decls);
3795 Make_Attribute_Reference (Loc,
3796 Attribute_Name => Name_Unchecked_Access,
3798 New_Reference_To (Defining_Identifier (N_Node), Loc)));
3800 -- Interface class-wide formal
3802 if Ada_Version >= Ada_2005
3803 and then Ekind (Etype (Formal)) = E_Class_Wide_Type
3804 and then Is_Interface (Etype (Formal))
3806 Iface_Typ := Etype (Etype (Formal));
3809 -- formal_iface_type! (actual.iface_tag)'reference
3812 Find_Interface_Tag (Etype (Actual), Iface_Typ);
3813 pragma Assert (Present (Iface_Tag));
3816 Make_Reference (Loc,
3817 Unchecked_Convert_To (Iface_Typ,
3818 Make_Selected_Component (Loc,
3820 Relocate_Node (Actual),
3822 New_Reference_To (Iface_Tag, Loc)))));
3828 Make_Reference (Loc, Relocate_Node (Actual)));
3832 Next_Actual (Actual);
3833 Next_Formal_With_Extras (Formal);
3836 -- Now build the declaration of parameters initialized with the
3837 -- aggregate containing this constructed parameter list.
3839 P := Make_Defining_Identifier (Loc, Name_uP);
3842 Make_Object_Declaration (Loc,
3843 Defining_Identifier => P,
3844 Object_Definition =>
3845 New_Reference_To (Designated_Type (Ent_Acc), Loc),
3847 Make_Aggregate (Loc, Expressions => Plist));
3850 Make_Attribute_Reference (Loc,
3851 Prefix => New_Reference_To (P, Loc),
3852 Attribute_Name => Name_Address);
3854 Append (Pdecl, Decls);
3857 -- Now we can create the call, case of protected type
3859 if Is_Protected_Type (Conctyp) then
3860 case Corresponding_Runtime_Package (Conctyp) is
3861 when System_Tasking_Protected_Objects_Entries =>
3863 -- Change the type of the index declaration
3865 Set_Object_Definition (Xdecl,
3866 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc));
3868 -- Some additional declarations for protected entry calls
3874 -- Bnn : Communications_Block;
3876 Comm_Name := Make_Temporary (Loc, 'B');
3879 Make_Object_Declaration (Loc,
3880 Defining_Identifier => Comm_Name,
3881 Object_Definition =>
3882 New_Reference_To (RTE (RE_Communication_Block), Loc)));
3884 -- Some additional statements for protected entry calls
3886 -- Protected_Entry_Call (
3887 -- Object => po._object'Access,
3888 -- E => <entry index>;
3889 -- Uninterpreted_Data => P'Address;
3890 -- Mode => Simple_Call;
3894 Make_Procedure_Call_Statement (Loc,
3896 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
3898 Parameter_Associations => New_List (
3899 Make_Attribute_Reference (Loc,
3900 Attribute_Name => Name_Unchecked_Access,
3904 New_Reference_To (RTE (RE_Simple_Call), Loc),
3905 New_Occurrence_Of (Comm_Name, Loc)));
3907 when System_Tasking_Protected_Objects_Single_Entry =>
3908 -- Protected_Single_Entry_Call (
3909 -- Object => po._object'Access,
3910 -- Uninterpreted_Data => P'Address;
3911 -- Mode => Simple_Call);
3914 Make_Procedure_Call_Statement (Loc,
3915 Name => New_Reference_To (
3916 RTE (RE_Protected_Single_Entry_Call), Loc),
3918 Parameter_Associations => New_List (
3919 Make_Attribute_Reference (Loc,
3920 Attribute_Name => Name_Unchecked_Access,
3923 New_Reference_To (RTE (RE_Simple_Call), Loc)));
3926 raise Program_Error;
3929 -- Case of task type
3933 Make_Procedure_Call_Statement (Loc,
3934 Name => New_Reference_To (RTE (RE_Call_Simple), Loc),
3935 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
3939 Append_To (Stats, Call);
3941 -- If there are out or in/out parameters by copy add assignment
3942 -- statements for the result values.
3944 if Present (Parms) then
3945 Actual := First_Actual (N);
3946 Formal := First_Formal (Ent);
3948 Set_Assignment_OK (Actual);
3949 while Present (Actual) loop
3950 if Is_By_Copy_Type (Etype (Actual))
3951 and then Ekind (Formal) /= E_In_Parameter
3954 Make_Assignment_Statement (Loc,
3955 Name => New_Copy (Actual),
3957 Make_Explicit_Dereference (Loc,
3958 Make_Selected_Component (Loc,
3959 Prefix => New_Reference_To (P, Loc),
3961 Make_Identifier (Loc, Chars (Formal)))));
3963 -- In all cases (including limited private types) we want
3964 -- the assignment to be valid.
3966 Set_Assignment_OK (Name (N_Node));
3968 -- If the call is the triggering alternative in an
3969 -- asynchronous select, or the entry_call alternative of a
3970 -- conditional entry call, the assignments for in-out
3971 -- parameters are incorporated into the statement list that
3972 -- follows, so that there are executed only if the entry
3975 if (Nkind (Parent (N)) = N_Triggering_Alternative
3976 and then N = Triggering_Statement (Parent (N)))
3978 (Nkind (Parent (N)) = N_Entry_Call_Alternative
3979 and then N = Entry_Call_Statement (Parent (N)))
3981 if No (Statements (Parent (N))) then
3982 Set_Statements (Parent (N), New_List);
3985 Prepend (N_Node, Statements (Parent (N)));
3988 Insert_After (Call, N_Node);
3992 Next_Actual (Actual);
3993 Next_Formal_With_Extras (Formal);
3997 -- Finally, create block and analyze it
4000 Make_Block_Statement (Loc,
4001 Declarations => Decls,
4002 Handled_Statement_Sequence =>
4003 Make_Handled_Sequence_Of_Statements (Loc,
4004 Statements => Stats)));
4008 end Build_Simple_Entry_Call;
4010 --------------------------------
4011 -- Build_Task_Activation_Call --
4012 --------------------------------
4014 procedure Build_Task_Activation_Call (N : Node_Id) is
4015 Loc : constant Source_Ptr := Sloc (N);
4022 -- Get the activation chain entity. Except in the case of a package
4023 -- body, this is in the node that was passed. For a package body, we
4024 -- have to find the corresponding package declaration node.
4026 if Nkind (N) = N_Package_Body then
4027 P := Corresponding_Spec (N);
4030 exit when Nkind (P) = N_Package_Declaration;
4033 Chain := Activation_Chain_Entity (P);
4036 Chain := Activation_Chain_Entity (N);
4039 if Present (Chain) then
4040 if Restricted_Profile then
4041 Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc);
4043 Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
4047 Make_Procedure_Call_Statement (Loc,
4049 Parameter_Associations =>
4050 New_List (Make_Attribute_Reference (Loc,
4051 Prefix => New_Occurrence_Of (Chain, Loc),
4052 Attribute_Name => Name_Unchecked_Access)));
4054 if Nkind (N) = N_Package_Declaration then
4055 if Present (Corresponding_Body (N)) then
4058 elsif Present (Private_Declarations (Specification (N))) then
4059 Append (Call, Private_Declarations (Specification (N)));
4062 Append (Call, Visible_Declarations (Specification (N)));
4066 if Present (Handled_Statement_Sequence (N)) then
4068 -- The call goes at the start of the statement sequence
4069 -- after the start of exception range label if one is present.
4075 Stm := First (Statements (Handled_Statement_Sequence (N)));
4077 -- A special case, skip exception range label if one is
4078 -- present (from front end zcx processing).
4080 if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
4084 -- Another special case, if the first statement is a block
4085 -- from optimization of a local raise to a goto, then the
4086 -- call goes inside this block.
4088 if Nkind (Stm) = N_Block_Statement
4089 and then Exception_Junk (Stm)
4092 First (Statements (Handled_Statement_Sequence (Stm)));
4095 -- Insertion point is after any exception label pushes,
4096 -- since we want it covered by any local handlers.
4098 while Nkind (Stm) in N_Push_xxx_Label loop
4102 -- Now we have the proper insertion point
4104 Insert_Before (Stm, Call);
4108 Set_Handled_Statement_Sequence (N,
4109 Make_Handled_Sequence_Of_Statements (Loc,
4110 Statements => New_List (Call)));
4115 Check_Task_Activation (N);
4117 end Build_Task_Activation_Call;
4119 -------------------------------
4120 -- Build_Task_Allocate_Block --
4121 -------------------------------
4123 procedure Build_Task_Allocate_Block
4128 T : constant Entity_Id := Entity (Expression (N));
4129 Init : constant Entity_Id := Base_Init_Proc (T);
4130 Loc : constant Source_Ptr := Sloc (N);
4131 Chain : constant Entity_Id :=
4132 Make_Defining_Identifier (Loc, Name_uChain);
4133 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
4138 Make_Block_Statement (Loc,
4139 Identifier => New_Reference_To (Blkent, Loc),
4140 Declarations => New_List (
4142 -- _Chain : Activation_Chain;
4144 Make_Object_Declaration (Loc,
4145 Defining_Identifier => Chain,
4146 Aliased_Present => True,
4147 Object_Definition =>
4148 New_Reference_To (RTE (RE_Activation_Chain), Loc))),
4150 Handled_Statement_Sequence =>
4151 Make_Handled_Sequence_Of_Statements (Loc,
4153 Statements => New_List (
4157 Make_Procedure_Call_Statement (Loc,
4158 Name => New_Reference_To (Init, Loc),
4159 Parameter_Associations => Args),
4161 -- Activate_Tasks (_Chain);
4163 Make_Procedure_Call_Statement (Loc,
4164 Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
4165 Parameter_Associations => New_List (
4166 Make_Attribute_Reference (Loc,
4167 Prefix => New_Reference_To (Chain, Loc),
4168 Attribute_Name => Name_Unchecked_Access))))),
4170 Has_Created_Identifier => True,
4171 Is_Task_Allocation_Block => True);
4174 Make_Implicit_Label_Declaration (Loc,
4175 Defining_Identifier => Blkent,
4176 Label_Construct => Block));
4178 Append_To (Actions, Block);
4180 Set_Activation_Chain_Entity (Block, Chain);
4181 end Build_Task_Allocate_Block;
4183 -----------------------------------------------
4184 -- Build_Task_Allocate_Block_With_Init_Stmts --
4185 -----------------------------------------------
4187 procedure Build_Task_Allocate_Block_With_Init_Stmts
4190 Init_Stmts : List_Id)
4192 Loc : constant Source_Ptr := Sloc (N);
4193 Chain : constant Entity_Id :=
4194 Make_Defining_Identifier (Loc, Name_uChain);
4195 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
4199 Append_To (Init_Stmts,
4200 Make_Procedure_Call_Statement (Loc,
4201 Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
4202 Parameter_Associations => New_List (
4203 Make_Attribute_Reference (Loc,
4204 Prefix => New_Reference_To (Chain, Loc),
4205 Attribute_Name => Name_Unchecked_Access))));
4208 Make_Block_Statement (Loc,
4209 Identifier => New_Reference_To (Blkent, Loc),
4210 Declarations => New_List (
4212 -- _Chain : Activation_Chain;
4214 Make_Object_Declaration (Loc,
4215 Defining_Identifier => Chain,
4216 Aliased_Present => True,
4217 Object_Definition =>
4218 New_Reference_To (RTE (RE_Activation_Chain), Loc))),
4220 Handled_Statement_Sequence =>
4221 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
4223 Has_Created_Identifier => True,
4224 Is_Task_Allocation_Block => True);
4227 Make_Implicit_Label_Declaration (Loc,
4228 Defining_Identifier => Blkent,
4229 Label_Construct => Block));
4231 Append_To (Actions, Block);
4233 Set_Activation_Chain_Entity (Block, Chain);
4234 end Build_Task_Allocate_Block_With_Init_Stmts;
4236 -----------------------------------
4237 -- Build_Task_Proc_Specification --
4238 -----------------------------------
4240 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
4241 Loc : constant Source_Ptr := Sloc (T);
4242 Spec_Id : Entity_Id;
4245 -- Case of explicit task type, suffix TB
4247 if Comes_From_Source (T) then
4249 Make_Defining_Identifier (Loc,
4250 Chars => New_External_Name (Chars (T), "TB"));
4252 -- Case of anonymous task type, suffix B
4256 Make_Defining_Identifier (Loc,
4257 Chars => New_External_Name (Chars (T), 'B'));
4260 Set_Is_Internal (Spec_Id);
4262 -- Associate the procedure with the task, if this is the declaration
4263 -- (and not the body) of the procedure.
4265 if No (Task_Body_Procedure (T)) then
4266 Set_Task_Body_Procedure (T, Spec_Id);
4270 Make_Procedure_Specification (Loc,
4271 Defining_Unit_Name => Spec_Id,
4272 Parameter_Specifications => New_List (
4273 Make_Parameter_Specification (Loc,
4274 Defining_Identifier =>
4275 Make_Defining_Identifier (Loc, Name_uTask),
4277 Make_Access_Definition (Loc,
4279 New_Reference_To (Corresponding_Record_Type (T), Loc)))));
4280 end Build_Task_Proc_Specification;
4282 ---------------------------------------
4283 -- Build_Unprotected_Subprogram_Body --
4284 ---------------------------------------
4286 function Build_Unprotected_Subprogram_Body
4288 Pid : Node_Id) return Node_Id
4290 Decls : constant List_Id := Declarations (N);
4293 -- Add renamings for the Protection object, discriminals, privals and
4294 -- the entry index constant for use by debugger.
4296 Debug_Private_Data_Declarations (Decls);
4298 -- Make an unprotected version of the subprogram for use within the same
4299 -- object, with a new name and an additional parameter representing the
4303 Make_Subprogram_Body (Sloc (N),
4305 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
4306 Declarations => Decls,
4307 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
4308 end Build_Unprotected_Subprogram_Body;
4310 ----------------------------
4311 -- Collect_Entry_Families --
4312 ----------------------------
4314 procedure Collect_Entry_Families
4317 Current_Node : in out Node_Id;
4318 Conctyp : Entity_Id)
4321 Efam_Decl : Node_Id;
4322 Efam_Type : Entity_Id;
4325 Efam := First_Entity (Conctyp);
4326 while Present (Efam) loop
4327 if Ekind (Efam) = E_Entry_Family then
4328 Efam_Type := Make_Temporary (Loc, 'F');
4333 (Etype (Discrete_Subtype_Definition (Parent (Efam))));
4335 Bas_Decl : Node_Id := Empty;
4340 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
4342 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
4343 Bas := Make_Temporary (Loc, 'B');
4346 Make_Subtype_Declaration (Loc,
4347 Defining_Identifier => Bas,
4348 Subtype_Indication =>
4349 Make_Subtype_Indication (Loc,
4351 New_Occurrence_Of (Standard_Integer, Loc),
4353 Make_Range_Constraint (Loc,
4354 Range_Expression => Make_Range (Loc,
4355 Make_Integer_Literal
4356 (Loc, -Entry_Family_Bound),
4357 Make_Integer_Literal
4358 (Loc, Entry_Family_Bound - 1)))));
4360 Insert_After (Current_Node, Bas_Decl);
4361 Current_Node := Bas_Decl;
4366 Make_Full_Type_Declaration (Loc,
4367 Defining_Identifier => Efam_Type,
4369 Make_Unconstrained_Array_Definition (Loc,
4371 (New_List (New_Occurrence_Of (Bas, Loc))),
4373 Component_Definition =>
4374 Make_Component_Definition (Loc,
4375 Aliased_Present => False,
4376 Subtype_Indication =>
4377 New_Reference_To (Standard_Character, Loc))));
4380 Insert_After (Current_Node, Efam_Decl);
4381 Current_Node := Efam_Decl;
4382 Analyze (Efam_Decl);
4385 Make_Component_Declaration (Loc,
4386 Defining_Identifier =>
4387 Make_Defining_Identifier (Loc, Chars (Efam)),
4389 Component_Definition =>
4390 Make_Component_Definition (Loc,
4391 Aliased_Present => False,
4392 Subtype_Indication =>
4393 Make_Subtype_Indication (Loc,
4395 New_Occurrence_Of (Efam_Type, Loc),
4398 Make_Index_Or_Discriminant_Constraint (Loc,
4399 Constraints => New_List (
4401 (Etype (Discrete_Subtype_Definition
4402 (Parent (Efam))), Loc)))))));
4408 end Collect_Entry_Families;
4410 -----------------------
4411 -- Concurrent_Object --
4412 -----------------------
4414 function Concurrent_Object
4415 (Spec_Id : Entity_Id;
4416 Conc_Typ : Entity_Id) return Entity_Id
4419 -- Parameter _O or _object
4421 if Is_Protected_Type (Conc_Typ) then
4422 return First_Formal (Protected_Body_Subprogram (Spec_Id));
4427 pragma Assert (Is_Task_Type (Conc_Typ));
4428 return First_Formal (Task_Body_Procedure (Conc_Typ));
4430 end Concurrent_Object;
4432 ----------------------
4433 -- Copy_Result_Type --
4434 ----------------------
4436 function Copy_Result_Type (Res : Node_Id) return Node_Id is
4437 New_Res : constant Node_Id := New_Copy_Tree (Res);
4442 -- If the result type is an access_to_subprogram, we must create
4443 -- new entities for its spec.
4445 if Nkind (New_Res) = N_Access_Definition
4446 and then Present (Access_To_Subprogram_Definition (New_Res))
4448 -- Provide new entities for the formals
4450 Par_Spec := First (Parameter_Specifications
4451 (Access_To_Subprogram_Definition (New_Res)));
4452 while Present (Par_Spec) loop
4453 Formal := Defining_Identifier (Par_Spec);
4454 Set_Defining_Identifier (Par_Spec,
4455 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
4461 end Copy_Result_Type;
4463 --------------------
4464 -- Concurrent_Ref --
4465 --------------------
4467 -- The expression returned for a reference to a concurrent object has the
4470 -- taskV!(name)._Task_Id
4474 -- objectV!(name)._Object
4476 -- for a protected object. For the case of an access to a concurrent
4477 -- object, there is an extra explicit dereference:
4479 -- taskV!(name.all)._Task_Id
4480 -- objectV!(name.all)._Object
4482 -- here taskV and objectV are the types for the associated records, which
4483 -- contain the required _Task_Id and _Object fields for tasks and protected
4484 -- objects, respectively.
4486 -- For the case of a task type name, the expression is
4490 -- i.e. a call to the Self function which returns precisely this Task_Id
4492 -- For the case of a protected type name, the expression is
4496 -- which is a renaming of the _object field of the current object
4497 -- record, passed into protected operations as a parameter.
4499 function Concurrent_Ref (N : Node_Id) return Node_Id is
4500 Loc : constant Source_Ptr := Sloc (N);
4501 Ntyp : constant Entity_Id := Etype (N);
4505 function Is_Current_Task (T : Entity_Id) return Boolean;
4506 -- Check whether the reference is to the immediately enclosing task
4507 -- type, or to an outer one (rare but legal).
4509 ---------------------
4510 -- Is_Current_Task --
4511 ---------------------
4513 function Is_Current_Task (T : Entity_Id) return Boolean is
4517 Scop := Current_Scope;
4518 while Present (Scop)
4519 and then Scop /= Standard_Standard
4525 elsif Is_Task_Type (Scop) then
4528 -- If this is a procedure nested within the task type, we must
4529 -- assume that it can be called from an inner task, and therefore
4530 -- cannot treat it as a local reference.
4532 elsif Is_Overloadable (Scop)
4533 and then In_Open_Scopes (T)
4538 Scop := Scope (Scop);
4542 -- We know that we are within the task body, so should have found it
4545 raise Program_Error;
4546 end Is_Current_Task;
4548 -- Start of processing for Concurrent_Ref
4551 if Is_Access_Type (Ntyp) then
4552 Dtyp := Designated_Type (Ntyp);
4554 if Is_Protected_Type (Dtyp) then
4555 Sel := Name_uObject;
4557 Sel := Name_uTask_Id;
4561 Make_Selected_Component (Loc,
4563 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
4564 Make_Explicit_Dereference (Loc, N)),
4565 Selector_Name => Make_Identifier (Loc, Sel));
4567 elsif Is_Entity_Name (N)
4568 and then Is_Concurrent_Type (Entity (N))
4570 if Is_Task_Type (Entity (N)) then
4572 if Is_Current_Task (Entity (N)) then
4574 Make_Function_Call (Loc,
4575 Name => New_Reference_To (RTE (RE_Self), Loc));
4580 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T');
4581 T_Body : constant Node_Id :=
4582 Parent (Corresponding_Body (Parent (Entity (N))));
4586 Make_Object_Declaration (Loc,
4587 Defining_Identifier => T_Self,
4588 Object_Definition =>
4589 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
4591 Make_Function_Call (Loc,
4592 Name => New_Reference_To (RTE (RE_Self), Loc)));
4593 Prepend (Decl, Declarations (T_Body));
4595 Set_Scope (T_Self, Entity (N));
4596 return New_Occurrence_Of (T_Self, Loc);
4601 pragma Assert (Is_Protected_Type (Entity (N)));
4604 New_Reference_To (Find_Protection_Object (Current_Scope), Loc);
4608 if Is_Protected_Type (Ntyp) then
4609 Sel := Name_uObject;
4611 elsif Is_Task_Type (Ntyp) then
4612 Sel := Name_uTask_Id;
4615 raise Program_Error;
4619 Make_Selected_Component (Loc,
4621 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
4623 Selector_Name => Make_Identifier (Loc, Sel));
4627 ------------------------
4628 -- Convert_Concurrent --
4629 ------------------------
4631 function Convert_Concurrent
4633 Typ : Entity_Id) return Node_Id
4636 if not Is_Concurrent_Type (Typ) then
4640 Unchecked_Convert_To
4641 (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
4643 end Convert_Concurrent;
4645 -------------------------------------
4646 -- Debug_Private_Data_Declarations --
4647 -------------------------------------
4649 procedure Debug_Private_Data_Declarations (Decls : List_Id) is
4650 Debug_Nod : Node_Id;
4654 Decl := First (Decls);
4655 while Present (Decl)
4656 and then not Comes_From_Source (Decl)
4658 -- Declaration for concurrent entity _object and its access type,
4659 -- along with the entry index subtype:
4660 -- type prot_typVP is access prot_typV;
4661 -- _object : prot_typVP := prot_typV (_O);
4662 -- subtype Jnn is <Type of Index> range Low .. High;
4664 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then
4665 Set_Debug_Info_Needed (Defining_Identifier (Decl));
4667 -- Declaration for the Protection object, discriminals, privals and
4668 -- entry index constant:
4669 -- conc_typR : protection_typ renames _object._object;
4670 -- discr_nameD : discr_typ renames _object.discr_name;
4671 -- discr_nameD : discr_typ renames _task.discr_name;
4672 -- prival_name : comp_typ renames _object.comp_name;
4673 -- J : constant Jnn :=
4674 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
4676 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
4677 Set_Debug_Info_Needed (Defining_Identifier (Decl));
4678 Debug_Nod := Debug_Renaming_Declaration (Decl);
4680 if Present (Debug_Nod) then
4681 Insert_After (Decl, Debug_Nod);
4687 end Debug_Private_Data_Declarations;
4689 ----------------------------
4690 -- Entry_Index_Expression --
4691 ----------------------------
4693 function Entry_Index_Expression
4697 Ttyp : Entity_Id) return Node_Id
4707 -- The queues of entries and entry families appear in textual order in
4708 -- the associated record. The entry index is computed as the sum of the
4709 -- number of queues for all entries that precede the designated one, to
4710 -- which is added the index expression, if this expression denotes a
4711 -- member of a family.
4713 -- The following is a place holder for the count of simple entries
4715 Num := Make_Integer_Literal (Sloc, 1);
4717 -- We construct an expression which is a series of addition operations.
4718 -- The first operand is the number of single entries that precede this
4719 -- one, the second operand is the index value relative to the start of
4720 -- the referenced family, and the remaining operands are the lengths of
4721 -- the entry families that precede this entry, i.e. the constructed
4724 -- number_simple_entries +
4725 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
4726 -- family'length + ...
4728 -- where index-value is the given index value, and s is the index
4729 -- subtype (we have to use pos because the subtype might be an
4730 -- enumeration type preventing direct subtraction). Note that the task
4731 -- entry array is one-indexed.
4733 -- The upper bound of the entry family may be a discriminant, so we
4734 -- retrieve the lower bound explicitly to compute offset, rather than
4735 -- using the index subtype which may mention a discriminant.
4737 if Present (Index) then
4738 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
4747 Make_Attribute_Reference (Sloc,
4748 Attribute_Name => Name_Pos,
4749 Prefix => New_Reference_To (Base_Type (S), Sloc),
4750 Expressions => New_List (Relocate_Node (Index))),
4758 -- Now add lengths of preceding entries and entry families
4760 Prev := First_Entity (Ttyp);
4762 while Chars (Prev) /= Chars (Ent)
4763 or else (Ekind (Prev) /= Ekind (Ent))
4764 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
4766 if Ekind (Prev) = E_Entry then
4767 Set_Intval (Num, Intval (Num) + 1);
4769 elsif Ekind (Prev) = E_Entry_Family then
4771 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
4772 Lo := Type_Low_Bound (S);
4773 Hi := Type_High_Bound (S);
4778 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
4780 -- Other components are anonymous types to be ignored
4790 end Entry_Index_Expression;
4792 ---------------------------
4793 -- Establish_Task_Master --
4794 ---------------------------
4796 procedure Establish_Task_Master (N : Node_Id) is
4799 if Restriction_Active (No_Task_Hierarchy) = False then
4800 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
4801 Prepend_To (Declarations (N), Call);
4804 end Establish_Task_Master;
4806 --------------------------------
4807 -- Expand_Accept_Declarations --
4808 --------------------------------
4810 -- Part of the expansion of an accept statement involves the creation of
4811 -- a declaration that can be referenced from the statement sequence of
4816 -- This declaration is inserted immediately before the accept statement
4817 -- and it is important that it be inserted before the statements of the
4818 -- statement sequence are analyzed. Thus it would be too late to create
4819 -- this declaration in the Expand_N_Accept_Statement routine, which is
4820 -- why there is a separate procedure to be called directly from Sem_Ch9.
4822 -- Ann is used to hold the address of the record containing the parameters
4823 -- (see Expand_N_Entry_Call for more details on how this record is built).
4824 -- References to the parameters do an unchecked conversion of this address
4825 -- to a pointer to the required record type, and then access the field that
4826 -- holds the value of the required parameter. The entity for the address
4827 -- variable is held as the top stack element (i.e. the last element) of the
4828 -- Accept_Address stack in the corresponding entry entity, and this element
4829 -- must be set in place before the statements are processed.
4831 -- The above description applies to the case of a stand alone accept
4832 -- statement, i.e. one not appearing as part of a select alternative.
4834 -- For the case of an accept that appears as part of a select alternative
4835 -- of a selective accept, we must still create the declaration right away,
4836 -- since Ann is needed immediately, but there is an important difference:
4838 -- The declaration is inserted before the selective accept, not before
4839 -- the accept statement (which is not part of a list anyway, and so would
4840 -- not accommodate inserted declarations)
4842 -- We only need one address variable for the entire selective accept. So
4843 -- the Ann declaration is created only for the first accept alternative,
4844 -- and subsequent accept alternatives reference the same Ann variable.
4846 -- We can distinguish the two cases by seeing whether the accept statement
4847 -- is part of a list. If not, then it must be in an accept alternative.
4849 -- To expand the requeue statement, a label is provided at the end of the
4850 -- accept statement or alternative of which it is a part, so that the
4851 -- statement can be skipped after the requeue is complete. This label is
4852 -- created here rather than during the expansion of the accept statement,
4853 -- because it will be needed by any requeue statements within the accept,
4854 -- which are expanded before the accept.
4856 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
4857 Loc : constant Source_Ptr := Sloc (N);
4858 Stats : constant Node_Id := Handled_Statement_Sequence (N);
4859 Ann : Entity_Id := Empty;
4867 if Expander_Active then
4869 -- If we have no handled statement sequence, we may need to build
4870 -- a dummy sequence consisting of a null statement. This can be
4871 -- skipped if the trivial accept optimization is permitted.
4873 if not Trivial_Accept_OK
4875 (No (Stats) or else Null_Statements (Statements (Stats)))
4877 Set_Handled_Statement_Sequence (N,
4878 Make_Handled_Sequence_Of_Statements (Loc,
4879 New_List (Make_Null_Statement (Loc))));
4882 -- Create and declare two labels to be placed at the end of the
4883 -- accept statement. The first label is used to allow requeues to
4884 -- skip the remainder of entry processing. The second label is used
4885 -- to skip the remainder of entry processing if the rendezvous
4886 -- completes in the middle of the accept body.
4888 if Present (Handled_Statement_Sequence (N)) then
4893 Ent := Make_Temporary (Loc, 'L');
4894 Lab_Id := New_Reference_To (Ent, Loc);
4895 Lab := Make_Label (Loc, Lab_Id);
4897 Make_Implicit_Label_Declaration (Loc,
4898 Defining_Identifier => Ent,
4899 Label_Construct => Lab);
4900 Append (Lab, Statements (Handled_Statement_Sequence (N)));
4902 Ent := Make_Temporary (Loc, 'L');
4903 Lab_Id := New_Reference_To (Ent, Loc);
4904 Lab := Make_Label (Loc, Lab_Id);
4906 Make_Implicit_Label_Declaration (Loc,
4907 Defining_Identifier => Ent,
4908 Label_Construct => Lab);
4909 Append (Lab, Statements (Handled_Statement_Sequence (N)));
4917 -- Case of stand alone accept statement
4919 if Is_List_Member (N) then
4921 if Present (Handled_Statement_Sequence (N)) then
4922 Ann := Make_Temporary (Loc, 'A');
4925 Make_Object_Declaration (Loc,
4926 Defining_Identifier => Ann,
4927 Object_Definition =>
4928 New_Reference_To (RTE (RE_Address), Loc));
4930 Insert_Before (N, Adecl);
4933 Insert_Before (N, Ldecl);
4936 Insert_Before (N, Ldecl2);
4940 -- Case of accept statement which is in an accept alternative
4944 Acc_Alt : constant Node_Id := Parent (N);
4945 Sel_Acc : constant Node_Id := Parent (Acc_Alt);
4949 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
4950 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
4952 -- ??? Consider a single label for select statements
4954 if Present (Handled_Statement_Sequence (N)) then
4956 Statements (Handled_Statement_Sequence (N)));
4960 Statements (Handled_Statement_Sequence (N)));
4964 -- Find first accept alternative of the selective accept. A
4965 -- valid selective accept must have at least one accept in it.
4967 Alt := First (Select_Alternatives (Sel_Acc));
4969 while Nkind (Alt) /= N_Accept_Alternative loop
4973 -- If we are the first accept statement, then we have to create
4974 -- the Ann variable, as for the stand alone case, except that
4975 -- it is inserted before the selective accept. Similarly, a
4976 -- label for requeue expansion must be declared.
4978 if N = Accept_Statement (Alt) then
4979 Ann := Make_Temporary (Loc, 'A');
4981 Make_Object_Declaration (Loc,
4982 Defining_Identifier => Ann,
4983 Object_Definition =>
4984 New_Reference_To (RTE (RE_Address), Loc));
4986 Insert_Before (Sel_Acc, Adecl);
4989 -- If we are not the first accept statement, then find the Ann
4990 -- variable allocated by the first accept and use it.
4994 Node (Last_Elmt (Accept_Address
4995 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
5000 -- Merge here with Ann either created or referenced, and Adecl
5001 -- pointing to the corresponding declaration. Remaining processing
5002 -- is the same for the two cases.
5004 if Present (Ann) then
5005 Append_Elmt (Ann, Accept_Address (Ent));
5006 Set_Debug_Info_Needed (Ann);
5009 -- Create renaming declarations for the entry formals. Each reference
5010 -- to a formal becomes a dereference of a component of the parameter
5011 -- block, whose address is held in Ann. These declarations are
5012 -- eventually inserted into the accept block, and analyzed there so
5013 -- that they have the proper scope for gdb and do not conflict with
5014 -- other declarations.
5016 if Present (Parameter_Specifications (N))
5017 and then Present (Handled_Statement_Sequence (N))
5024 Renamed_Formal : Node_Id;
5028 Formal := First_Formal (Ent);
5030 while Present (Formal) loop
5031 Comp := Entry_Component (Formal);
5033 Make_Defining_Identifier (Loc, Chars (Formal));
5035 Set_Etype (New_F, Etype (Formal));
5036 Set_Scope (New_F, Ent);
5038 -- Now we set debug info needed on New_F even though it does
5039 -- not come from source, so that the debugger will get the
5040 -- right information for these generated names.
5042 Set_Debug_Info_Needed (New_F);
5044 if Ekind (Formal) = E_In_Parameter then
5045 Set_Ekind (New_F, E_Constant);
5047 Set_Ekind (New_F, E_Variable);
5048 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
5051 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
5054 Make_Selected_Component (Loc,
5056 Unchecked_Convert_To (
5057 Entry_Parameters_Type (Ent),
5058 New_Reference_To (Ann, Loc)),
5060 New_Reference_To (Comp, Loc));
5063 Build_Renamed_Formal_Declaration
5064 (New_F, Formal, Comp, Renamed_Formal);
5066 if No (Declarations (N)) then
5067 Set_Declarations (N, New_List);
5070 Append (Decl, Declarations (N));
5071 Set_Renamed_Object (Formal, New_F);
5072 Next_Formal (Formal);
5079 end Expand_Accept_Declarations;
5081 ---------------------------------------------
5082 -- Expand_Access_Protected_Subprogram_Type --
5083 ---------------------------------------------
5085 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
5086 Loc : constant Source_Ptr := Sloc (N);
5088 T : constant Entity_Id := Defining_Identifier (N);
5089 D_T : constant Entity_Id := Designated_Type (T);
5090 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D');
5091 E_T : constant Entity_Id := Make_Temporary (Loc, 'E');
5092 P_List : constant List_Id := Build_Protected_Spec
5093 (N, RTE (RE_Address), D_T, False);
5099 -- Create access to subprogram with full signature
5101 if Etype (D_T) /= Standard_Void_Type then
5103 Make_Access_Function_Definition (Loc,
5104 Parameter_Specifications => P_List,
5105 Result_Definition =>
5106 Copy_Result_Type (Result_Definition (Type_Definition (N))));
5110 Make_Access_Procedure_Definition (Loc,
5111 Parameter_Specifications => P_List);
5115 Make_Full_Type_Declaration (Loc,
5116 Defining_Identifier => D_T2,
5117 Type_Definition => Def1);
5119 Insert_After (N, Decl1);
5122 -- Associate the access to subprogram with its original access to
5123 -- protected subprogram type. Needed by the backend to know that this
5124 -- type corresponds with an access to protected subprogram type.
5126 Set_Original_Access_Type (D_T2, T);
5128 -- Create Equivalent_Type, a record with two components for an access to
5129 -- object and an access to subprogram.
5132 Make_Component_Declaration (Loc,
5133 Defining_Identifier => Make_Temporary (Loc, 'P'),
5134 Component_Definition =>
5135 Make_Component_Definition (Loc,
5136 Aliased_Present => False,
5137 Subtype_Indication =>
5138 New_Occurrence_Of (RTE (RE_Address), Loc))),
5140 Make_Component_Declaration (Loc,
5141 Defining_Identifier => Make_Temporary (Loc, 'S'),
5142 Component_Definition =>
5143 Make_Component_Definition (Loc,
5144 Aliased_Present => False,
5145 Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
5148 Make_Full_Type_Declaration (Loc,
5149 Defining_Identifier => E_T,
5151 Make_Record_Definition (Loc,
5153 Make_Component_List (Loc,
5154 Component_Items => Comps)));
5156 Insert_After (Decl1, Decl2);
5158 Set_Equivalent_Type (T, E_T);
5159 end Expand_Access_Protected_Subprogram_Type;
5161 --------------------------
5162 -- Expand_Entry_Barrier --
5163 --------------------------
5165 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
5166 Cond : constant Node_Id :=
5167 Condition (Entry_Body_Formal_Part (N));
5168 Prot : constant Entity_Id := Scope (Ent);
5169 Spec_Decl : constant Node_Id := Parent (Prot);
5172 Body_Decl : Node_Id;
5175 if No_Run_Time_Mode then
5176 Error_Msg_CRT ("entry barrier", N);
5180 -- The body of the entry barrier must be analyzed in the context of the
5181 -- protected object, but its scope is external to it, just as any other
5182 -- unprotected version of a protected operation. The specification has
5183 -- been produced when the protected type declaration was elaborated. We
5184 -- build the body, insert it in the enclosing scope, but analyze it in
5185 -- the current context. A more uniform approach would be to treat the
5186 -- barrier just as a protected function, and discard the protected
5187 -- version of it because it is never called.
5189 if Expander_Active then
5190 B_F := Build_Barrier_Function (N, Ent, Prot);
5191 Func := Barrier_Function (Ent);
5192 Set_Corresponding_Spec (B_F, Func);
5194 Body_Decl := Parent (Corresponding_Body (Spec_Decl));
5196 if Nkind (Parent (Body_Decl)) = N_Subunit then
5197 Body_Decl := Corresponding_Stub (Parent (Body_Decl));
5200 Insert_Before_And_Analyze (Body_Decl, B_F);
5202 Set_Discriminals (Spec_Decl);
5203 Set_Scope (Func, Scope (Prot));
5206 Analyze_And_Resolve (Cond, Any_Boolean);
5209 -- The Ravenscar profile restricts barriers to simple variables declared
5210 -- within the protected object. We also allow Boolean constants, since
5211 -- these appear in several published examples and are also allowed by
5212 -- the Aonix compiler.
5214 -- Note that after analysis variables in this context will be replaced
5215 -- by the corresponding prival, that is to say a renaming of a selected
5216 -- component of the form _Object.Var. If expansion is disabled, as
5217 -- within a generic, we check that the entity appears in the current
5220 if Is_Entity_Name (Cond) then
5222 -- A small optimization of useless renamings. If the scope of the
5223 -- entity of the condition is not the barrier function, then the
5224 -- condition does not reference any of the generated renamings
5225 -- within the function.
5228 and then Scope (Entity (Cond)) /= Func
5230 Set_Declarations (B_F, Empty_List);
5233 if Entity (Cond) = Standard_False
5235 Entity (Cond) = Standard_True
5239 elsif not Expander_Active
5240 and then Scope (Entity (Cond)) = Current_Scope
5244 -- Check for case of _object.all.field (note that the explicit
5245 -- dereference gets inserted by analyze/expand of _object.field)
5247 elsif Present (Renamed_Object (Entity (Cond)))
5249 Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component
5253 (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject
5259 -- It is not a boolean variable or literal, so check the restriction
5261 Check_Restriction (Simple_Barriers, Cond);
5262 end Expand_Entry_Barrier;
5264 ------------------------------
5265 -- Expand_N_Abort_Statement --
5266 ------------------------------
5268 -- Expand abort T1, T2, .. Tn; into:
5269 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
5271 procedure Expand_N_Abort_Statement (N : Node_Id) is
5272 Loc : constant Source_Ptr := Sloc (N);
5273 Tlist : constant List_Id := Names (N);
5279 Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
5282 Tasknm := First (Tlist);
5284 while Present (Tasknm) loop
5287 -- A task interface class-wide type object is being aborted.
5288 -- Retrieve its _task_id by calling a dispatching routine.
5290 if Ada_Version >= Ada_2005
5291 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
5292 and then Is_Interface (Etype (Tasknm))
5293 and then Is_Task_Interface (Etype (Tasknm))
5295 Append_To (Component_Associations (Aggr),
5296 Make_Component_Association (Loc,
5297 Choices => New_List (
5298 Make_Integer_Literal (Loc, Count)),
5301 -- Task_Id (Tasknm._disp_get_task_id)
5303 Make_Unchecked_Type_Conversion (Loc,
5305 New_Reference_To (RTE (RO_ST_Task_Id), Loc),
5307 Make_Selected_Component (Loc,
5308 Prefix => New_Copy_Tree (Tasknm),
5310 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
5313 Append_To (Component_Associations (Aggr),
5314 Make_Component_Association (Loc,
5315 Choices => New_List (
5316 Make_Integer_Literal (Loc, Count)),
5317 Expression => Concurrent_Ref (Tasknm)));
5324 Make_Procedure_Call_Statement (Loc,
5325 Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc),
5326 Parameter_Associations => New_List (
5327 Make_Qualified_Expression (Loc,
5328 Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc),
5329 Expression => Aggr))));
5332 end Expand_N_Abort_Statement;
5334 -------------------------------
5335 -- Expand_N_Accept_Statement --
5336 -------------------------------
5338 -- This procedure handles expansion of accept statements that stand
5339 -- alone, i.e. they are not part of an accept alternative. The expansion
5340 -- of accept statement in accept alternatives is handled by the routines
5341 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
5342 -- following description applies only to stand alone accept statements.
5344 -- If there is no handled statement sequence, or only null statements,
5345 -- then this is called a trivial accept, and the expansion is:
5347 -- Accept_Trivial (entry-index)
5349 -- If there is a handled statement sequence, then the expansion is:
5356 -- Accept_Call (entry-index, Ann);
5357 -- Renaming_Declarations for formals
5358 -- <statement sequence from N_Accept_Statement node>
5359 -- Complete_Rendezvous;
5364 -- <exception handler from N_Accept_Statement node>
5365 -- Complete_Rendezvous;
5367 -- <exception handler from N_Accept_Statement node>
5368 -- Complete_Rendezvous;
5373 -- when all others =>
5374 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
5377 -- The first three declarations were already inserted ahead of the accept
5378 -- statement by the Expand_Accept_Declarations procedure, which was called
5379 -- directly from the semantics during analysis of the accept statement,
5380 -- before analyzing its contained statements.
5382 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
5383 -- from possible expansion activity (the original source of course does
5384 -- not have any declarations associated with the accept statement, since
5385 -- an accept statement has no declarative part). In particular, if the
5386 -- expander is active, the first such declaration is the declaration of
5387 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
5389 -- The two blocks are merged into a single block if the inner block has
5390 -- no exception handlers, but otherwise two blocks are required, since
5391 -- exceptions might be raised in the exception handlers of the inner
5392 -- block, and Exceptional_Complete_Rendezvous must be called.
5394 procedure Expand_N_Accept_Statement (N : Node_Id) is
5395 Loc : constant Source_Ptr := Sloc (N);
5396 Stats : constant Node_Id := Handled_Statement_Sequence (N);
5397 Ename : constant Node_Id := Entry_Direct_Name (N);
5398 Eindx : constant Node_Id := Entry_Index (N);
5399 Eent : constant Entity_Id := Entity (Ename);
5400 Acstack : constant Elist_Id := Accept_Address (Eent);
5401 Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
5402 Ttyp : constant Entity_Id := Etype (Scope (Eent));
5407 -- Start of processing for Expand_N_Accept_Statement
5410 -- If accept statement is not part of a list, then its parent must be
5411 -- an accept alternative, and, as described above, we do not do any
5412 -- expansion for such accept statements at this level.
5414 if not Is_List_Member (N) then
5415 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
5418 -- Trivial accept case (no statement sequence, or null statements).
5419 -- If the accept statement has declarations, then just insert them
5420 -- before the procedure call.
5422 elsif Trivial_Accept_OK
5423 and then (No (Stats) or else Null_Statements (Statements (Stats)))
5425 -- Remove declarations for renamings, because the parameter block
5426 -- will not be assigned.
5433 D := First (Declarations (N));
5435 while Present (D) loop
5437 if Nkind (D) = N_Object_Renaming_Declaration then
5445 if Present (Declarations (N)) then
5446 Insert_Actions (N, Declarations (N));
5450 Make_Procedure_Call_Statement (Loc,
5451 Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc),
5452 Parameter_Associations => New_List (
5453 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
5457 -- Discard Entry_Address that was created for it, so it will not be
5458 -- emitted if this accept statement is in the statement part of a
5459 -- delay alternative.
5461 if Present (Stats) then
5462 Remove_Last_Elmt (Acstack);
5465 -- Case of statement sequence present
5468 -- Construct the block, using the declarations from the accept
5469 -- statement if any to initialize the declarations of the block.
5471 Blkent := Make_Temporary (Loc, 'A');
5472 Set_Ekind (Blkent, E_Block);
5473 Set_Etype (Blkent, Standard_Void_Type);
5474 Set_Scope (Blkent, Current_Scope);
5477 Make_Block_Statement (Loc,
5478 Identifier => New_Reference_To (Blkent, Loc),
5479 Declarations => Declarations (N),
5480 Handled_Statement_Sequence => Build_Accept_Body (N));
5482 -- For the analysis of the generated declarations, the parent node
5483 -- must be properly set.
5485 Set_Parent (Block, Parent (N));
5487 -- Prepend call to Accept_Call to main statement sequence If the
5488 -- accept has exception handlers, the statement sequence is wrapped
5489 -- in a block. Insert call and renaming declarations in the
5490 -- declarations of the block, so they are elaborated before the
5494 Make_Procedure_Call_Statement (Loc,
5495 Name => New_Reference_To (RTE (RE_Accept_Call), Loc),
5496 Parameter_Associations => New_List (
5497 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
5498 New_Reference_To (Ann, Loc)));
5500 if Parent (Stats) = N then
5501 Prepend (Call, Statements (Stats));
5510 Push_Scope (Blkent);
5518 D := First (Declarations (N));
5519 while Present (D) loop
5522 if Nkind (D) = N_Object_Renaming_Declaration then
5524 -- The renaming declarations for the formals were created
5525 -- during analysis of the accept statement, and attached to
5526 -- the list of declarations. Place them now in the context
5527 -- of the accept block or subprogram.
5530 Typ := Entity (Subtype_Mark (D));
5531 Insert_After (Call, D);
5534 -- If the formal is class_wide, it does not have an actual
5535 -- subtype. The analysis of the renaming declaration creates
5536 -- one, but we need to retain the class-wide nature of the
5539 if Is_Class_Wide_Type (Typ) then
5540 Set_Etype (Defining_Identifier (D), Typ);
5551 -- Replace the accept statement by the new block
5556 -- Last step is to unstack the Accept_Address value
5558 Remove_Last_Elmt (Acstack);
5560 end Expand_N_Accept_Statement;
5562 ----------------------------------
5563 -- Expand_N_Asynchronous_Select --
5564 ----------------------------------
5566 -- This procedure assumes that the trigger statement is an entry call or
5567 -- a dispatching procedure call. A delay alternative should already have
5568 -- been expanded into an entry call to the appropriate delay object Wait
5571 -- If the trigger is a task entry call, the select is implemented with
5572 -- a Task_Entry_Call:
5577 -- P : parms := (parm, parm, parm);
5579 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5581 -- procedure _clean is
5584 -- Cancel_Task_Entry_Call (C);
5591 -- (<acceptor-task>, -- Acceptor
5592 -- <entry-index>, -- E
5593 -- P'Address, -- Uninterpreted_Data
5594 -- Asynchronous_Call, -- Mode
5595 -- B); -- Rendezvous_Successful
5602 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5605 -- when Abort_Signal => Abort_Undefer;
5612 -- <triggered-statements>
5616 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
5617 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
5621 -- P : parms := (parm, parm, parm);
5623 -- Call_Simple (acceptor-task, entry-index, P'Address);
5629 -- so the task at hand is to convert the latter expansion into the former
5631 -- If the trigger is a protected entry call, the select is implemented
5632 -- with Protected_Entry_Call:
5635 -- P : E1_Params := (param, param, param);
5636 -- Bnn : Communications_Block;
5641 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5643 -- procedure _clean is
5646 -- if Enqueued (Bnn) then
5647 -- Cancel_Protected_Entry_Call (Bnn);
5654 -- Protected_Entry_Call
5655 -- (po._object'Access, -- Object
5656 -- <entry index>, -- E
5657 -- P'Address, -- Uninterpreted_Data
5658 -- Asynchronous_Call, -- Mode
5661 -- if Enqueued (Bnn) then
5665 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5668 -- when Abort_Signal => Abort_Undefer;
5671 -- if not Cancelled (Bnn) then
5672 -- <triggered-statements>
5676 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
5680 -- P : E1_Params := (param, param, param);
5681 -- Bnn : Communications_Block;
5684 -- Protected_Entry_Call
5685 -- (po._object'Access, -- Object
5686 -- <entry index>, -- E
5687 -- P'Address, -- Uninterpreted_Data
5688 -- Simple_Call, -- Mode
5695 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
5699 -- B : Boolean := False;
5700 -- Bnn : Communication_Block;
5701 -- C : Ada.Tags.Prim_Op_Kind;
5702 -- D : System.Storage_Elements.Dummy_Communication_Block;
5703 -- K : Ada.Tags.Tagged_Kind :=
5704 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5705 -- P : Parameters := (Param1 .. ParamN);
5710 -- if K = Ada.Tags.TK_Limited_Tagged then
5711 -- <dispatching-call>;
5712 -- <triggering-statements>;
5716 -- Ada.Tags.Get_Offset_Index
5717 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
5719 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
5721 -- if C = POK_Protected_Entry then
5723 -- procedure _clean is
5725 -- if Enqueued (Bnn) then
5726 -- Cancel_Protected_Entry_Call (Bnn);
5732 -- _Disp_Asynchronous_Select
5733 -- (<object>, S, P'Address, D, B);
5734 -- Bnn := Communication_Block (D);
5736 -- Param1 := P.Param1;
5738 -- ParamN := P.ParamN;
5740 -- if Enqueued (Bnn) then
5741 -- <abortable-statements>
5744 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5747 -- when Abort_Signal => Abort_Undefer;
5750 -- if not Cancelled (Bnn) then
5751 -- <triggering-statements>
5754 -- elsif C = POK_Task_Entry then
5756 -- procedure _clean is
5758 -- Cancel_Task_Entry_Call (U);
5764 -- _Disp_Asynchronous_Select
5765 -- (<object>, S, P'Address, D, B);
5766 -- Bnn := Communication_Bloc (D);
5768 -- Param1 := P.Param1;
5770 -- ParamN := P.ParamN;
5775 -- <abortable-statements>
5777 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5780 -- when Abort_Signal => Abort_Undefer;
5784 -- <triggering-statements>
5789 -- <dispatching-call>;
5790 -- <triggering-statements>
5795 -- The job is to convert this to the asynchronous form
5797 -- If the trigger is a delay statement, it will have been expanded into a
5798 -- call to one of the GNARL delay procedures. This routine will convert
5799 -- this into a protected entry call on a delay object and then continue
5800 -- processing as for a protected entry call trigger. This requires
5801 -- declaring a Delay_Block object and adding a pointer to this object to
5802 -- the parameter list of the delay procedure to form the parameter list of
5803 -- the entry call. This object is used by the runtime to queue the delay
5806 -- For a description of the use of P and the assignments after the call,
5807 -- see Expand_N_Entry_Call_Statement.
5809 procedure Expand_N_Asynchronous_Select (N : Node_Id) is
5810 Loc : constant Source_Ptr := Sloc (N);
5811 Abrt : constant Node_Id := Abortable_Part (N);
5812 Astats : constant List_Id := Statements (Abrt);
5813 Trig : constant Node_Id := Triggering_Alternative (N);
5814 Tstats : constant List_Id := Statements (Trig);
5816 Abort_Block_Ent : Entity_Id;
5817 Abortable_Block : Node_Id;
5819 Blk_Ent : Entity_Id;
5820 Blk_Typ : Entity_Id;
5822 Call_Ent : Entity_Id;
5823 Cancel_Param : Entity_Id;
5824 Cleanup_Block : Node_Id;
5825 Cleanup_Block_Ent : Entity_Id;
5826 Cleanup_Stmts : List_Id;
5827 Conc_Typ_Stmts : List_Id;
5829 Dblock_Ent : Entity_Id;
5834 Enqueue_Call : Node_Id;
5838 Lim_Typ_Stmts : List_Id;
5844 ProtE_Stmts : List_Id;
5845 ProtP_Stmts : List_Id;
5848 Target_Undefer : RE_Id;
5849 TaskE_Stmts : List_Id;
5850 Undefer_Args : List_Id := No_List;
5852 B : Entity_Id; -- Call status flag
5853 Bnn : Entity_Id; -- Communication block
5854 C : Entity_Id; -- Call kind
5855 K : Entity_Id; -- Tagged kind
5856 P : Entity_Id; -- Parameter block
5857 S : Entity_Id; -- Primitive operation slot
5858 T : Entity_Id; -- Additional status flag
5861 Blk_Ent := Make_Temporary (Loc, 'A');
5862 Ecall := Triggering_Statement (Trig);
5864 -- The arguments in the call may require dynamic allocation, and the
5865 -- call statement may have been transformed into a block. The block
5866 -- may contain additional declarations for internal entities, and the
5867 -- original call is found by sequential search.
5869 if Nkind (Ecall) = N_Block_Statement then
5870 Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
5871 while not Nkind_In (Ecall, N_Procedure_Call_Statement,
5872 N_Entry_Call_Statement)
5878 -- This is either a dispatching call or a delay statement used as a
5879 -- trigger which was expanded into a procedure call.
5881 if Nkind (Ecall) = N_Procedure_Call_Statement then
5882 if Ada_Version >= Ada_2005
5884 (No (Original_Node (Ecall))
5885 or else not Nkind_In (Original_Node (Ecall),
5886 N_Delay_Relative_Statement,
5887 N_Delay_Until_Statement))
5889 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
5894 -- Call status flag processing, generate:
5895 -- B : Boolean := False;
5897 B := Build_B (Loc, Decls);
5899 -- Communication block processing, generate:
5900 -- Bnn : Communication_Block;
5902 Bnn := Make_Temporary (Loc, 'B');
5904 Make_Object_Declaration (Loc,
5905 Defining_Identifier => Bnn,
5906 Object_Definition =>
5907 New_Reference_To (RTE (RE_Communication_Block), Loc)));
5909 -- Call kind processing, generate:
5910 -- C : Ada.Tags.Prim_Op_Kind;
5912 C := Build_C (Loc, Decls);
5914 -- Tagged kind processing, generate:
5915 -- K : Ada.Tags.Tagged_Kind :=
5916 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5918 -- Dummy communication block, generate:
5919 -- D : Dummy_Communication_Block;
5922 Make_Object_Declaration (Loc,
5923 Defining_Identifier =>
5924 Make_Defining_Identifier (Loc, Name_uD),
5925 Object_Definition =>
5927 RTE (RE_Dummy_Communication_Block), Loc)));
5929 K := Build_K (Loc, Decls, Obj);
5931 -- Parameter block processing
5933 Blk_Typ := Build_Parameter_Block
5934 (Loc, Actuals, Formals, Decls);
5935 P := Parameter_Block_Pack
5936 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
5938 -- Dispatch table slot processing, generate:
5941 S := Build_S (Loc, Decls);
5943 -- Additional status flag processing, generate:
5946 T := Make_Temporary (Loc, 'T');
5948 Make_Object_Declaration (Loc,
5949 Defining_Identifier => T,
5950 Object_Definition =>
5951 New_Reference_To (Standard_Boolean, Loc)));
5953 ------------------------------
5954 -- Protected entry handling --
5955 ------------------------------
5958 -- Param1 := P.Param1;
5960 -- ParamN := P.ParamN;
5962 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
5965 -- Bnn := Communication_Block (D);
5967 Prepend_To (Cleanup_Stmts,
5968 Make_Assignment_Statement (Loc,
5970 New_Reference_To (Bnn, Loc),
5972 Make_Unchecked_Type_Conversion (Loc,
5974 New_Reference_To (RTE (RE_Communication_Block), Loc),
5975 Expression => Make_Identifier (Loc, Name_uD))));
5978 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
5980 Prepend_To (Cleanup_Stmts,
5981 Make_Procedure_Call_Statement (Loc,
5984 Find_Prim_Op (Etype (Etype (Obj)),
5985 Name_uDisp_Asynchronous_Select),
5987 Parameter_Associations =>
5989 New_Copy_Tree (Obj), -- <object>
5990 New_Reference_To (S, Loc), -- S
5991 Make_Attribute_Reference (Loc, -- P'Address
5993 New_Reference_To (P, Loc),
5996 Make_Identifier (Loc, Name_uD), -- D
5997 New_Reference_To (B, Loc)))); -- B
6000 -- if Enqueued (Bnn) then
6001 -- <abortable-statements>
6004 Append_To (Cleanup_Stmts,
6005 Make_If_Statement (Loc,
6007 Make_Function_Call (Loc,
6009 New_Reference_To (RTE (RE_Enqueued), Loc),
6010 Parameter_Associations =>
6012 New_Reference_To (Bnn, Loc))),
6015 New_Copy_List_Tree (Astats)));
6017 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
6018 -- will then generate a _clean for the communication block Bnn.
6022 -- procedure _clean is
6024 -- if Enqueued (Bnn) then
6025 -- Cancel_Protected_Entry_Call (Bnn);
6034 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
6036 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
6038 -- Wrap the cleanup block in an exception handling block
6044 -- when Abort_Signal => Abort_Undefer;
6047 Abort_Block_Ent := Make_Temporary (Loc, 'A');
6050 Make_Implicit_Label_Declaration (Loc,
6051 Defining_Identifier =>
6055 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
6058 -- if not Cancelled (Bnn) then
6059 -- <triggering-statements>
6062 Append_To (ProtE_Stmts,
6063 Make_If_Statement (Loc,
6067 Make_Function_Call (Loc,
6069 New_Reference_To (RTE (RE_Cancelled), Loc),
6070 Parameter_Associations =>
6072 New_Reference_To (Bnn, Loc)))),
6075 New_Copy_List_Tree (Tstats)));
6077 -------------------------
6078 -- Task entry handling --
6079 -------------------------
6082 -- Param1 := P.Param1;
6084 -- ParamN := P.ParamN;
6086 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
6089 -- Bnn := Communication_Block (D);
6091 Append_To (TaskE_Stmts,
6092 Make_Assignment_Statement (Loc,
6094 New_Reference_To (Bnn, Loc),
6096 Make_Unchecked_Type_Conversion (Loc,
6098 New_Reference_To (RTE (RE_Communication_Block), Loc),
6099 Expression => Make_Identifier (Loc, Name_uD))));
6102 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
6104 Prepend_To (TaskE_Stmts,
6105 Make_Procedure_Call_Statement (Loc,
6108 Find_Prim_Op (Etype (Etype (Obj)),
6109 Name_uDisp_Asynchronous_Select),
6111 Parameter_Associations =>
6113 New_Copy_Tree (Obj), -- <object>
6114 New_Reference_To (S, Loc), -- S
6115 Make_Attribute_Reference (Loc, -- P'Address
6117 New_Reference_To (P, Loc),
6120 Make_Identifier (Loc, Name_uD), -- D
6121 New_Reference_To (B, Loc)))); -- B
6126 Prepend_To (TaskE_Stmts,
6127 Make_Procedure_Call_Statement (Loc,
6129 New_Reference_To (RTE (RE_Abort_Defer), Loc),
6130 Parameter_Associations =>
6135 -- <abortable-statements>
6137 Cleanup_Stmts := New_Copy_List_Tree (Astats);
6139 Prepend_To (Cleanup_Stmts,
6140 Make_Procedure_Call_Statement (Loc,
6142 New_Reference_To (RTE (RE_Abort_Undefer), Loc),
6143 Parameter_Associations =>
6146 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
6147 -- will generate a _clean for the additional status flag.
6151 -- procedure _clean is
6153 -- Cancel_Task_Entry_Call (U);
6161 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
6163 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
6165 -- Wrap the cleanup block in an exception handling block
6171 -- when Abort_Signal => Abort_Undefer;
6174 Abort_Block_Ent := Make_Temporary (Loc, 'A');
6176 Append_To (TaskE_Stmts,
6177 Make_Implicit_Label_Declaration (Loc,
6178 Defining_Identifier => Abort_Block_Ent));
6180 Append_To (TaskE_Stmts,
6182 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
6186 -- <triggering-statements>
6189 Append_To (TaskE_Stmts,
6190 Make_If_Statement (Loc,
6194 New_Reference_To (T, Loc)),
6197 New_Copy_List_Tree (Tstats)));
6199 ----------------------------------
6200 -- Protected procedure handling --
6201 ----------------------------------
6204 -- <dispatching-call>;
6205 -- <triggering-statements>
6207 ProtP_Stmts := New_Copy_List_Tree (Tstats);
6208 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
6211 -- S := Ada.Tags.Get_Offset_Index
6212 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6215 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
6218 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6220 Append_To (Conc_Typ_Stmts,
6221 Make_Procedure_Call_Statement (Loc,
6224 Find_Prim_Op (Etype (Etype (Obj)),
6225 Name_uDisp_Get_Prim_Op_Kind),
6227 Parameter_Associations =>
6229 New_Copy_Tree (Obj),
6230 New_Reference_To (S, Loc),
6231 New_Reference_To (C, Loc))));
6234 -- if C = POK_Procedure_Entry then
6236 -- elsif C = POK_Task_Entry then
6242 Append_To (Conc_Typ_Stmts,
6243 Make_If_Statement (Loc,
6247 New_Reference_To (C, Loc),
6249 New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
6256 Make_Elsif_Part (Loc,
6260 New_Reference_To (C, Loc),
6262 New_Reference_To (RTE (RE_POK_Task_Entry), Loc)),
6271 -- <dispatching-call>;
6272 -- <triggering-statements>
6274 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
6275 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
6278 -- if K = Ada.Tags.TK_Limited_Tagged then
6285 Make_If_Statement (Loc,
6289 New_Reference_To (K, Loc),
6291 New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
6300 Make_Block_Statement (Loc,
6303 Handled_Statement_Sequence =>
6304 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6309 -- Delay triggering statement processing
6312 -- Add a Delay_Block object to the parameter list of the delay
6313 -- procedure to form the parameter list of the Wait entry call.
6315 Dblock_Ent := Make_Temporary (Loc, 'D');
6317 Pdef := Entity (Name (Ecall));
6319 if Is_RTE (Pdef, RO_CA_Delay_For) then
6321 New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
6323 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
6325 New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
6327 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
6328 Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
6331 Append_To (Parameter_Associations (Ecall),
6332 Make_Attribute_Reference (Loc,
6333 Prefix => New_Reference_To (Dblock_Ent, Loc),
6334 Attribute_Name => Name_Unchecked_Access));
6336 -- Create the inner block to protect the abortable part
6339 Make_Implicit_Exception_Handler (Loc,
6340 Exception_Choices =>
6341 New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
6342 Statements => New_List (
6343 Make_Procedure_Call_Statement (Loc,
6344 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
6347 Make_Procedure_Call_Statement (Loc,
6348 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
6351 Make_Block_Statement (Loc,
6352 Identifier => New_Reference_To (Blk_Ent, Loc),
6353 Handled_Statement_Sequence =>
6354 Make_Handled_Sequence_Of_Statements (Loc,
6355 Statements => Astats),
6356 Has_Created_Identifier => True,
6357 Is_Asynchronous_Call_Block => True);
6359 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
6362 Make_Implicit_If_Statement (N,
6363 Condition => Make_Function_Call (Loc,
6364 Name => Enqueue_Call,
6365 Parameter_Associations => Parameter_Associations (Ecall)),
6367 New_List (Make_Block_Statement (Loc,
6368 Handled_Statement_Sequence =>
6369 Make_Handled_Sequence_Of_Statements (Loc,
6370 Statements => New_List (
6371 Make_Implicit_Label_Declaration (Loc,
6372 Defining_Identifier => Blk_Ent,
6373 Label_Construct => Abortable_Block),
6375 Exception_Handlers => Hdle)))));
6377 Stmts := New_List (Ecall);
6379 -- Construct statement sequence for new block
6382 Make_Implicit_If_Statement (N,
6383 Condition => Make_Function_Call (Loc,
6384 Name => New_Reference_To (
6385 RTE (RE_Timed_Out), Loc),
6386 Parameter_Associations => New_List (
6387 Make_Attribute_Reference (Loc,
6388 Prefix => New_Reference_To (Dblock_Ent, Loc),
6389 Attribute_Name => Name_Unchecked_Access))),
6390 Then_Statements => Tstats));
6392 -- The result is the new block
6394 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
6397 Make_Block_Statement (Loc,
6398 Declarations => New_List (
6399 Make_Object_Declaration (Loc,
6400 Defining_Identifier => Dblock_Ent,
6401 Aliased_Present => True,
6402 Object_Definition => New_Reference_To (
6403 RTE (RE_Delay_Block), Loc))),
6405 Handled_Statement_Sequence =>
6406 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6416 Extract_Entry (Ecall, Concval, Ename, Index);
6417 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
6419 Stmts := Statements (Handled_Statement_Sequence (Ecall));
6420 Decls := Declarations (Ecall);
6422 if Is_Protected_Type (Etype (Concval)) then
6424 -- Get the declarations of the block expanded from the entry call
6426 Decl := First (Decls);
6427 while Present (Decl)
6429 (Nkind (Decl) /= N_Object_Declaration
6430 or else not Is_RTE (Etype (Object_Definition (Decl)),
6431 RE_Communication_Block))
6436 pragma Assert (Present (Decl));
6437 Cancel_Param := Defining_Identifier (Decl);
6439 -- Change the mode of the Protected_Entry_Call call
6441 -- Protected_Entry_Call (
6442 -- Object => po._object'Access,
6443 -- E => <entry index>;
6444 -- Uninterpreted_Data => P'Address;
6445 -- Mode => Asynchronous_Call;
6448 Stmt := First (Stmts);
6450 -- Skip assignments to temporaries created for in-out parameters
6452 -- This makes unwarranted assumptions about the shape of the expanded
6453 -- tree for the call, and should be cleaned up ???
6455 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
6461 Param := First (Parameter_Associations (Call));
6462 while Present (Param)
6463 and then not Is_RTE (Etype (Param), RE_Call_Modes)
6468 pragma Assert (Present (Param));
6469 Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
6472 -- Append an if statement to execute the abortable part
6475 -- if Enqueued (Bnn) then
6478 Make_Implicit_If_Statement (N,
6479 Condition => Make_Function_Call (Loc,
6480 Name => New_Reference_To (
6481 RTE (RE_Enqueued), Loc),
6482 Parameter_Associations => New_List (
6483 New_Reference_To (Cancel_Param, Loc))),
6484 Then_Statements => Astats));
6487 Make_Block_Statement (Loc,
6488 Identifier => New_Reference_To (Blk_Ent, Loc),
6489 Handled_Statement_Sequence =>
6490 Make_Handled_Sequence_Of_Statements (Loc,
6491 Statements => Stmts),
6492 Has_Created_Identifier => True,
6493 Is_Asynchronous_Call_Block => True);
6495 -- For the VM call Update_Exception instead of Abort_Undefer.
6496 -- See 4jexcept.ads for an explanation.
6498 if VM_Target = No_VM then
6499 Target_Undefer := RE_Abort_Undefer;
6501 Target_Undefer := RE_Update_Exception;
6503 New_List (Make_Function_Call (Loc,
6504 Name => New_Occurrence_Of
6505 (RTE (RE_Current_Target_Exception), Loc)));
6509 Make_Block_Statement (Loc,
6510 Handled_Statement_Sequence =>
6511 Make_Handled_Sequence_Of_Statements (Loc,
6512 Statements => New_List (
6513 Make_Implicit_Label_Declaration (Loc,
6514 Defining_Identifier => Blk_Ent,
6515 Label_Construct => Abortable_Block),
6520 Exception_Handlers => New_List (
6521 Make_Implicit_Exception_Handler (Loc,
6523 -- when Abort_Signal =>
6524 -- Abort_Undefer.all;
6526 Exception_Choices =>
6527 New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
6528 Statements => New_List (
6529 Make_Procedure_Call_Statement (Loc,
6530 Name => New_Reference_To (
6531 RTE (Target_Undefer), Loc),
6532 Parameter_Associations => Undefer_Args)))))),
6534 -- if not Cancelled (Bnn) then
6535 -- triggered statements
6538 Make_Implicit_If_Statement (N,
6539 Condition => Make_Op_Not (Loc,
6541 Make_Function_Call (Loc,
6542 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
6543 Parameter_Associations => New_List (
6544 New_Occurrence_Of (Cancel_Param, Loc)))),
6545 Then_Statements => Tstats));
6547 -- Asynchronous task entry call
6554 B := Make_Defining_Identifier (Loc, Name_uB);
6556 -- Insert declaration of B in declarations of existing block
6559 Make_Object_Declaration (Loc,
6560 Defining_Identifier => B,
6561 Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
6563 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
6565 -- Insert declaration of C in declarations of existing block
6568 Make_Object_Declaration (Loc,
6569 Defining_Identifier => Cancel_Param,
6570 Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
6572 -- Remove and save the call to Call_Simple
6574 Stmt := First (Stmts);
6576 -- Skip assignments to temporaries created for in-out parameters.
6577 -- This makes unwarranted assumptions about the shape of the expanded
6578 -- tree for the call, and should be cleaned up ???
6580 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
6586 -- Create the inner block to protect the abortable part
6589 Make_Implicit_Exception_Handler (Loc,
6590 Exception_Choices =>
6591 New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
6594 Make_Procedure_Call_Statement (Loc,
6595 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
6598 Make_Procedure_Call_Statement (Loc,
6599 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
6602 Make_Block_Statement (Loc,
6603 Identifier => New_Reference_To (Blk_Ent, Loc),
6604 Handled_Statement_Sequence =>
6605 Make_Handled_Sequence_Of_Statements (Loc,
6606 Statements => Astats),
6607 Has_Created_Identifier => True,
6608 Is_Asynchronous_Call_Block => True);
6611 Make_Block_Statement (Loc,
6612 Handled_Statement_Sequence =>
6613 Make_Handled_Sequence_Of_Statements (Loc,
6614 Statements => New_List (
6615 Make_Implicit_Label_Declaration (Loc,
6616 Defining_Identifier =>
6621 Exception_Handlers => Hdle)));
6623 -- Create new call statement
6625 Params := Parameter_Associations (Call);
6628 New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
6630 New_Reference_To (B, Loc));
6633 Make_Procedure_Call_Statement (Loc,
6635 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
6636 Parameter_Associations => Params));
6638 -- Construct statement sequence for new block
6641 Make_Implicit_If_Statement (N,
6644 New_Reference_To (Cancel_Param, Loc)),
6645 Then_Statements => Tstats));
6647 -- Protected the call against abort
6650 Make_Procedure_Call_Statement (Loc,
6651 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
6652 Parameter_Associations => Empty_List));
6655 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
6657 -- The result is the new block
6660 Make_Block_Statement (Loc,
6661 Declarations => Decls,
6662 Handled_Statement_Sequence =>
6663 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6666 end Expand_N_Asynchronous_Select;
6668 -------------------------------------
6669 -- Expand_N_Conditional_Entry_Call --
6670 -------------------------------------
6672 -- The conditional task entry call is converted to a call to
6677 -- P : parms := (parm, parm, parm);
6681 -- (<acceptor-task>, -- Acceptor
6682 -- <entry-index>, -- E
6683 -- P'Address, -- Uninterpreted_Data
6684 -- Conditional_Call, -- Mode
6685 -- B); -- Rendezvous_Successful
6690 -- normal-statements
6696 -- For a description of the use of P and the assignments after the call,
6697 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
6698 -- conditional entry call has already been expanded (by the Expand_N_Entry
6699 -- _Call_Statement procedure) as follows:
6702 -- P : parms := (parm, parm, parm);
6704 -- ... info for in-out parameters
6705 -- Call_Simple (acceptor-task, entry-index, P'Address);
6711 -- so the task at hand is to convert the latter expansion into the former
6713 -- The conditional protected entry call is converted to a call to
6714 -- Protected_Entry_Call:
6717 -- P : parms := (parm, parm, parm);
6718 -- Bnn : Communications_Block;
6721 -- Protected_Entry_Call
6722 -- (po._object'Access, -- Object
6723 -- <entry index>, -- E
6724 -- P'Address, -- Uninterpreted_Data
6725 -- Conditional_Call, -- Mode
6730 -- if Cancelled (Bnn) then
6733 -- normal-statements
6737 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
6741 -- B : Boolean := False;
6742 -- C : Ada.Tags.Prim_Op_Kind;
6743 -- K : Ada.Tags.Tagged_Kind :=
6744 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6745 -- P : Parameters := (Param1 .. ParamN);
6749 -- if K = Ada.Tags.TK_Limited_Tagged then
6750 -- <dispatching-call>;
6751 -- <triggering-statements>
6755 -- Ada.Tags.Get_Offset_Index
6756 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6758 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6760 -- if C = POK_Protected_Entry
6761 -- or else C = POK_Task_Entry
6763 -- Param1 := P.Param1;
6765 -- ParamN := P.ParamN;
6769 -- if C = POK_Procedure
6770 -- or else C = POK_Protected_Procedure
6771 -- or else C = POK_Task_Procedure
6773 -- <dispatching-call>;
6776 -- <triggering-statements>
6778 -- <else-statements>
6783 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
6784 Loc : constant Source_Ptr := Sloc (N);
6785 Alt : constant Node_Id := Entry_Call_Alternative (N);
6786 Blk : Node_Id := Entry_Call_Statement (Alt);
6789 Blk_Typ : Entity_Id;
6791 Call_Ent : Entity_Id;
6792 Conc_Typ_Stmts : List_Id;
6796 Lim_Typ_Stmts : List_Id;
6803 Transient_Blk : Node_Id;
6806 B : Entity_Id; -- Call status flag
6807 C : Entity_Id; -- Call kind
6808 K : Entity_Id; -- Tagged kind
6809 P : Entity_Id; -- Parameter block
6810 S : Entity_Id; -- Primitive operation slot
6813 if Ada_Version >= Ada_2005
6814 and then Nkind (Blk) = N_Procedure_Call_Statement
6816 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
6821 -- Call status flag processing, generate:
6822 -- B : Boolean := False;
6824 B := Build_B (Loc, Decls);
6826 -- Call kind processing, generate:
6827 -- C : Ada.Tags.Prim_Op_Kind;
6829 C := Build_C (Loc, Decls);
6831 -- Tagged kind processing, generate:
6832 -- K : Ada.Tags.Tagged_Kind :=
6833 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6835 K := Build_K (Loc, Decls, Obj);
6837 -- Parameter block processing
6839 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
6840 P := Parameter_Block_Pack
6841 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
6843 -- Dispatch table slot processing, generate:
6846 S := Build_S (Loc, Decls);
6849 -- S := Ada.Tags.Get_Offset_Index
6850 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6853 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
6856 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6858 Append_To (Conc_Typ_Stmts,
6859 Make_Procedure_Call_Statement (Loc,
6862 Find_Prim_Op (Etype (Etype (Obj)),
6863 Name_uDisp_Conditional_Select),
6865 Parameter_Associations =>
6867 New_Copy_Tree (Obj), -- <object>
6868 New_Reference_To (S, Loc), -- S
6869 Make_Attribute_Reference (Loc, -- P'Address
6871 New_Reference_To (P, Loc),
6874 New_Reference_To (C, Loc), -- C
6875 New_Reference_To (B, Loc)))); -- B
6878 -- if C = POK_Protected_Entry
6879 -- or else C = POK_Task_Entry
6881 -- Param1 := P.Param1;
6883 -- ParamN := P.ParamN;
6886 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
6888 -- Generate the if statement only when the packed parameters need
6889 -- explicit assignments to their corresponding actuals.
6891 if Present (Unpack) then
6892 Append_To (Conc_Typ_Stmts,
6893 Make_If_Statement (Loc,
6900 New_Reference_To (C, Loc),
6902 New_Reference_To (RTE (
6903 RE_POK_Protected_Entry), Loc)),
6907 New_Reference_To (C, Loc),
6909 New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
6917 -- if C = POK_Procedure
6918 -- or else C = POK_Protected_Procedure
6919 -- or else C = POK_Task_Procedure
6921 -- <dispatching-call>
6923 -- <normal-statements>
6925 -- <else-statements>
6928 N_Stats := New_Copy_List_Tree (Statements (Alt));
6930 Prepend_To (N_Stats,
6931 Make_If_Statement (Loc,
6937 New_Reference_To (C, Loc),
6939 New_Reference_To (RTE (RE_POK_Procedure), Loc)),
6946 New_Reference_To (C, Loc),
6948 New_Reference_To (RTE (
6949 RE_POK_Protected_Procedure), Loc)),
6954 New_Reference_To (C, Loc),
6956 New_Reference_To (RTE (
6957 RE_POK_Task_Procedure), Loc)))),
6962 Append_To (Conc_Typ_Stmts,
6963 Make_If_Statement (Loc,
6964 Condition => New_Reference_To (B, Loc),
6965 Then_Statements => N_Stats,
6966 Else_Statements => Else_Statements (N)));
6969 -- <dispatching-call>;
6970 -- <triggering-statements>
6972 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
6973 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
6976 -- if K = Ada.Tags.TK_Limited_Tagged then
6983 Make_If_Statement (Loc,
6987 New_Reference_To (K, Loc),
6989 New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
6998 Make_Block_Statement (Loc,
7001 Handled_Statement_Sequence =>
7002 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7004 -- As described above, The entry alternative is transformed into a
7005 -- block that contains the gnulli call, and possibly assignment
7006 -- statements for in-out parameters. The gnulli call may itself be
7007 -- rewritten into a transient block if some unconstrained parameters
7008 -- require it. We need to retrieve the call to complete its parameter
7013 First_Real_Statement (Handled_Statement_Sequence (Blk));
7015 if Present (Transient_Blk)
7016 and then Nkind (Transient_Blk) = N_Block_Statement
7018 Blk := Transient_Blk;
7021 Stmts := Statements (Handled_Statement_Sequence (Blk));
7022 Stmt := First (Stmts);
7023 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7028 Params := Parameter_Associations (Call);
7030 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
7032 -- Substitute Conditional_Entry_Call for Simple_Call parameter
7034 Param := First (Params);
7035 while Present (Param)
7036 and then not Is_RTE (Etype (Param), RE_Call_Modes)
7041 pragma Assert (Present (Param));
7042 Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc));
7046 -- Find the Communication_Block parameter for the call to the
7047 -- Cancelled function.
7049 Decl := First (Declarations (Blk));
7050 while Present (Decl)
7051 and then not Is_RTE (Etype (Object_Definition (Decl)),
7052 RE_Communication_Block)
7057 -- Add an if statement to execute the else part if the call
7058 -- does not succeed (as indicated by the Cancelled predicate).
7061 Make_Implicit_If_Statement (N,
7062 Condition => Make_Function_Call (Loc,
7063 Name => New_Reference_To (RTE (RE_Cancelled), Loc),
7064 Parameter_Associations => New_List (
7065 New_Reference_To (Defining_Identifier (Decl), Loc))),
7066 Then_Statements => Else_Statements (N),
7067 Else_Statements => Statements (Alt)));
7070 B := Make_Defining_Identifier (Loc, Name_uB);
7072 -- Insert declaration of B in declarations of existing block
7074 if No (Declarations (Blk)) then
7075 Set_Declarations (Blk, New_List);
7078 Prepend_To (Declarations (Blk),
7079 Make_Object_Declaration (Loc,
7080 Defining_Identifier => B,
7081 Object_Definition =>
7082 New_Reference_To (Standard_Boolean, Loc)));
7084 -- Create new call statement
7087 New_Reference_To (RTE (RE_Conditional_Call), Loc));
7088 Append_To (Params, New_Reference_To (B, Loc));
7091 Make_Procedure_Call_Statement (Loc,
7092 Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
7093 Parameter_Associations => Params));
7095 -- Construct statement sequence for new block
7098 Make_Implicit_If_Statement (N,
7099 Condition => New_Reference_To (B, Loc),
7100 Then_Statements => Statements (Alt),
7101 Else_Statements => Else_Statements (N)));
7104 -- The result is the new block
7107 Make_Block_Statement (Loc,
7108 Declarations => Declarations (Blk),
7109 Handled_Statement_Sequence =>
7110 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7114 end Expand_N_Conditional_Entry_Call;
7116 ---------------------------------------
7117 -- Expand_N_Delay_Relative_Statement --
7118 ---------------------------------------
7120 -- Delay statement is implemented as a procedure call to Delay_For
7121 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
7122 -- simple delays imposed by the use of Protected Objects.
7124 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
7125 Loc : constant Source_Ptr := Sloc (N);
7128 Make_Procedure_Call_Statement (Loc,
7129 Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc),
7130 Parameter_Associations => New_List (Expression (N))));
7132 end Expand_N_Delay_Relative_Statement;
7134 ------------------------------------
7135 -- Expand_N_Delay_Until_Statement --
7136 ------------------------------------
7138 -- Delay Until statement is implemented as a procedure call to
7139 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
7141 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
7142 Loc : constant Source_Ptr := Sloc (N);
7146 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
7147 Typ := RTE (RO_CA_Delay_Until);
7149 Typ := RTE (RO_RT_Delay_Until);
7153 Make_Procedure_Call_Statement (Loc,
7154 Name => New_Reference_To (Typ, Loc),
7155 Parameter_Associations => New_List (Expression (N))));
7158 end Expand_N_Delay_Until_Statement;
7160 -------------------------
7161 -- Expand_N_Entry_Body --
7162 -------------------------
7164 procedure Expand_N_Entry_Body (N : Node_Id) is
7166 -- Associate discriminals with the next protected operation body to be
7169 if Present (Next_Protected_Operation (N)) then
7170 Set_Discriminals (Parent (Current_Scope));
7172 end Expand_N_Entry_Body;
7174 -----------------------------------
7175 -- Expand_N_Entry_Call_Statement --
7176 -----------------------------------
7178 -- An entry call is expanded into GNARLI calls to implement a simple entry
7179 -- call (see Build_Simple_Entry_Call).
7181 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
7187 if No_Run_Time_Mode then
7188 Error_Msg_CRT ("entry call", N);
7192 -- If this entry call is part of an asynchronous select, don't expand it
7193 -- here; it will be expanded with the select statement. Don't expand
7194 -- timed entry calls either, as they are translated into asynchronous
7197 -- ??? This whole approach is questionable; it may be better to go back
7198 -- to allowing the expansion to take place and then attempting to fix it
7199 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
7200 -- whether the expanded call is on a task or protected entry.
7202 if (Nkind (Parent (N)) /= N_Triggering_Alternative
7203 or else N /= Triggering_Statement (Parent (N)))
7204 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
7205 or else N /= Entry_Call_Statement (Parent (N))
7206 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
7208 Extract_Entry (N, Concval, Ename, Index);
7209 Build_Simple_Entry_Call (N, Concval, Ename, Index);
7211 end Expand_N_Entry_Call_Statement;
7213 --------------------------------
7214 -- Expand_N_Entry_Declaration --
7215 --------------------------------
7217 -- If there are parameters, then first, each of the formals is marked by
7218 -- setting Is_Entry_Formal. Next a record type is built which is used to
7219 -- hold the parameter values. The name of this record type is entryP where
7220 -- entry is the name of the entry, with an additional corresponding access
7221 -- type called entryPA. The record type has matching components for each
7222 -- formal (the component names are the same as the formal names). For
7223 -- elementary types, the component type matches the formal type. For
7224 -- composite types, an access type is declared (with the name formalA)
7225 -- which designates the formal type, and the type of the component is this
7226 -- access type. Finally the Entry_Component of each formal is set to
7227 -- reference the corresponding record component.
7229 procedure Expand_N_Entry_Declaration (N : Node_Id) is
7230 Loc : constant Source_Ptr := Sloc (N);
7231 Entry_Ent : constant Entity_Id := Defining_Identifier (N);
7232 Components : List_Id;
7235 Last_Decl : Node_Id;
7236 Component : Entity_Id;
7239 Rec_Ent : Entity_Id;
7240 Acc_Ent : Entity_Id;
7243 Formal := First_Formal (Entry_Ent);
7246 -- Most processing is done only if parameters are present
7248 if Present (Formal) then
7249 Components := New_List;
7251 -- Loop through formals
7253 while Present (Formal) loop
7254 Set_Is_Entry_Formal (Formal);
7256 Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
7257 Set_Entry_Component (Formal, Component);
7258 Set_Entry_Formal (Component, Formal);
7259 Ftype := Etype (Formal);
7261 -- Declare new access type and then append
7263 Ctype := Make_Temporary (Loc, 'A');
7266 Make_Full_Type_Declaration (Loc,
7267 Defining_Identifier => Ctype,
7269 Make_Access_To_Object_Definition (Loc,
7270 All_Present => True,
7271 Constant_Present => Ekind (Formal) = E_In_Parameter,
7272 Subtype_Indication => New_Reference_To (Ftype, Loc)));
7274 Insert_After (Last_Decl, Decl);
7277 Append_To (Components,
7278 Make_Component_Declaration (Loc,
7279 Defining_Identifier => Component,
7280 Component_Definition =>
7281 Make_Component_Definition (Loc,
7282 Aliased_Present => False,
7283 Subtype_Indication => New_Reference_To (Ctype, Loc))));
7285 Next_Formal_With_Extras (Formal);
7288 -- Create the Entry_Parameter_Record declaration
7290 Rec_Ent := Make_Temporary (Loc, 'P');
7293 Make_Full_Type_Declaration (Loc,
7294 Defining_Identifier => Rec_Ent,
7296 Make_Record_Definition (Loc,
7298 Make_Component_List (Loc,
7299 Component_Items => Components)));
7301 Insert_After (Last_Decl, Decl);
7304 -- Construct and link in the corresponding access type
7306 Acc_Ent := Make_Temporary (Loc, 'A');
7308 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
7311 Make_Full_Type_Declaration (Loc,
7312 Defining_Identifier => Acc_Ent,
7314 Make_Access_To_Object_Definition (Loc,
7315 All_Present => True,
7316 Subtype_Indication => New_Reference_To (Rec_Ent, Loc)));
7318 Insert_After (Last_Decl, Decl);
7321 end Expand_N_Entry_Declaration;
7323 -----------------------------
7324 -- Expand_N_Protected_Body --
7325 -----------------------------
7327 -- Protected bodies are expanded to the completion of the subprograms
7328 -- created for the corresponding protected type. These are a protected and
7329 -- unprotected version of each protected subprogram in the object, a
7330 -- function to calculate each entry barrier, and a procedure to execute the
7331 -- sequence of statements of each protected entry body. For example, for
7332 -- protected type ptype:
7335 -- (O : System.Address;
7336 -- E : Protected_Entry_Index)
7339 -- <discriminant renamings>
7340 -- <private object renamings>
7342 -- return <barrier expression>;
7345 -- procedure pprocN (_object : in out poV;...) is
7346 -- <discriminant renamings>
7347 -- <private object renamings>
7349 -- <sequence of statements>
7352 -- procedure pprocP (_object : in out poV;...) is
7353 -- procedure _clean is
7356 -- ptypeS (_object, Pn);
7357 -- Unlock (_object._object'Access);
7358 -- Abort_Undefer.all;
7363 -- Lock (_object._object'Access);
7364 -- pprocN (_object;...);
7369 -- function pfuncN (_object : poV;...) return Return_Type is
7370 -- <discriminant renamings>
7371 -- <private object renamings>
7373 -- <sequence of statements>
7376 -- function pfuncP (_object : poV) return Return_Type is
7377 -- procedure _clean is
7379 -- Unlock (_object._object'Access);
7380 -- Abort_Undefer.all;
7385 -- Lock (_object._object'Access);
7386 -- return pfuncN (_object);
7393 -- (O : System.Address;
7394 -- P : System.Address;
7395 -- E : Protected_Entry_Index)
7397 -- <discriminant renamings>
7398 -- <private object renamings>
7399 -- type poVP is access poV;
7400 -- _Object : ptVP := ptVP!(O);
7404 -- <statement sequence>
7405 -- Complete_Entry_Body (_Object._Object);
7407 -- when all others =>
7408 -- Exceptional_Complete_Entry_Body (
7409 -- _Object._Object, Get_GNAT_Exception);
7413 -- The type poV is the record created for the protected type to hold
7414 -- the state of the protected object.
7416 procedure Expand_N_Protected_Body (N : Node_Id) is
7417 Loc : constant Source_Ptr := Sloc (N);
7418 Pid : constant Entity_Id := Corresponding_Spec (N);
7420 Current_Node : Node_Id;
7421 Disp_Op_Body : Node_Id;
7422 New_Op_Body : Node_Id;
7423 Num_Entries : Natural := 0;
7427 Chain : Entity_Id := Empty;
7428 -- Finalization chain that may be attached to new body
7430 function Build_Dispatching_Subprogram_Body
7433 Prot_Bod : Node_Id) return Node_Id;
7434 -- Build a dispatching version of the protected subprogram body. The
7435 -- newly generated subprogram contains a call to the original protected
7436 -- body. The following code is generated:
7438 -- function <protected-function-name> (Param1 .. ParamN) return
7441 -- return <protected-function-name>P (Param1 .. ParamN);
7442 -- end <protected-function-name>;
7446 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
7448 -- <protected-procedure-name>P (Param1 .. ParamN);
7449 -- end <protected-procedure-name>
7451 ---------------------------------------
7452 -- Build_Dispatching_Subprogram_Body --
7453 ---------------------------------------
7455 function Build_Dispatching_Subprogram_Body
7458 Prot_Bod : Node_Id) return Node_Id
7460 Loc : constant Source_Ptr := Sloc (N);
7467 -- Generate a specification without a letter suffix in order to
7468 -- override an interface function or procedure.
7470 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
7472 -- The formal parameters become the actuals of the protected function
7473 -- or procedure call.
7475 Actuals := New_List;
7476 Formal := First (Parameter_Specifications (Spec));
7477 while Present (Formal) loop
7479 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
7484 if Nkind (Spec) = N_Procedure_Specification then
7487 Make_Procedure_Call_Statement (Loc,
7489 New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
7490 Parameter_Associations => Actuals));
7492 pragma Assert (Nkind (Spec) = N_Function_Specification);
7496 Make_Simple_Return_Statement (Loc,
7498 Make_Function_Call (Loc,
7500 New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
7501 Parameter_Associations => Actuals)));
7505 Make_Subprogram_Body (Loc,
7506 Declarations => Empty_List,
7507 Specification => Spec,
7508 Handled_Statement_Sequence =>
7509 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7510 end Build_Dispatching_Subprogram_Body;
7512 -- Start of processing for Expand_N_Protected_Body
7515 if No_Run_Time_Mode then
7516 Error_Msg_CRT ("protected body", N);
7520 -- This is the proper body corresponding to a stub. The declarations
7521 -- must be inserted at the point of the stub, which in turn is in the
7522 -- declarative part of the parent unit.
7524 if Nkind (Parent (N)) = N_Subunit then
7525 Current_Node := Corresponding_Stub (Parent (N));
7530 Op_Body := First (Declarations (N));
7532 -- The protected body is replaced with the bodies of its
7533 -- protected operations, and the declarations for internal objects
7534 -- that may have been created for entry family bounds.
7536 Rewrite (N, Make_Null_Statement (Sloc (N)));
7539 while Present (Op_Body) loop
7540 case Nkind (Op_Body) is
7541 when N_Subprogram_Declaration =>
7544 when N_Subprogram_Body =>
7546 -- Do not create bodies for eliminated operations
7548 if not Is_Eliminated (Defining_Entity (Op_Body))
7549 and then not Is_Eliminated (Corresponding_Spec (Op_Body))
7552 Build_Unprotected_Subprogram_Body (Op_Body, Pid);
7554 -- Propagate the finalization chain to the new body. In the
7555 -- unlikely event that the subprogram contains a declaration
7556 -- or allocator for an object that requires finalization,
7557 -- the corresponding chain is created when analyzing the
7558 -- body, and attached to its entity. This entity is not
7559 -- further elaborated, and so the chain properly belongs to
7560 -- the newly created subprogram body.
7563 Finalization_Chain_Entity (Defining_Entity (Op_Body));
7565 if Present (Chain) then
7566 Set_Finalization_Chain_Entity
7567 (Protected_Body_Subprogram
7568 (Corresponding_Spec (Op_Body)), Chain);
7570 (Handled_Statement_Sequence (New_Op_Body), False);
7573 Insert_After (Current_Node, New_Op_Body);
7574 Current_Node := New_Op_Body;
7575 Analyze (New_Op_Body);
7577 -- Build the corresponding protected operation. It may
7578 -- appear that this is needed only if this is a visible
7579 -- operation of the type, or if it is an interrupt handler,
7580 -- and this was the strategy used previously in GNAT.
7581 -- However, the operation may be exported through a 'Access
7582 -- to an external caller. This is the common idiom in code
7583 -- that uses the Ada 2005 Timing_Events package. As a result
7584 -- we need to produce the protected body for both visible
7585 -- and private operations, as well as operations that only
7586 -- have a body in the source, and for which we create a
7587 -- declaration in the protected body itself.
7589 if Present (Corresponding_Spec (Op_Body)) then
7591 Build_Protected_Subprogram_Body (
7592 Op_Body, Pid, Specification (New_Op_Body));
7594 Insert_After (Current_Node, New_Op_Body);
7595 Analyze (New_Op_Body);
7597 Current_Node := New_Op_Body;
7599 -- Generate an overriding primitive operation body for
7600 -- this subprogram if the protected type implements an
7603 if Ada_Version >= Ada_2005
7605 Present (Interfaces (Corresponding_Record_Type (Pid)))
7608 Build_Dispatching_Subprogram_Body
7609 (Op_Body, Pid, New_Op_Body);
7611 Insert_After (Current_Node, Disp_Op_Body);
7612 Analyze (Disp_Op_Body);
7614 Current_Node := Disp_Op_Body;
7619 when N_Entry_Body =>
7620 Op_Id := Defining_Identifier (Op_Body);
7621 Num_Entries := Num_Entries + 1;
7623 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
7625 Insert_After (Current_Node, New_Op_Body);
7626 Current_Node := New_Op_Body;
7627 Analyze (New_Op_Body);
7629 when N_Implicit_Label_Declaration =>
7632 when N_Itype_Reference =>
7633 Insert_After (Current_Node, New_Copy (Op_Body));
7635 when N_Freeze_Entity =>
7636 New_Op_Body := New_Copy (Op_Body);
7638 if Present (Entity (Op_Body))
7639 and then Freeze_Node (Entity (Op_Body)) = Op_Body
7641 Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
7644 Insert_After (Current_Node, New_Op_Body);
7645 Current_Node := New_Op_Body;
7646 Analyze (New_Op_Body);
7649 New_Op_Body := New_Copy (Op_Body);
7650 Insert_After (Current_Node, New_Op_Body);
7651 Current_Node := New_Op_Body;
7652 Analyze (New_Op_Body);
7654 when N_Object_Declaration =>
7655 pragma Assert (not Comes_From_Source (Op_Body));
7656 New_Op_Body := New_Copy (Op_Body);
7657 Insert_After (Current_Node, New_Op_Body);
7658 Current_Node := New_Op_Body;
7659 Analyze (New_Op_Body);
7662 raise Program_Error;
7669 -- Finally, create the body of the function that maps an entry index
7670 -- into the corresponding body index, except when there is no entry, or
7671 -- in a Ravenscar-like profile.
7673 if Corresponding_Runtime_Package (Pid) =
7674 System_Tasking_Protected_Objects_Entries
7676 New_Op_Body := Build_Find_Body_Index (Pid);
7677 Insert_After (Current_Node, New_Op_Body);
7678 Current_Node := New_Op_Body;
7679 Analyze (New_Op_Body);
7682 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
7683 -- protected body. At this point all wrapper specs have been created,
7684 -- frozen and included in the dispatch table for the protected type.
7686 if Ada_Version >= Ada_2005 then
7687 Build_Wrapper_Bodies (Loc, Pid, Current_Node);
7689 end Expand_N_Protected_Body;
7691 -----------------------------------------
7692 -- Expand_N_Protected_Type_Declaration --
7693 -----------------------------------------
7695 -- First we create a corresponding record type declaration used to
7696 -- represent values of this protected type.
7697 -- The general form of this type declaration is
7699 -- type poV (discriminants) is record
7700 -- _Object : aliased <kind>Protection
7701 -- [(<entry count> [, <handler count>])];
7702 -- [entry_family : array (bounds) of Void;]
7703 -- <private data fields>
7706 -- The discriminants are present only if the corresponding protected type
7707 -- has discriminants, and they exactly mirror the protected type
7708 -- discriminants. The private data fields similarly mirror the private
7709 -- declarations of the protected type.
7711 -- The Object field is always present. It contains RTS specific data used
7712 -- to control the protected object. It is declared as Aliased so that it
7713 -- can be passed as a pointer to the RTS. This allows the protected record
7714 -- to be referenced within RTS data structures. An appropriate Protection
7715 -- type and discriminant are generated.
7717 -- The Service field is present for protected objects with entries. It
7718 -- contains sufficient information to allow the entry service procedure for
7719 -- this object to be called when the object is not known till runtime.
7721 -- One entry_family component is present for each entry family in the
7722 -- task definition (see Expand_N_Task_Type_Declaration).
7724 -- When a protected object is declared, an instance of the protected type
7725 -- value record is created. The elaboration of this declaration creates the
7726 -- correct bounds for the entry families, and also evaluates the priority
7727 -- expression if needed. The initialization routine for the protected type
7728 -- itself then calls Initialize_Protection with appropriate parameters to
7729 -- initialize the value of the Task_Id field. Install_Handlers may be also
7730 -- called if a pragma Attach_Handler applies.
7732 -- Note: this record is passed to the subprograms created by the expansion
7733 -- of protected subprograms and entries. It is an in parameter to protected
7734 -- functions and an in out parameter to procedures and entry bodies. The
7735 -- Entity_Id for this created record type is placed in the
7736 -- Corresponding_Record_Type field of the associated protected type entity.
7738 -- Next we create a procedure specifications for protected subprograms and
7739 -- entry bodies. For each protected subprograms two subprograms are
7740 -- created, an unprotected and a protected version. The unprotected version
7741 -- is called from within other operations of the same protected object.
7743 -- We also build the call to register the procedure if a pragma
7744 -- Interrupt_Handler applies.
7746 -- A single subprogram is created to service all entry bodies; it has an
7747 -- additional boolean out parameter indicating that the previous entry call
7748 -- made by the current task was serviced immediately, i.e. not by proxy.
7749 -- The O parameter contains a pointer to a record object of the type
7750 -- described above. An untyped interface is used here to allow this
7751 -- procedure to be called in places where the type of the object to be
7752 -- serviced is not known. This must be done, for example, when a call that
7753 -- may have been requeued is cancelled; the corresponding object must be
7754 -- serviced, but which object that is not known till runtime.
7757 -- (O : System.Address; P : out Boolean);
7758 -- procedure pprocN (_object : in out poV);
7759 -- procedure pproc (_object : in out poV);
7760 -- function pfuncN (_object : poV);
7761 -- function pfunc (_object : poV);
7764 -- Note that this must come after the record type declaration, since
7765 -- the specs refer to this type.
7767 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
7768 Loc : constant Source_Ptr := Sloc (N);
7769 Prot_Typ : constant Entity_Id := Defining_Identifier (N);
7771 Pdef : constant Node_Id := Protected_Definition (N);
7772 -- This contains two lists; one for visible and one for private decls
7776 Discr_Map : constant Elist_Id := New_Elmt_List;
7780 Comp_Id : Entity_Id;
7782 Current_Node : Node_Id := N;
7783 Bdef : Entity_Id := Empty; -- avoid uninit warning
7784 Edef : Entity_Id := Empty; -- avoid uninit warning
7785 Entries_Aggr : Node_Id;
7786 Body_Id : Entity_Id;
7789 Object_Comp : Node_Id;
7791 procedure Check_Inlining (Subp : Entity_Id);
7792 -- If the original operation has a pragma Inline, propagate the flag
7793 -- to the internal body, for possible inlining later on. The source
7794 -- operation is invisible to the back-end and is never actually called.
7796 function Static_Component_Size (Comp : Entity_Id) return Boolean;
7797 -- When compiling under the Ravenscar profile, private components must
7798 -- have a static size, or else a protected object will require heap
7799 -- allocation, violating the corresponding restriction. It is preferable
7800 -- to make this check here, because it provides a better error message
7801 -- than the back-end, which refers to the object as a whole.
7803 procedure Register_Handler;
7804 -- For a protected operation that is an interrupt handler, add the
7805 -- freeze action that will register it as such.
7807 --------------------
7808 -- Check_Inlining --
7809 --------------------
7811 procedure Check_Inlining (Subp : Entity_Id) is
7813 if Is_Inlined (Subp) then
7814 Set_Is_Inlined (Protected_Body_Subprogram (Subp));
7815 Set_Is_Inlined (Subp, False);
7819 ---------------------------------
7820 -- Check_Static_Component_Size --
7821 ---------------------------------
7823 function Static_Component_Size (Comp : Entity_Id) return Boolean is
7824 Typ : constant Entity_Id := Etype (Comp);
7828 if Is_Scalar_Type (Typ) then
7831 elsif Is_Array_Type (Typ) then
7832 return Compile_Time_Known_Bounds (Typ);
7834 elsif Is_Record_Type (Typ) then
7835 C := First_Component (Typ);
7836 while Present (C) loop
7837 if not Static_Component_Size (C) then
7846 -- Any other types will be checked by the back-end
7851 end Static_Component_Size;
7853 ----------------------
7854 -- Register_Handler --
7855 ----------------------
7857 procedure Register_Handler is
7859 -- All semantic checks already done in Sem_Prag
7861 Prot_Proc : constant Entity_Id :=
7863 (Specification (Current_Node));
7865 Proc_Address : constant Node_Id :=
7866 Make_Attribute_Reference (Loc,
7867 Prefix => New_Reference_To (Prot_Proc, Loc),
7868 Attribute_Name => Name_Address);
7870 RTS_Call : constant Entity_Id :=
7871 Make_Procedure_Call_Statement (Loc,
7874 RTE (RE_Register_Interrupt_Handler), Loc),
7875 Parameter_Associations =>
7876 New_List (Proc_Address));
7878 Append_Freeze_Action (Prot_Proc, RTS_Call);
7879 end Register_Handler;
7881 -- Start of processing for Expand_N_Protected_Type_Declaration
7884 if Present (Corresponding_Record_Type (Prot_Typ)) then
7887 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
7890 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
7892 Qualify_Entity_Names (N);
7894 -- If the type has discriminants, their occurrences in the declaration
7895 -- have been replaced by the corresponding discriminals. For components
7896 -- that are constrained by discriminants, their homologues in the
7897 -- corresponding record type must refer to the discriminants of that
7898 -- record, so we must apply a new renaming to subtypes_indications:
7900 -- protected discriminant => discriminal => record discriminant
7902 -- This replacement is not applied to default expressions, for which
7903 -- the discriminal is correct.
7905 if Has_Discriminants (Prot_Typ) then
7911 Disc := First_Discriminant (Prot_Typ);
7912 Decl := First (Discriminant_Specifications (Rec_Decl));
7913 while Present (Disc) loop
7914 Append_Elmt (Discriminal (Disc), Discr_Map);
7915 Append_Elmt (Defining_Identifier (Decl), Discr_Map);
7916 Next_Discriminant (Disc);
7922 -- Fill in the component declarations
7924 -- Add components for entry families. For each entry family, create an
7925 -- anonymous type declaration with the same size, and analyze the type.
7927 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
7929 -- Prepend the _Object field with the right type to the component list.
7930 -- We need to compute the number of entries, and in some cases the
7931 -- number of Attach_Handler pragmas.
7935 Num_Attach_Handler : Int := 0;
7936 Protection_Subtype : Node_Id;
7937 Entry_Count_Expr : constant Node_Id :=
7938 Build_Entry_Count_Expression
7939 (Prot_Typ, Cdecls, Loc);
7942 -- Could this be simplified using Corresponding_Runtime_Package???
7944 if Has_Attach_Handler (Prot_Typ) then
7945 Ritem := First_Rep_Item (Prot_Typ);
7946 while Present (Ritem) loop
7947 if Nkind (Ritem) = N_Pragma
7948 and then Pragma_Name (Ritem) = Name_Attach_Handler
7950 Num_Attach_Handler := Num_Attach_Handler + 1;
7953 Next_Rep_Item (Ritem);
7956 if Restricted_Profile then
7957 if Has_Entries (Prot_Typ) then
7958 Protection_Subtype :=
7959 New_Reference_To (RTE (RE_Protection_Entry), Loc);
7961 Protection_Subtype :=
7962 New_Reference_To (RTE (RE_Protection), Loc);
7965 Protection_Subtype :=
7966 Make_Subtype_Indication
7970 (RTE (RE_Static_Interrupt_Protection), Loc),
7972 Make_Index_Or_Discriminant_Constraint (
7974 Constraints => New_List (
7976 Make_Integer_Literal (Loc, Num_Attach_Handler))));
7979 elsif Has_Interrupt_Handler (Prot_Typ) then
7980 Protection_Subtype :=
7981 Make_Subtype_Indication (
7983 Subtype_Mark => New_Reference_To
7984 (RTE (RE_Dynamic_Interrupt_Protection), Loc),
7986 Make_Index_Or_Discriminant_Constraint (
7988 Constraints => New_List (Entry_Count_Expr)));
7990 -- Type has explicit entries or generated primitive entry wrappers
7992 elsif Has_Entries (Prot_Typ)
7993 or else (Ada_Version >= Ada_2005
7994 and then Present (Interface_List (N)))
7996 case Corresponding_Runtime_Package (Prot_Typ) is
7997 when System_Tasking_Protected_Objects_Entries =>
7998 Protection_Subtype :=
7999 Make_Subtype_Indication (Loc,
8001 New_Reference_To (RTE (RE_Protection_Entries), Loc),
8003 Make_Index_Or_Discriminant_Constraint (
8005 Constraints => New_List (Entry_Count_Expr)));
8007 when System_Tasking_Protected_Objects_Single_Entry =>
8008 Protection_Subtype :=
8009 New_Reference_To (RTE (RE_Protection_Entry), Loc);
8012 raise Program_Error;
8016 Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc);
8020 Make_Component_Declaration (Loc,
8021 Defining_Identifier =>
8022 Make_Defining_Identifier (Loc, Name_uObject),
8023 Component_Definition =>
8024 Make_Component_Definition (Loc,
8025 Aliased_Present => True,
8026 Subtype_Indication => Protection_Subtype));
8029 pragma Assert (Present (Pdef));
8031 -- Add private field components
8033 if Present (Private_Declarations (Pdef)) then
8034 Priv := First (Private_Declarations (Pdef));
8036 while Present (Priv) loop
8038 if Nkind (Priv) = N_Component_Declaration then
8039 if not Static_Component_Size (Defining_Identifier (Priv)) then
8041 -- When compiling for a restricted profile, the private
8042 -- components must have a static size. If not, this is an
8043 -- error for a single protected declaration, and rates a
8044 -- warning on a protected type declaration.
8046 if not Comes_From_Source (Prot_Typ) then
8047 Check_Restriction (No_Implicit_Heap_Allocations, Priv);
8049 elsif Restriction_Active (No_Implicit_Heap_Allocations) then
8050 Error_Msg_N ("component has non-static size?", Priv);
8052 ("\creation of protected object of type& will violate"
8053 & " restriction No_Implicit_Heap_Allocations?",
8058 -- The component definition consists of a subtype indication,
8059 -- or (in Ada 2005) an access definition. Make a copy of the
8060 -- proper definition.
8063 Old_Comp : constant Node_Id := Component_Definition (Priv);
8064 Oent : constant Entity_Id := Defining_Identifier (Priv);
8066 Nent : constant Entity_Id :=
8067 Make_Defining_Identifier (Sloc (Oent),
8068 Chars => Chars (Oent));
8071 if Present (Subtype_Indication (Old_Comp)) then
8073 Make_Component_Definition (Sloc (Oent),
8074 Aliased_Present => False,
8075 Subtype_Indication =>
8076 New_Copy_Tree (Subtype_Indication (Old_Comp),
8080 Make_Component_Definition (Sloc (Oent),
8081 Aliased_Present => False,
8082 Access_Definition =>
8083 New_Copy_Tree (Access_Definition (Old_Comp),
8088 Make_Component_Declaration (Loc,
8089 Defining_Identifier => Nent,
8090 Component_Definition => New_Comp,
8091 Expression => Expression (Priv));
8093 Set_Has_Per_Object_Constraint (Nent,
8094 Has_Per_Object_Constraint (Oent));
8096 Append_To (Cdecls, New_Priv);
8099 elsif Nkind (Priv) = N_Subprogram_Declaration then
8101 -- Make the unprotected version of the subprogram available
8102 -- for expansion of intra object calls. There is need for
8103 -- a protected version only if the subprogram is an interrupt
8104 -- handler, otherwise this operation can only be called from
8108 Make_Subprogram_Declaration (Loc,
8110 Build_Protected_Sub_Specification
8111 (Priv, Prot_Typ, Unprotected_Mode));
8113 Insert_After (Current_Node, Sub);
8116 Set_Protected_Body_Subprogram
8117 (Defining_Unit_Name (Specification (Priv)),
8118 Defining_Unit_Name (Specification (Sub)));
8119 Check_Inlining (Defining_Unit_Name (Specification (Priv)));
8120 Current_Node := Sub;
8123 Make_Subprogram_Declaration (Loc,
8125 Build_Protected_Sub_Specification
8126 (Priv, Prot_Typ, Protected_Mode));
8128 Insert_After (Current_Node, Sub);
8130 Current_Node := Sub;
8132 if Is_Interrupt_Handler
8133 (Defining_Unit_Name (Specification (Priv)))
8135 if not Restricted_Profile then
8145 -- Put the _Object component after the private component so that it
8146 -- be finalized early as required by 9.4 (20)
8148 Append_To (Cdecls, Object_Comp);
8150 Insert_After (Current_Node, Rec_Decl);
8151 Current_Node := Rec_Decl;
8153 -- Analyze the record declaration immediately after construction,
8154 -- because the initialization procedure is needed for single object
8155 -- declarations before the next entity is analyzed (the freeze call
8156 -- that generates this initialization procedure is found below).
8158 Analyze (Rec_Decl, Suppress => All_Checks);
8160 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
8161 -- the corresponding record is frozen. If any wrappers are generated,
8162 -- Current_Node is updated accordingly.
8164 if Ada_Version >= Ada_2005 then
8165 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
8168 -- Collect pointers to entry bodies and their barriers, to be placed
8169 -- in the Entry_Bodies_Array for the type. For each entry/family we
8170 -- add an expression to the aggregate which is the initial value of
8171 -- this array. The array is declared after all protected subprograms.
8173 if Has_Entries (Prot_Typ) then
8174 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
8176 Entries_Aggr := Empty;
8179 -- Build two new procedure specifications for each protected subprogram;
8180 -- one to call from outside the object and one to call from inside.
8181 -- Build a barrier function and an entry body action procedure
8182 -- specification for each protected entry. Initialize the entry body
8183 -- array. If subprogram is flagged as eliminated, do not generate any
8184 -- internal operations.
8188 Comp := First (Visible_Declarations (Pdef));
8190 while Present (Comp) loop
8191 if Nkind (Comp) = N_Subprogram_Declaration then
8193 Make_Subprogram_Declaration (Loc,
8195 Build_Protected_Sub_Specification
8196 (Comp, Prot_Typ, Unprotected_Mode));
8198 Insert_After (Current_Node, Sub);
8201 Set_Protected_Body_Subprogram
8202 (Defining_Unit_Name (Specification (Comp)),
8203 Defining_Unit_Name (Specification (Sub)));
8204 Check_Inlining (Defining_Unit_Name (Specification (Comp)));
8206 -- Make the protected version of the subprogram available for
8207 -- expansion of external calls.
8209 Current_Node := Sub;
8212 Make_Subprogram_Declaration (Loc,
8214 Build_Protected_Sub_Specification
8215 (Comp, Prot_Typ, Protected_Mode));
8217 Insert_After (Current_Node, Sub);
8220 Current_Node := Sub;
8222 -- Generate an overriding primitive operation specification for
8223 -- this subprogram if the protected type implements an interface.
8225 if Ada_Version >= Ada_2005
8227 Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
8230 Make_Subprogram_Declaration (Loc,
8232 Build_Protected_Sub_Specification
8233 (Comp, Prot_Typ, Dispatching_Mode));
8235 Insert_After (Current_Node, Sub);
8238 Current_Node := Sub;
8241 -- If a pragma Interrupt_Handler applies, build and add a call to
8242 -- Register_Interrupt_Handler to the freezing actions of the
8243 -- protected version (Current_Node) of the subprogram:
8245 -- system.interrupts.register_interrupt_handler
8246 -- (prot_procP'address);
8248 if not Restricted_Profile
8249 and then Is_Interrupt_Handler
8250 (Defining_Unit_Name (Specification (Comp)))
8255 elsif Nkind (Comp) = N_Entry_Declaration then
8256 E_Count := E_Count + 1;
8257 Comp_Id := Defining_Identifier (Comp);
8260 Make_Defining_Identifier (Loc,
8261 Build_Selected_Name (Prot_Typ, Comp_Id, 'E'));
8263 Make_Subprogram_Declaration (Loc,
8265 Build_Protected_Entry_Specification (Loc, Edef, Comp_Id));
8267 Insert_After (Current_Node, Sub);
8270 -- build wrapper procedure for pre/postconditions.
8272 Build_PPC_Wrapper (Comp_Id, N);
8274 Set_Protected_Body_Subprogram
8275 (Defining_Identifier (Comp),
8276 Defining_Unit_Name (Specification (Sub)));
8278 Current_Node := Sub;
8281 Make_Defining_Identifier (Loc,
8282 Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B'));
8284 Make_Subprogram_Declaration (Loc,
8286 Build_Barrier_Function_Specification (Loc, Bdef));
8288 Insert_After (Current_Node, Sub);
8290 Set_Protected_Body_Subprogram (Bdef, Bdef);
8291 Set_Barrier_Function (Comp_Id, Bdef);
8292 Set_Scope (Bdef, Scope (Comp_Id));
8293 Current_Node := Sub;
8295 -- Collect pointers to the protected subprogram and the barrier
8296 -- of the current entry, for insertion into Entry_Bodies_Array.
8299 Make_Aggregate (Loc,
8300 Expressions => New_List (
8301 Make_Attribute_Reference (Loc,
8302 Prefix => New_Reference_To (Bdef, Loc),
8303 Attribute_Name => Name_Unrestricted_Access),
8304 Make_Attribute_Reference (Loc,
8305 Prefix => New_Reference_To (Edef, Loc),
8306 Attribute_Name => Name_Unrestricted_Access))),
8307 Expressions (Entries_Aggr));
8314 -- If there are some private entry declarations, expand it as if they
8315 -- were visible entries.
8317 if Present (Private_Declarations (Pdef)) then
8318 Comp := First (Private_Declarations (Pdef));
8319 while Present (Comp) loop
8320 if Nkind (Comp) = N_Entry_Declaration then
8321 E_Count := E_Count + 1;
8322 Comp_Id := Defining_Identifier (Comp);
8325 Make_Defining_Identifier (Loc,
8326 Build_Selected_Name (Prot_Typ, Comp_Id, 'E'));
8328 Make_Subprogram_Declaration (Loc,
8330 Build_Protected_Entry_Specification (Loc, Edef, Comp_Id));
8332 Insert_After (Current_Node, Sub);
8335 Set_Protected_Body_Subprogram
8336 (Defining_Identifier (Comp),
8337 Defining_Unit_Name (Specification (Sub)));
8339 Current_Node := Sub;
8342 Make_Defining_Identifier (Loc,
8343 Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E'));
8346 Make_Subprogram_Declaration (Loc,
8348 Build_Barrier_Function_Specification (Loc, Bdef));
8350 Insert_After (Current_Node, Sub);
8352 Set_Protected_Body_Subprogram (Bdef, Bdef);
8353 Set_Barrier_Function (Comp_Id, Bdef);
8354 Set_Scope (Bdef, Scope (Comp_Id));
8355 Current_Node := Sub;
8357 -- Collect pointers to the protected subprogram and the barrier
8358 -- of the current entry, for insertion into Entry_Bodies_Array.
8360 Append_To (Expressions (Entries_Aggr),
8361 Make_Aggregate (Loc,
8362 Expressions => New_List (
8363 Make_Attribute_Reference (Loc,
8364 Prefix => New_Reference_To (Bdef, Loc),
8365 Attribute_Name => Name_Unrestricted_Access),
8366 Make_Attribute_Reference (Loc,
8367 Prefix => New_Reference_To (Edef, Loc),
8368 Attribute_Name => Name_Unrestricted_Access))));
8375 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
8376 -- all protected subprograms have been collected.
8378 if Has_Entries (Prot_Typ) then
8380 Make_Defining_Identifier (Sloc (Prot_Typ),
8381 Chars => New_External_Name (Chars (Prot_Typ), 'A'));
8383 case Corresponding_Runtime_Package (Prot_Typ) is
8384 when System_Tasking_Protected_Objects_Entries =>
8385 Body_Arr := Make_Object_Declaration (Loc,
8386 Defining_Identifier => Body_Id,
8387 Aliased_Present => True,
8388 Object_Definition =>
8389 Make_Subtype_Indication (Loc,
8390 Subtype_Mark => New_Reference_To (
8391 RTE (RE_Protected_Entry_Body_Array), Loc),
8393 Make_Index_Or_Discriminant_Constraint (Loc,
8394 Constraints => New_List (
8396 Make_Integer_Literal (Loc, 1),
8397 Make_Integer_Literal (Loc, E_Count))))),
8398 Expression => Entries_Aggr);
8400 when System_Tasking_Protected_Objects_Single_Entry =>
8401 Body_Arr := Make_Object_Declaration (Loc,
8402 Defining_Identifier => Body_Id,
8403 Aliased_Present => True,
8404 Object_Definition => New_Reference_To
8405 (RTE (RE_Entry_Body), Loc),
8407 Make_Aggregate (Loc,
8408 Expressions => New_List (
8409 Make_Attribute_Reference (Loc,
8410 Prefix => New_Reference_To (Bdef, Loc),
8411 Attribute_Name => Name_Unrestricted_Access),
8412 Make_Attribute_Reference (Loc,
8413 Prefix => New_Reference_To (Edef, Loc),
8414 Attribute_Name => Name_Unrestricted_Access))));
8417 raise Program_Error;
8420 -- A pointer to this array will be placed in the corresponding record
8421 -- by its initialization procedure so this needs to be analyzed here.
8423 Insert_After (Current_Node, Body_Arr);
8424 Current_Node := Body_Arr;
8427 Set_Entry_Bodies_Array (Prot_Typ, Body_Id);
8429 -- Finally, build the function that maps an entry index into the
8430 -- corresponding body. A pointer to this function is placed in each
8431 -- object of the type. Except for a ravenscar-like profile (no abort,
8432 -- no entry queue, 1 entry)
8434 if Corresponding_Runtime_Package (Prot_Typ) =
8435 System_Tasking_Protected_Objects_Entries
8438 Make_Subprogram_Declaration (Loc,
8439 Specification => Build_Find_Body_Index_Spec (Prot_Typ));
8440 Insert_After (Current_Node, Sub);
8444 end Expand_N_Protected_Type_Declaration;
8446 --------------------------------
8447 -- Expand_N_Requeue_Statement --
8448 --------------------------------
8450 -- A non-dispatching requeue statement is expanded into one of four GNARLI
8451 -- operations, depending on the source and destination (task or protected
8452 -- object). A dispatching requeue statement is expanded into a call to the
8453 -- predefined primitive _Disp_Requeue. In addition, code is generated to
8454 -- jump around the remainder of processing for the original entry and, if
8455 -- the destination is (different) protected object, to attempt to service
8456 -- it. The following illustrates the various cases:
8459 -- (O : System.Address;
8460 -- P : System.Address;
8461 -- E : Protected_Entry_Index)
8463 -- <discriminant renamings>
8464 -- <private object renamings>
8465 -- type poVP is access poV;
8466 -- _object : ptVP := ptVP!(O);
8470 -- <start of statement sequence for entry>
8472 -- -- Requeue from one protected entry body to another protected
8475 -- Requeue_Protected_Entry (
8476 -- _object._object'Access,
8477 -- new._object'Access,
8482 -- <some more of the statement sequence for entry>
8484 -- -- Requeue from an entry body to a task entry
8486 -- Requeue_Protected_To_Task_Entry (
8492 -- <rest of statement sequence for entry>
8493 -- Complete_Entry_Body (_object._object);
8496 -- when all others =>
8497 -- Exceptional_Complete_Entry_Body (
8498 -- _object._object, Get_GNAT_Exception);
8502 -- Requeue of a task entry call to a task entry
8504 -- Accept_Call (E, Ann);
8505 -- <start of statement sequence for accept statement>
8506 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
8508 -- <rest of statement sequence for accept statement>
8510 -- Complete_Rendezvous;
8513 -- when all others =>
8514 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8516 -- Requeue of a task entry call to a protected entry
8518 -- Accept_Call (E, Ann);
8519 -- <start of statement sequence for accept statement>
8520 -- Requeue_Task_To_Protected_Entry (
8521 -- new._object'Access,
8526 -- <rest of statement sequence for accept statement>
8528 -- Complete_Rendezvous;
8531 -- when all others =>
8532 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8534 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8535 -- marked by pragma Implemented (XXX, By_Entry).
8537 -- The requeue is inside a protected entry:
8540 -- (O : System.Address;
8541 -- P : System.Address;
8542 -- E : Protected_Entry_Index)
8544 -- <discriminant renamings>
8545 -- <private object renamings>
8546 -- type poVP is access poV;
8547 -- _object : ptVP := ptVP!(O);
8551 -- <start of statement sequence for entry>
8554 -- (<interface class-wide object>,
8557 -- Ada.Tags.Get_Offset_Index
8559 -- <interface dispatch table index of target entry>),
8563 -- <rest of statement sequence for entry>
8564 -- Complete_Entry_Body (_object._object);
8567 -- when all others =>
8568 -- Exceptional_Complete_Entry_Body (
8569 -- _object._object, Get_GNAT_Exception);
8573 -- The requeue is inside a task entry:
8575 -- Accept_Call (E, Ann);
8576 -- <start of statement sequence for accept statement>
8578 -- (<interface class-wide object>,
8581 -- Ada.Tags.Get_Offset_Index
8583 -- <interface dispatch table index of target entrt>),
8587 -- <rest of statement sequence for accept statement>
8589 -- Complete_Rendezvous;
8592 -- when all others =>
8593 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8595 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8596 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
8597 -- statement is replaced by a dispatching call with actual parameters taken
8598 -- from the inner-most accept statement or entry body.
8600 -- Target.Primitive (Param1, ..., ParamN);
8602 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8603 -- marked by pragma Implemented (XXX, By_Any) or not marked at all.
8606 -- S : constant Offset_Index :=
8607 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
8608 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
8611 -- if C = POK_Protected_Entry
8612 -- or else C = POK_Task_Entry
8614 -- <statements for dispatching requeue>
8616 -- elsif C = POK_Protected_Procedure then
8617 -- <dispatching call equivalent>
8620 -- raise Program_Error;
8624 procedure Expand_N_Requeue_Statement (N : Node_Id) is
8625 Loc : constant Source_Ptr := Sloc (N);
8626 Conc_Typ : Entity_Id;
8630 Old_Typ : Entity_Id;
8632 function Build_Dispatching_Call_Equivalent return Node_Id;
8633 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8634 -- the form Concval.Ename. It is statically known that Ename is allowed
8635 -- to be implemented by a protected procedure. Create a dispatching call
8636 -- equivalent of Concval.Ename taking the actual parameters from the
8637 -- inner-most accept statement or entry body.
8639 function Build_Dispatching_Requeue return Node_Id;
8640 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8641 -- the form Concval.Ename. It is statically known that Ename is allowed
8642 -- to be implemented by a protected or a task entry. Create a call to
8643 -- primitive _Disp_Requeue which handles the low-level actions.
8645 function Build_Dispatching_Requeue_To_Any return Node_Id;
8646 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8647 -- the form Concval.Ename. Ename is either marked by pragma Implemented
8648 -- (XXX, By_Any) or not marked at all. Create a block which determines
8649 -- at runtime whether Ename denotes an entry or a procedure and perform
8650 -- the appropriate kind of dispatching select.
8652 function Build_Normal_Requeue return Node_Id;
8653 -- N denotes a non-dispatching requeue statement to either a task or a
8654 -- protected entry. Build the appropriate runtime call to perform the
8657 function Build_Skip_Statement (Search : Node_Id) return Node_Id;
8658 -- For a protected entry, create a return statement to skip the rest of
8659 -- the entry body. Otherwise, create a goto statement to skip the rest
8660 -- of a task accept statement. The lookup for the enclosing entry body
8661 -- or accept statement starts from Search.
8663 ---------------------------------------
8664 -- Build_Dispatching_Call_Equivalent --
8665 ---------------------------------------
8667 function Build_Dispatching_Call_Equivalent return Node_Id is
8668 Call_Ent : constant Entity_Id := Entity (Ename);
8669 Obj : constant Node_Id := Original_Node (Concval);
8676 -- Climb the parent chain looking for the inner-most entry body or
8677 -- accept statement.
8680 while Present (Acc_Ent)
8681 and then not Nkind_In (Acc_Ent, N_Accept_Statement,
8684 Acc_Ent := Parent (Acc_Ent);
8687 -- A requeue statement should be housed inside an entry body or an
8688 -- accept statement at some level. If this is not the case, then the
8689 -- tree is malformed.
8691 pragma Assert (Present (Acc_Ent));
8693 -- Recover the list of formal parameters
8695 if Nkind (Acc_Ent) = N_Entry_Body then
8696 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
8699 Formals := Parameter_Specifications (Acc_Ent);
8701 -- Create the actual parameters for the dispatching call. These are
8702 -- simply copies of the entry body or accept statement formals in the
8703 -- same order as they appear.
8707 if Present (Formals) then
8708 Actuals := New_List;
8709 Formal := First (Formals);
8710 while Present (Formal) loop
8712 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
8718 -- Obj.Call_Ent (Actuals);
8721 Make_Procedure_Call_Statement (Loc,
8723 Make_Selected_Component (Loc,
8724 Prefix => Make_Identifier (Loc, Chars (Obj)),
8725 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))),
8727 Parameter_Associations => Actuals);
8728 end Build_Dispatching_Call_Equivalent;
8730 -------------------------------
8731 -- Build_Dispatching_Requeue --
8732 -------------------------------
8734 function Build_Dispatching_Requeue return Node_Id is
8735 Params : constant List_Id := New_List;
8738 -- Process the "with abort" parameter
8741 New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
8743 -- Process the entry wrapper's position in the primary dispatch
8744 -- table parameter. Generate:
8746 -- Ada.Tags.Get_Offset_Index
8747 -- (Ada.Tags.Tag (Concval),
8748 -- <interface dispatch table position of Ename>)
8750 if Tagged_Type_Expansion then
8752 Make_Function_Call (Loc,
8753 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
8754 Parameter_Associations => New_List (
8755 Unchecked_Convert_To (RTE (RE_Tag), Concval),
8756 Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
8762 Make_Function_Call (Loc,
8763 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
8765 Parameter_Associations => New_List (
8769 Make_Attribute_Reference (Loc,
8771 Attribute_Name => Name_Tag),
8775 Make_Attribute_Reference (Loc,
8776 Prefix => New_Reference_To (Etype (Concval), Loc),
8777 Attribute_Name => Name_Tag),
8781 Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
8784 -- Specific actuals for protected to XXX requeue
8786 if Is_Protected_Type (Old_Typ) then
8788 Make_Attribute_Reference (Loc, -- _object'Address
8790 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
8791 Attribute_Name => Name_Address));
8793 Prepend_To (Params, -- True
8794 New_Reference_To (Standard_True, Loc));
8796 -- Specific actuals for task to XXX requeue
8799 pragma Assert (Is_Task_Type (Old_Typ));
8801 Prepend_To (Params, -- null
8802 New_Reference_To (RTE (RE_Null_Address), Loc));
8804 Prepend_To (Params, -- False
8805 New_Reference_To (Standard_False, Loc));
8808 -- Add the object parameter
8810 Prepend_To (Params, New_Copy_Tree (Concval));
8813 -- _Disp_Requeue (<Params>);
8816 Make_Procedure_Call_Statement (Loc,
8817 Name => Make_Identifier (Loc, Name_uDisp_Requeue),
8818 Parameter_Associations => Params);
8819 end Build_Dispatching_Requeue;
8821 --------------------------------------
8822 -- Build_Dispatching_Requeue_To_Any --
8823 --------------------------------------
8825 function Build_Dispatching_Requeue_To_Any return Node_Id is
8826 Call_Ent : constant Entity_Id := Entity (Ename);
8827 Obj : constant Node_Id := Original_Node (Concval);
8828 Skip : constant Node_Id := Build_Skip_Statement (N);
8838 -- Dispatch table slot processing, generate:
8841 S := Build_S (Loc, Decls);
8843 -- Call kind processing, generate:
8844 -- C : Ada.Tags.Prim_Op_Kind;
8846 C := Build_C (Loc, Decls);
8849 -- S := Ada.Tags.Get_Offset_Index
8850 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
8852 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
8855 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
8858 Make_Procedure_Call_Statement (Loc,
8861 Find_Prim_Op (Etype (Etype (Obj)),
8862 Name_uDisp_Get_Prim_Op_Kind),
8864 Parameter_Associations => New_List (
8865 New_Copy_Tree (Obj),
8866 New_Reference_To (S, Loc),
8867 New_Reference_To (C, Loc))));
8871 -- if C = POK_Protected_Entry
8872 -- or else C = POK_Task_Entry
8875 Make_If_Statement (Loc,
8881 New_Reference_To (C, Loc),
8883 New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
8888 New_Reference_To (C, Loc),
8890 New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
8892 -- Dispatching requeue equivalent
8894 Then_Statements => New_List (
8895 Build_Dispatching_Requeue,
8898 -- elsif C = POK_Protected_Procedure then
8900 Elsif_Parts => New_List (
8901 Make_Elsif_Part (Loc,
8905 New_Reference_To (C, Loc),
8908 RTE (RE_POK_Protected_Procedure), Loc)),
8910 -- Dispatching call equivalent
8912 Then_Statements => New_List (
8913 Build_Dispatching_Call_Equivalent))),
8916 -- raise Program_Error;
8919 Else_Statements => New_List (
8920 Make_Raise_Program_Error (Loc,
8921 Reason => PE_Explicit_Raise))));
8923 -- Wrap everything into a block
8926 Make_Block_Statement (Loc,
8927 Declarations => Decls,
8928 Handled_Statement_Sequence =>
8929 Make_Handled_Sequence_Of_Statements (Loc,
8930 Statements => Stmts));
8931 end Build_Dispatching_Requeue_To_Any;
8933 --------------------------
8934 -- Build_Normal_Requeue --
8935 --------------------------
8937 function Build_Normal_Requeue return Node_Id is
8938 Params : constant List_Id := New_List;
8943 -- Process the "with abort" parameter
8946 New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
8948 -- Add the index expression to the parameters. It is common among all
8952 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
8954 if Is_Protected_Type (Old_Typ) then
8956 Self_Param : Node_Id;
8960 Make_Attribute_Reference (Loc,
8962 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
8964 Name_Unchecked_Access);
8966 -- Protected to protected requeue
8968 if Is_Protected_Type (Conc_Typ) then
8971 RTE (RE_Requeue_Protected_Entry), Loc);
8974 Make_Attribute_Reference (Loc,
8976 Concurrent_Ref (Concval),
8978 Name_Unchecked_Access);
8980 -- Protected to task requeue
8982 else pragma Assert (Is_Task_Type (Conc_Typ));
8985 RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
8987 Param := Concurrent_Ref (Concval);
8990 Prepend_To (Params, Param);
8991 Prepend_To (Params, Self_Param);
8994 else pragma Assert (Is_Task_Type (Old_Typ));
8996 -- Task to protected requeue
8998 if Is_Protected_Type (Conc_Typ) then
9001 RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
9004 Make_Attribute_Reference (Loc,
9006 Concurrent_Ref (Concval),
9008 Name_Unchecked_Access);
9010 -- Task to task requeue
9012 else pragma Assert (Is_Task_Type (Conc_Typ));
9014 New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc);
9016 Param := Concurrent_Ref (Concval);
9019 Prepend_To (Params, Param);
9023 Make_Procedure_Call_Statement (Loc,
9025 Parameter_Associations => Params);
9026 end Build_Normal_Requeue;
9028 --------------------------
9029 -- Build_Skip_Statement --
9030 --------------------------
9032 function Build_Skip_Statement (Search : Node_Id) return Node_Id is
9033 Skip_Stmt : Node_Id;
9036 -- Build a return statement to skip the rest of the entire body
9038 if Is_Protected_Type (Old_Typ) then
9039 Skip_Stmt := Make_Simple_Return_Statement (Loc);
9041 -- If the requeue is within a task, find the end label of the
9042 -- enclosing accept statement and create a goto statement to it.
9050 -- Climb the parent chain looking for the enclosing accept
9053 Acc := Parent (Search);
9055 and then Nkind (Acc) /= N_Accept_Statement
9057 Acc := Parent (Acc);
9060 -- The last statement is the second label used for completing
9061 -- the rendezvous the usual way. The label we are looking for
9062 -- is right before it.
9065 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
9067 pragma Assert (Nkind (Label) = N_Label);
9069 -- Generate a goto statement to skip the rest of the accept
9072 Make_Goto_Statement (Loc,
9074 New_Occurrence_Of (Entity (Identifier (Label)), Loc));
9078 Set_Analyzed (Skip_Stmt);
9081 end Build_Skip_Statement;
9083 -- Start of processing for Expand_N_Requeue_Statement
9086 -- Extract the components of the entry call
9088 Extract_Entry (N, Concval, Ename, Index);
9089 Conc_Typ := Etype (Concval);
9091 -- Examine the scope stack in order to find nearest enclosing protected
9092 -- or task type. This will constitute our invocation source.
9094 Old_Typ := Current_Scope;
9095 while Present (Old_Typ)
9096 and then not Is_Protected_Type (Old_Typ)
9097 and then not Is_Task_Type (Old_Typ)
9099 Old_Typ := Scope (Old_Typ);
9102 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
9103 -- Concval.Ename where the type of Concval is class-wide concurrent
9106 if Ada_Version >= Ada_2012
9107 and then Present (Concval)
9108 and then Is_Class_Wide_Type (Conc_Typ)
9109 and then Is_Concurrent_Interface (Conc_Typ)
9112 Has_Impl : Boolean := False;
9113 Impl_Kind : Name_Id := No_Name;
9116 -- Check whether the Ename is flagged by pragma Implemented
9118 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
9120 Impl_Kind := Implementation_Kind (Entity (Ename));
9123 -- The procedure_or_entry_NAME is guaranteed to be overridden by
9124 -- an entry. Create a call to predefined primitive _Disp_Requeue.
9127 and then Impl_Kind = Name_By_Entry
9129 Rewrite (N, Build_Dispatching_Requeue);
9131 Insert_After (N, Build_Skip_Statement (N));
9133 -- The procedure_or_entry_NAME is guaranteed to be overridden by
9134 -- a protected procedure. In this case the requeue is transformed
9135 -- into a dispatching call.
9138 and then Impl_Kind = Name_By_Protected_Procedure
9140 Rewrite (N, Build_Dispatching_Call_Equivalent);
9143 -- The procedure_or_entry_NAME's implementation kind is either
9144 -- By_Any or pragma Implemented was not applied at all. In this
9145 -- case a runtime test determines whether Ename denotes an entry
9146 -- or a protected procedure and performs the appropriate call.
9149 Rewrite (N, Build_Dispatching_Requeue_To_Any);
9154 -- Processing for regular (non-dispatching) requeues
9157 Rewrite (N, Build_Normal_Requeue);
9159 Insert_After (N, Build_Skip_Statement (N));
9161 end Expand_N_Requeue_Statement;
9163 -------------------------------
9164 -- Expand_N_Selective_Accept --
9165 -------------------------------
9167 procedure Expand_N_Selective_Accept (N : Node_Id) is
9168 Loc : constant Source_Ptr := Sloc (N);
9169 Alts : constant List_Id := Select_Alternatives (N);
9171 -- Note: in the below declarations a lot of new lists are allocated
9172 -- unconditionally which may well not end up being used. That's
9173 -- not a good idea since it wastes space gratuitously ???
9175 Accept_Case : List_Id;
9176 Accept_List : constant List_Id := New_List;
9179 Alt_List : constant List_Id := New_List;
9180 Alt_Stats : List_Id;
9181 Ann : Entity_Id := Empty;
9184 Check_Guard : Boolean := True;
9186 Decls : constant List_Id := New_List;
9187 Stats : constant List_Id := New_List;
9188 Body_List : constant List_Id := New_List;
9189 Trailing_List : constant List_Id := New_List;
9192 Else_Present : Boolean := False;
9193 Terminate_Alt : Node_Id := Empty;
9194 Select_Mode : Node_Id;
9196 Delay_Case : List_Id;
9197 Delay_Count : Integer := 0;
9198 Delay_Val : Entity_Id;
9199 Delay_Index : Entity_Id;
9200 Delay_Min : Entity_Id;
9201 Delay_Num : Int := 1;
9202 Delay_Alt_List : List_Id := New_List;
9203 Delay_List : constant List_Id := New_List;
9207 First_Delay : Boolean := True;
9208 Guard_Open : Entity_Id;
9214 Num_Accept : Nat := 0;
9217 Time_Type : Entity_Id;
9219 Select_Call : Node_Id;
9221 Qnam : constant Entity_Id :=
9222 Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
9224 Xnam : constant Entity_Id :=
9225 Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
9227 -----------------------
9228 -- Local subprograms --
9229 -----------------------
9231 function Accept_Or_Raise return List_Id;
9232 -- For the rare case where delay alternatives all have guards, and
9233 -- all of them are closed, it is still possible that there were open
9234 -- accept alternatives with no callers. We must reexamine the
9235 -- Accept_List, and execute a selective wait with no else if some
9236 -- accept is open. If none, we raise program_error.
9238 procedure Add_Accept (Alt : Node_Id);
9239 -- Process a single accept statement in a select alternative. Build
9240 -- procedure for body of accept, and add entry to dispatch table with
9241 -- expression for guard, in preparation for call to run time select.
9243 function Make_And_Declare_Label (Num : Int) return Node_Id;
9244 -- Manufacture a label using Num as a serial number and declare it.
9245 -- The declaration is appended to Decls. The label marks the trailing
9246 -- statements of an accept or delay alternative.
9248 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
9249 -- Build call to Selective_Wait runtime routine
9251 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
9252 -- Add code to compare value of delay with previous values, and
9253 -- generate case entry for trailing statements.
9255 procedure Process_Accept_Alternative
9259 -- Add code to call corresponding procedure, and branch to
9260 -- trailing statements, if any.
9262 ---------------------
9263 -- Accept_Or_Raise --
9264 ---------------------
9266 function Accept_Or_Raise return List_Id is
9269 J : constant Entity_Id := Make_Temporary (Loc, 'J');
9272 -- We generate the following:
9274 -- for J in q'range loop
9275 -- if q(J).S /=null_task_entry then
9276 -- selective_wait (simple_mode,...);
9282 -- if no rendez_vous then
9283 -- raise program_error;
9286 -- Note that the code needs to know that the selector name
9287 -- in an Accept_Alternative is named S.
9289 Cond := Make_Op_Ne (Loc,
9291 Make_Selected_Component (Loc,
9293 Make_Indexed_Component (Loc,
9294 Prefix => New_Reference_To (Qnam, Loc),
9295 Expressions => New_List (New_Reference_To (J, Loc))),
9296 Selector_Name => Make_Identifier (Loc, Name_S)),
9298 New_Reference_To (RTE (RE_Null_Task_Entry), Loc));
9301 Make_Implicit_Loop_Statement (N,
9302 Identifier => Empty,
9304 Make_Iteration_Scheme (Loc,
9305 Loop_Parameter_Specification =>
9306 Make_Loop_Parameter_Specification (Loc,
9307 Defining_Identifier => J,
9308 Discrete_Subtype_Definition =>
9309 Make_Attribute_Reference (Loc,
9310 Prefix => New_Reference_To (Qnam, Loc),
9311 Attribute_Name => Name_Range,
9312 Expressions => New_List (
9313 Make_Integer_Literal (Loc, 1))))),
9315 Statements => New_List (
9316 Make_Implicit_If_Statement (N,
9318 Then_Statements => New_List (
9320 New_Reference_To (RTE (RE_Simple_Mode), Loc)),
9321 Make_Exit_Statement (Loc))))));
9324 Make_Raise_Program_Error (Loc,
9325 Condition => Make_Op_Eq (Loc,
9326 Left_Opnd => New_Reference_To (Xnam, Loc),
9328 New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
9329 Reason => PE_All_Guards_Closed));
9332 end Accept_Or_Raise;
9338 procedure Add_Accept (Alt : Node_Id) is
9339 Acc_Stm : constant Node_Id := Accept_Statement (Alt);
9340 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm);
9341 Eloc : constant Source_Ptr := Sloc (Ename);
9342 Eent : constant Entity_Id := Entity (Ename);
9343 Index : constant Node_Id := Entry_Index (Acc_Stm);
9344 Null_Body : Node_Id;
9345 Proc_Body : Node_Id;
9352 Ann := Node (Last_Elmt (Accept_Address (Eent)));
9355 if Present (Condition (Alt)) then
9357 Make_Conditional_Expression (Eloc, New_List (
9359 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
9360 New_Reference_To (RTE (RE_Null_Task_Entry), Eloc)));
9363 Entry_Index_Expression
9364 (Eloc, Eent, Index, Scope (Eent));
9367 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
9368 Null_Body := New_Reference_To (Standard_False, Eloc);
9370 if Abort_Allowed then
9371 Call := Make_Procedure_Call_Statement (Eloc,
9372 Name => New_Reference_To (RTE (RE_Abort_Undefer), Eloc));
9373 Insert_Before (First (Statements (Handled_Statement_Sequence (
9374 Accept_Statement (Alt)))), Call);
9379 Make_Defining_Identifier (Eloc,
9380 New_External_Name (Chars (Ename), 'A', Num_Accept));
9382 if Comes_From_Source (Alt) then
9383 Set_Debug_Info_Needed (PB_Ent);
9387 Make_Subprogram_Body (Eloc,
9389 Make_Procedure_Specification (Eloc,
9390 Defining_Unit_Name => PB_Ent),
9391 Declarations => Declarations (Acc_Stm),
9392 Handled_Statement_Sequence =>
9393 Build_Accept_Body (Accept_Statement (Alt)));
9395 -- During the analysis of the body of the accept statement, any
9396 -- zero cost exception handler records were collected in the
9397 -- Accept_Handler_Records field of the N_Accept_Alternative node.
9398 -- This is where we move them to where they belong, namely the
9399 -- newly created procedure.
9401 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
9402 Append (Proc_Body, Body_List);
9405 Null_Body := New_Reference_To (Standard_True, Eloc);
9407 -- if accept statement has declarations, insert above, given that
9408 -- we are not creating a body for the accept.
9410 if Present (Declarations (Acc_Stm)) then
9411 Insert_Actions (N, Declarations (Acc_Stm));
9415 Append_To (Accept_List,
9416 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr)));
9418 Num_Accept := Num_Accept + 1;
9421 ----------------------------
9422 -- Make_And_Declare_Label --
9423 ----------------------------
9425 function Make_And_Declare_Label (Num : Int) return Node_Id is
9429 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
9431 Make_Label (Loc, Lab_Id);
9434 Make_Implicit_Label_Declaration (Loc,
9435 Defining_Identifier =>
9436 Make_Defining_Identifier (Loc, Chars (Lab_Id)),
9437 Label_Construct => Lab));
9440 end Make_And_Declare_Label;
9442 ----------------------
9443 -- Make_Select_Call --
9444 ----------------------
9446 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
9447 Params : constant List_Id := New_List;
9451 Make_Attribute_Reference (Loc,
9452 Prefix => New_Reference_To (Qnam, Loc),
9453 Attribute_Name => Name_Unchecked_Access),
9455 Append (Select_Mode, Params);
9456 Append (New_Reference_To (Ann, Loc), Params);
9457 Append (New_Reference_To (Xnam, Loc), Params);
9460 Make_Procedure_Call_Statement (Loc,
9461 Name => New_Reference_To (RTE (RE_Selective_Wait), Loc),
9462 Parameter_Associations => Params);
9463 end Make_Select_Call;
9465 --------------------------------
9466 -- Process_Accept_Alternative --
9467 --------------------------------
9469 procedure Process_Accept_Alternative
9474 Choices : List_Id := No_List;
9475 Alt_Stats : List_Id;
9478 Adjust_Condition (Condition (Alt));
9479 Alt_Stats := No_List;
9481 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
9482 Choices := New_List (
9483 Make_Integer_Literal (Loc, Index));
9485 Alt_Stats := New_List (
9486 Make_Procedure_Call_Statement (Sloc (Proc),
9487 Name => New_Reference_To (
9488 Defining_Unit_Name (Specification (Proc)), Sloc (Proc))));
9491 if Statements (Alt) /= Empty_List then
9493 if No (Alt_Stats) then
9495 -- Accept with no body, followed by trailing statements
9497 Choices := New_List (
9498 Make_Integer_Literal (Loc, Index));
9500 Alt_Stats := New_List;
9503 -- After the call, if any, branch to trailing statements. We
9504 -- create a label for each, as well as the corresponding label
9507 Lab := Make_And_Declare_Label (Index);
9508 Append_To (Alt_Stats,
9509 Make_Goto_Statement (Loc,
9510 Name => New_Copy (Identifier (Lab))));
9512 Append (Lab, Trailing_List);
9513 Append_List (Statements (Alt), Trailing_List);
9514 Append_To (Trailing_List,
9515 Make_Goto_Statement (Loc,
9516 Name => New_Copy (Identifier (End_Lab))));
9519 if Present (Alt_Stats) then
9521 -- Procedure call. and/or trailing statements
9523 Append_To (Alt_List,
9524 Make_Case_Statement_Alternative (Loc,
9525 Discrete_Choices => Choices,
9526 Statements => Alt_Stats));
9528 end Process_Accept_Alternative;
9530 -------------------------------
9531 -- Process_Delay_Alternative --
9532 -------------------------------
9534 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
9537 Delay_Alt : List_Id;
9540 -- Deal with C/Fortran boolean as delay condition
9542 Adjust_Condition (Condition (Alt));
9544 -- Determine the smallest specified delay
9546 -- for each delay alternative generate:
9548 -- if guard-expression then
9549 -- Delay_Val := delay-expression;
9550 -- Guard_Open := True;
9551 -- if Delay_Val < Delay_Min then
9552 -- Delay_Min := Delay_Val;
9553 -- Delay_Index := Index;
9557 -- The enclosing if-statement is omitted if there is no guard
9562 First_Delay := False;
9564 Delay_Alt := New_List (
9565 Make_Assignment_Statement (Loc,
9566 Name => New_Reference_To (Delay_Min, Loc),
9567 Expression => Expression (Delay_Statement (Alt))));
9569 if Delay_Count > 1 then
9570 Append_To (Delay_Alt,
9571 Make_Assignment_Statement (Loc,
9572 Name => New_Reference_To (Delay_Index, Loc),
9573 Expression => Make_Integer_Literal (Loc, Index)));
9577 Delay_Alt := New_List (
9578 Make_Assignment_Statement (Loc,
9579 Name => New_Reference_To (Delay_Val, Loc),
9580 Expression => Expression (Delay_Statement (Alt))));
9582 if Time_Type = Standard_Duration then
9585 Left_Opnd => New_Reference_To (Delay_Val, Loc),
9586 Right_Opnd => New_Reference_To (Delay_Min, Loc));
9589 -- The scope of the time type must define a comparison
9590 -- operator. The scope itself may not be visible, so we
9591 -- construct a node with entity information to insure that
9592 -- semantic analysis can find the proper operator.
9595 Make_Function_Call (Loc,
9596 Name => Make_Selected_Component (Loc,
9597 Prefix => New_Reference_To (Scope (Time_Type), Loc),
9599 Make_Operator_Symbol (Loc,
9600 Chars => Name_Op_Lt,
9601 Strval => No_String)),
9602 Parameter_Associations =>
9604 New_Reference_To (Delay_Val, Loc),
9605 New_Reference_To (Delay_Min, Loc)));
9607 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
9610 Append_To (Delay_Alt,
9611 Make_Implicit_If_Statement (N,
9613 Then_Statements => New_List (
9614 Make_Assignment_Statement (Loc,
9615 Name => New_Reference_To (Delay_Min, Loc),
9616 Expression => New_Reference_To (Delay_Val, Loc)),
9618 Make_Assignment_Statement (Loc,
9619 Name => New_Reference_To (Delay_Index, Loc),
9620 Expression => Make_Integer_Literal (Loc, Index)))));
9624 Append_To (Delay_Alt,
9625 Make_Assignment_Statement (Loc,
9626 Name => New_Reference_To (Guard_Open, Loc),
9627 Expression => New_Reference_To (Standard_True, Loc)));
9630 if Present (Condition (Alt)) then
9631 Delay_Alt := New_List (
9632 Make_Implicit_If_Statement (N,
9633 Condition => Condition (Alt),
9634 Then_Statements => Delay_Alt));
9637 Append_List (Delay_Alt, Delay_List);
9639 -- If the delay alternative has a statement part, add choice to the
9640 -- case statements for delays.
9642 if Present (Statements (Alt)) then
9644 if Delay_Count = 1 then
9645 Append_List (Statements (Alt), Delay_Alt_List);
9648 Choices := New_List (
9649 Make_Integer_Literal (Loc, Index));
9651 Append_To (Delay_Alt_List,
9652 Make_Case_Statement_Alternative (Loc,
9653 Discrete_Choices => Choices,
9654 Statements => Statements (Alt)));
9657 elsif Delay_Count = 1 then
9659 -- If the single delay has no trailing statements, add a branch
9660 -- to the exit label to the selective wait.
9662 Delay_Alt_List := New_List (
9663 Make_Goto_Statement (Loc,
9664 Name => New_Copy (Identifier (End_Lab))));
9667 end Process_Delay_Alternative;
9669 -- Start of processing for Expand_N_Selective_Accept
9672 -- First insert some declarations before the select. The first is:
9676 -- This variable holds the parameters passed to the accept body. This
9677 -- declaration has already been inserted by the time we get here by
9678 -- a call to Expand_Accept_Declarations made from the semantics when
9679 -- processing the first accept statement contained in the select. We
9680 -- can find this entity as Accept_Address (E), where E is any of the
9681 -- entries references by contained accept statements.
9683 -- The first step is to scan the list of Selective_Accept_Statements
9684 -- to find this entity, and also count the number of accepts, and
9685 -- determine if terminated, delay or else is present:
9689 Alt := First (Alts);
9690 while Present (Alt) loop
9692 if Nkind (Alt) = N_Accept_Alternative then
9695 elsif Nkind (Alt) = N_Delay_Alternative then
9696 Delay_Count := Delay_Count + 1;
9698 -- If the delays are relative delays, the delay expressions have
9699 -- type Standard_Duration. Otherwise they must have some time type
9700 -- recognized by GNAT.
9702 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
9703 Time_Type := Standard_Duration;
9705 Time_Type := Etype (Expression (Delay_Statement (Alt)));
9707 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
9708 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
9713 "& is not a time type (RM 9.6(6))",
9714 Expression (Delay_Statement (Alt)), Time_Type);
9715 Time_Type := Standard_Duration;
9716 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
9720 if No (Condition (Alt)) then
9722 -- This guard will always be open
9724 Check_Guard := False;
9727 elsif Nkind (Alt) = N_Terminate_Alternative then
9728 Adjust_Condition (Condition (Alt));
9729 Terminate_Alt := Alt;
9732 Num_Alts := Num_Alts + 1;
9736 Else_Present := Present (Else_Statements (N));
9738 -- At the same time (see procedure Add_Accept) we build the accept list:
9740 -- Qnn : Accept_List (1 .. num-select) := (
9741 -- (null-body, entry-index),
9742 -- (null-body, entry-index),
9744 -- (null_body, entry-index));
9746 -- In the above declaration, null-body is True if the corresponding
9747 -- accept has no body, and false otherwise. The entry is either the
9748 -- entry index expression if there is no guard, or if a guard is
9749 -- present, then a conditional expression of the form:
9751 -- (if guard then entry-index else Null_Task_Entry)
9753 -- If a guard is statically known to be false, the entry can simply
9754 -- be omitted from the accept list.
9757 Make_Object_Declaration (Loc,
9758 Defining_Identifier => Qnam,
9759 Object_Definition =>
9760 New_Reference_To (RTE (RE_Accept_List), Loc),
9761 Aliased_Present => True,
9764 Make_Qualified_Expression (Loc,
9766 New_Reference_To (RTE (RE_Accept_List), Loc),
9768 Make_Aggregate (Loc, Expressions => Accept_List)));
9772 -- Then we declare the variable that holds the index for the accept
9773 -- that will be selected for service:
9775 -- Xnn : Select_Index;
9778 Make_Object_Declaration (Loc,
9779 Defining_Identifier => Xnam,
9780 Object_Definition =>
9781 New_Reference_To (RTE (RE_Select_Index), Loc),
9783 New_Reference_To (RTE (RE_No_Rendezvous), Loc));
9787 -- After this follow procedure declarations for each accept body
9794 -- where the ... are statements from the corresponding procedure body.
9795 -- No parameters are involved, since the parameters are passed via Ann
9796 -- and the parameter references have already been expanded to be direct
9797 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
9798 -- any embedded tasking statements (which would normally be illegal in
9799 -- procedures), have been converted to calls to the tasking runtime so
9800 -- there is no problem in putting them into procedures.
9802 -- The original accept statement has been expanded into a block in
9803 -- the same fashion as for simple accepts (see Build_Accept_Body).
9805 -- Note: we don't really need to build these procedures for the case
9806 -- where no delay statement is present, but it is just as easy to
9807 -- build them unconditionally, and not significantly inefficient,
9808 -- since if they are short they will be inlined anyway.
9810 -- The procedure declarations have been assembled in Body_List
9812 -- If delays are present, we must compute the required delay.
9813 -- We first generate the declarations:
9815 -- Delay_Index : Boolean := 0;
9816 -- Delay_Min : Some_Time_Type.Time;
9817 -- Delay_Val : Some_Time_Type.Time;
9819 -- Delay_Index will be set to the index of the minimum delay, i.e. the
9820 -- active delay that is actually chosen as the basis for the possible
9821 -- delay if an immediate rendez-vous is not possible.
9823 -- In the most common case there is a single delay statement, and this
9824 -- is handled specially.
9826 if Delay_Count > 0 then
9828 -- Generate the required declarations
9831 Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
9833 Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
9835 Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
9838 Make_Object_Declaration (Loc,
9839 Defining_Identifier => Delay_Val,
9840 Object_Definition => New_Reference_To (Time_Type, Loc)));
9843 Make_Object_Declaration (Loc,
9844 Defining_Identifier => Delay_Index,
9845 Object_Definition => New_Reference_To (Standard_Integer, Loc),
9846 Expression => Make_Integer_Literal (Loc, 0)));
9849 Make_Object_Declaration (Loc,
9850 Defining_Identifier => Delay_Min,
9851 Object_Definition => New_Reference_To (Time_Type, Loc),
9853 Unchecked_Convert_To (Time_Type,
9854 Make_Attribute_Reference (Loc,
9856 New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
9857 Attribute_Name => Name_Last))));
9859 -- Create Duration and Delay_Mode objects used for passing a delay
9862 D := Make_Temporary (Loc, 'D');
9863 M := Make_Temporary (Loc, 'M');
9869 -- Note that these values are defined in s-osprim.ads and must
9872 -- Relative : constant := 0;
9873 -- Absolute_Calendar : constant := 1;
9874 -- Absolute_RT : constant := 2;
9876 if Time_Type = Standard_Duration then
9877 Discr := Make_Integer_Literal (Loc, 0);
9879 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
9880 Discr := Make_Integer_Literal (Loc, 1);
9884 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
9885 Discr := Make_Integer_Literal (Loc, 2);
9889 Make_Object_Declaration (Loc,
9890 Defining_Identifier => D,
9891 Object_Definition =>
9892 New_Reference_To (Standard_Duration, Loc)));
9895 Make_Object_Declaration (Loc,
9896 Defining_Identifier => M,
9897 Object_Definition =>
9898 New_Reference_To (Standard_Integer, Loc),
9899 Expression => Discr));
9904 Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
9907 Make_Object_Declaration (Loc,
9908 Defining_Identifier => Guard_Open,
9909 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
9910 Expression => New_Reference_To (Standard_False, Loc)));
9913 -- Delay_Count is zero, don't need M and D set (suppress warning)
9920 if Present (Terminate_Alt) then
9922 -- If the terminate alternative guard is False, use
9923 -- Simple_Mode; otherwise use Terminate_Mode.
9925 if Present (Condition (Terminate_Alt)) then
9926 Select_Mode := Make_Conditional_Expression (Loc,
9927 New_List (Condition (Terminate_Alt),
9928 New_Reference_To (RTE (RE_Terminate_Mode), Loc),
9929 New_Reference_To (RTE (RE_Simple_Mode), Loc)));
9931 Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc);
9934 elsif Else_Present or Delay_Count > 0 then
9935 Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc);
9938 Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc);
9941 Select_Call := Make_Select_Call (Select_Mode);
9942 Append (Select_Call, Stats);
9944 -- Now generate code to act on the result. There is an entry
9945 -- in this case for each accept statement with a non-null body,
9946 -- followed by a branch to the statements that follow the Accept.
9947 -- In the absence of delay alternatives, we generate:
9950 -- when No_Rendezvous => -- omitted if simple mode
9965 -- Lab0: Else_Statements;
9968 -- Lab1: Trailing_Statements1;
9971 -- Lab2: Trailing_Statements2;
9976 -- Generate label for common exit
9978 End_Lab := Make_And_Declare_Label (Num_Alts + 1);
9980 -- First entry is the default case, when no rendezvous is possible
9982 Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc));
9984 if Else_Present then
9986 -- If no rendezvous is possible, the else part is executed
9988 Lab := Make_And_Declare_Label (0);
9989 Alt_Stats := New_List (
9990 Make_Goto_Statement (Loc,
9991 Name => New_Copy (Identifier (Lab))));
9993 Append (Lab, Trailing_List);
9994 Append_List (Else_Statements (N), Trailing_List);
9995 Append_To (Trailing_List,
9996 Make_Goto_Statement (Loc,
9997 Name => New_Copy (Identifier (End_Lab))));
9999 Alt_Stats := New_List (
10000 Make_Goto_Statement (Loc,
10001 Name => New_Copy (Identifier (End_Lab))));
10004 Append_To (Alt_List,
10005 Make_Case_Statement_Alternative (Loc,
10006 Discrete_Choices => Choices,
10007 Statements => Alt_Stats));
10009 -- We make use of the fact that Accept_Index is an integer type, and
10010 -- generate successive literals for entries for each accept. Only those
10011 -- for which there is a body or trailing statements get a case entry.
10013 Alt := First (Select_Alternatives (N));
10014 Proc := First (Body_List);
10015 while Present (Alt) loop
10017 if Nkind (Alt) = N_Accept_Alternative then
10018 Process_Accept_Alternative (Alt, Index, Proc);
10019 Index := Index + 1;
10022 (Handled_Statement_Sequence (Accept_Statement (Alt)))
10027 elsif Nkind (Alt) = N_Delay_Alternative then
10028 Process_Delay_Alternative (Alt, Delay_Num);
10029 Delay_Num := Delay_Num + 1;
10035 -- An others choice is always added to the main case, as well
10036 -- as the delay case (to satisfy the compiler).
10038 Append_To (Alt_List,
10039 Make_Case_Statement_Alternative (Loc,
10040 Discrete_Choices =>
10041 New_List (Make_Others_Choice (Loc)),
10043 New_List (Make_Goto_Statement (Loc,
10044 Name => New_Copy (Identifier (End_Lab))))));
10046 Accept_Case := New_List (
10047 Make_Case_Statement (Loc,
10048 Expression => New_Reference_To (Xnam, Loc),
10049 Alternatives => Alt_List));
10051 Append_List (Trailing_List, Accept_Case);
10052 Append (End_Lab, Accept_Case);
10053 Append_List (Body_List, Decls);
10055 -- Construct case statement for trailing statements of delay
10056 -- alternatives, if there are several of them.
10058 if Delay_Count > 1 then
10059 Append_To (Delay_Alt_List,
10060 Make_Case_Statement_Alternative (Loc,
10061 Discrete_Choices =>
10062 New_List (Make_Others_Choice (Loc)),
10064 New_List (Make_Null_Statement (Loc))));
10066 Delay_Case := New_List (
10067 Make_Case_Statement (Loc,
10068 Expression => New_Reference_To (Delay_Index, Loc),
10069 Alternatives => Delay_Alt_List));
10071 Delay_Case := Delay_Alt_List;
10074 -- If there are no delay alternatives, we append the case statement
10075 -- to the statement list.
10077 if Delay_Count = 0 then
10078 Append_List (Accept_Case, Stats);
10080 -- Delay alternatives present
10083 -- If delay alternatives are present we generate:
10085 -- find minimum delay.
10086 -- DX := minimum delay;
10087 -- M := <delay mode>;
10088 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
10091 -- if X = No_Rendezvous then
10092 -- case statement for delay statements.
10094 -- case statement for accept alternatives.
10105 -- The type of the delay expression is known to be legal
10107 if Time_Type = Standard_Duration then
10108 Conv := New_Reference_To (Delay_Min, Loc);
10110 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
10111 Conv := Make_Function_Call (Loc,
10112 New_Reference_To (RTE (RO_CA_To_Duration), Loc),
10113 New_List (New_Reference_To (Delay_Min, Loc)));
10117 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
10119 Conv := Make_Function_Call (Loc,
10120 New_Reference_To (RTE (RO_RT_To_Duration), Loc),
10121 New_List (New_Reference_To (Delay_Min, Loc)));
10124 Stmt := Make_Assignment_Statement (Loc,
10125 Name => New_Reference_To (D, Loc),
10126 Expression => Conv);
10128 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
10130 Parms := Parameter_Associations (Select_Call);
10131 Parm := First (Parms);
10133 while Present (Parm)
10134 and then Parm /= Select_Mode
10139 pragma Assert (Present (Parm));
10140 Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc));
10143 -- Prepare two new parameters of Duration and Delay_Mode type
10144 -- which represent the value and the mode of the minimum delay.
10147 Insert_After (Parm, New_Reference_To (M, Loc));
10148 Insert_After (Parm, New_Reference_To (D, Loc));
10150 -- Create a call to RTS
10152 Rewrite (Select_Call,
10153 Make_Procedure_Call_Statement (Loc,
10154 Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc),
10155 Parameter_Associations => Parms));
10157 -- This new call should follow the calculation of the minimum
10160 Insert_List_Before (Select_Call, Delay_List);
10162 if Check_Guard then
10164 Make_Implicit_If_Statement (N,
10165 Condition => New_Reference_To (Guard_Open, Loc),
10167 New_List (New_Copy_Tree (Stmt),
10168 New_Copy_Tree (Select_Call)),
10169 Else_Statements => Accept_Or_Raise);
10170 Rewrite (Select_Call, Stmt);
10172 Insert_Before (Select_Call, Stmt);
10176 Make_Implicit_If_Statement (N,
10177 Condition => Make_Op_Eq (Loc,
10178 Left_Opnd => New_Reference_To (Xnam, Loc),
10180 New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
10182 Then_Statements => Delay_Case,
10183 Else_Statements => Accept_Case);
10185 Append (Cases, Stats);
10189 -- Replace accept statement with appropriate block
10192 Make_Block_Statement (Loc,
10193 Declarations => Decls,
10194 Handled_Statement_Sequence =>
10195 Make_Handled_Sequence_Of_Statements (Loc,
10196 Statements => Stats));
10198 Rewrite (N, Block);
10201 -- Note: have to worry more about abort deferral in above code ???
10203 -- Final step is to unstack the Accept_Address entries for all accept
10204 -- statements appearing in accept alternatives in the select statement
10206 Alt := First (Alts);
10207 while Present (Alt) loop
10208 if Nkind (Alt) = N_Accept_Alternative then
10209 Remove_Last_Elmt (Accept_Address
10210 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
10215 end Expand_N_Selective_Accept;
10217 --------------------------------------
10218 -- Expand_N_Single_Task_Declaration --
10219 --------------------------------------
10221 -- Single task declarations should never be present after semantic
10222 -- analysis, since we expect them to be replaced by a declaration of an
10223 -- anonymous task type, followed by a declaration of the task object. We
10224 -- include this routine to make sure that is happening!
10226 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
10228 raise Program_Error;
10229 end Expand_N_Single_Task_Declaration;
10231 ------------------------
10232 -- Expand_N_Task_Body --
10233 ------------------------
10235 -- Given a task body
10237 -- task body tname is
10243 -- This expansion routine converts it into a procedure and sets the
10244 -- elaboration flag for the procedure to true, to represent the fact
10245 -- that the task body is now elaborated:
10247 -- procedure tnameB (_Task : access tnameV) is
10248 -- discriminal : dtype renames _Task.discriminant;
10250 -- procedure _clean is
10252 -- Abort_Defer.all;
10254 -- Abort_Undefer.all;
10259 -- Abort_Undefer.all;
10261 -- System.Task_Stages.Complete_Activation;
10269 -- In addition, if the task body is an activator, then a call to activate
10270 -- tasks is added at the start of the statements, before the call to
10271 -- Complete_Activation, and if in addition the task is a master then it
10272 -- must be established as a master. These calls are inserted and analyzed
10273 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
10276 -- There is one discriminal declaration line generated for each
10277 -- discriminant that is present to provide an easy reference point for
10278 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
10280 -- Note on relationship to GNARLI definition. In the GNARLI definition,
10281 -- task body procedures have a profile (Arg : System.Address). That is
10282 -- needed because GNARLI has to use the same access-to-subprogram type
10283 -- for all task types. We depend here on knowing that in GNAT, passing
10284 -- an address argument by value is identical to passing a record value
10285 -- by access (in either case a single pointer is passed), so even though
10286 -- this procedure has the wrong profile. In fact it's all OK, since the
10287 -- callings sequence is identical.
10289 procedure Expand_N_Task_Body (N : Node_Id) is
10290 Loc : constant Source_Ptr := Sloc (N);
10291 Ttyp : constant Entity_Id := Corresponding_Spec (N);
10295 Insert_Nod : Node_Id;
10296 -- Used to determine the proper location of wrapper body insertions
10299 -- Add renaming declarations for discriminals and a declaration for the
10300 -- entry family index (if applicable).
10302 Install_Private_Data_Declarations
10303 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N));
10305 -- Add a call to Abort_Undefer at the very beginning of the task
10306 -- body since this body is called with abort still deferred.
10308 if Abort_Allowed then
10309 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
10311 (First (Statements (Handled_Statement_Sequence (N))), Call);
10315 -- The statement part has already been protected with an at_end and
10316 -- cleanup actions. The call to Complete_Activation must be placed
10317 -- at the head of the sequence of statements of that block. The
10318 -- declarations have been merged in this sequence of statements but
10319 -- the first real statement is accessible from the First_Real_Statement
10320 -- field (which was set for exactly this purpose).
10322 if Restricted_Profile then
10323 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
10325 Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
10329 (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
10333 Make_Subprogram_Body (Loc,
10334 Specification => Build_Task_Proc_Specification (Ttyp),
10335 Declarations => Declarations (N),
10336 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
10338 -- If the task contains generic instantiations, cleanup actions are
10339 -- delayed until after instantiation. Transfer the activation chain to
10340 -- the subprogram, to insure that the activation call is properly
10341 -- generated. It the task body contains inner tasks, indicate that the
10342 -- subprogram is a task master.
10344 if Delay_Cleanups (Ttyp) then
10345 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
10346 Set_Is_Task_Master (New_N, Is_Task_Master (N));
10349 Rewrite (N, New_N);
10352 -- Set elaboration flag immediately after task body. If the body is a
10353 -- subunit, the flag is set in the declarative part containing the stub.
10355 if Nkind (Parent (N)) /= N_Subunit then
10357 Make_Assignment_Statement (Loc,
10359 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
10360 Expression => New_Reference_To (Standard_True, Loc)));
10363 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
10364 -- the task body. At this point all wrapper specs have been created,
10365 -- frozen and included in the dispatch table for the task type.
10367 if Ada_Version >= Ada_2005 then
10368 if Nkind (Parent (N)) = N_Subunit then
10369 Insert_Nod := Corresponding_Stub (Parent (N));
10374 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
10376 end Expand_N_Task_Body;
10378 ------------------------------------
10379 -- Expand_N_Task_Type_Declaration --
10380 ------------------------------------
10382 -- We have several things to do. First we must create a Boolean flag used
10383 -- to mark if the body is elaborated yet. This variable gets set to True
10384 -- when the body of the task is elaborated (we can't rely on the normal
10385 -- ABE mechanism for the task body, since we need to pass an access to
10386 -- this elaboration boolean to the runtime routines).
10388 -- taskE : aliased Boolean := False;
10390 -- Next a variable is declared to hold the task stack size (either the
10391 -- default : Unspecified_Size, or a value that is set by a pragma
10392 -- Storage_Size). If the value of the pragma Storage_Size is static, then
10393 -- the variable is initialized with this value:
10395 -- taskZ : Size_Type := Unspecified_Size;
10397 -- taskZ : Size_Type := Size_Type (size_expression);
10399 -- Note: No variable is needed to hold the task relative deadline since
10400 -- its value would never be static because the parameter is of a private
10401 -- type (Ada.Real_Time.Time_Span).
10403 -- Next we create a corresponding record type declaration used to represent
10404 -- values of this task. The general form of this type declaration is
10406 -- type taskV (discriminants) is record
10407 -- _Task_Id : Task_Id;
10408 -- entry_family : array (bounds) of Void;
10409 -- _Priority : Integer := priority_expression;
10410 -- _Size : Size_Type := Size_Type (size_expression);
10411 -- _Task_Info : Task_Info_Type := task_info_expression;
10412 -- _CPU : Integer := cpu_range_expression;
10415 -- The discriminants are present only if the corresponding task type has
10416 -- discriminants, and they exactly mirror the task type discriminants.
10418 -- The Id field is always present. It contains the Task_Id value, as set by
10419 -- the call to Create_Task. Note that although the task is limited, the
10420 -- task value record type is not limited, so there is no problem in passing
10421 -- this field as an out parameter to Create_Task.
10423 -- One entry_family component is present for each entry family in the task
10424 -- definition. The bounds correspond to the bounds of the entry family
10425 -- (which may depend on discriminants). The element type is void, since we
10426 -- only need the bounds information for determining the entry index. Note
10427 -- that the use of an anonymous array would normally be illegal in this
10428 -- context, but this is a parser check, and the semantics is quite prepared
10429 -- to handle such a case.
10431 -- The _Size field is present only if a Storage_Size pragma appears in the
10432 -- task definition. The expression captures the argument that was present
10433 -- in the pragma, and is used to override the task stack size otherwise
10434 -- associated with the task type.
10436 -- The _Priority field is present only if a Priority or Interrupt_Priority
10437 -- pragma appears in the task definition. The expression captures the
10438 -- argument that was present in the pragma, and is used to provide the Size
10439 -- parameter to the call to Create_Task.
10441 -- The _Task_Info field is present only if a Task_Info pragma appears in
10442 -- the task definition. The expression captures the argument that was
10443 -- present in the pragma, and is used to provide the Task_Image parameter
10444 -- to the call to Create_Task.
10446 -- The _CPU field is present only if a CPU pragma appears in the task
10447 -- definition. The expression captures the argument that was present in
10448 -- the pragma, and is used to provide the CPU parameter to the call to
10451 -- The _Relative_Deadline field is present only if a Relative_Deadline
10452 -- pragma appears in the task definition. The expression captures the
10453 -- argument that was present in the pragma, and is used to provide the
10454 -- Relative_Deadline parameter to the call to Create_Task.
10456 -- When a task is declared, an instance of the task value record is
10457 -- created. The elaboration of this declaration creates the correct bounds
10458 -- for the entry families, and also evaluates the size, priority, and
10459 -- task_Info expressions if needed. The initialization routine for the task
10460 -- type itself then calls Create_Task with appropriate parameters to
10461 -- initialize the value of the Task_Id field.
10463 -- Note: the address of this record is passed as the "Discriminants"
10464 -- parameter for Create_Task. Since Create_Task merely passes this onto the
10465 -- body procedure, it does not matter that it does not quite match the
10466 -- GNARLI model of what is being passed (the record contains more than just
10467 -- the discriminants, but the discriminants can be found from the record
10470 -- The Entity_Id for this created record type is placed in the
10471 -- Corresponding_Record_Type field of the associated task type entity.
10473 -- Next we create a procedure specification for the task body procedure:
10475 -- procedure taskB (_Task : access taskV);
10477 -- Note that this must come after the record type declaration, since
10478 -- the spec refers to this type. It turns out that the initialization
10479 -- procedure for the value type references the task body spec, but that's
10480 -- fine, since it won't be generated till the freeze point for the type,
10481 -- which is certainly after the task body spec declaration.
10483 -- Finally, we set the task index value field of the entry attribute in
10484 -- the case of a simple entry.
10486 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
10487 Loc : constant Source_Ptr := Sloc (N);
10488 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
10489 Tasknm : constant Name_Id := Chars (Tasktyp);
10490 Taskdef : constant Node_Id := Task_Definition (N);
10492 Proc_Spec : Node_Id;
10493 Rec_Decl : Node_Id;
10494 Rec_Ent : Entity_Id;
10496 Elab_Decl : Node_Id;
10497 Size_Decl : Node_Id;
10498 Body_Decl : Node_Id;
10499 Task_Size : Node_Id;
10500 Ent_Stack : Entity_Id;
10501 Decl_Stack : Node_Id;
10504 -- If already expanded, nothing to do
10506 if Present (Corresponding_Record_Type (Tasktyp)) then
10510 -- Here we will do the expansion
10512 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
10514 Rec_Ent := Defining_Identifier (Rec_Decl);
10515 Cdecls := Component_Items (Component_List
10516 (Type_Definition (Rec_Decl)));
10518 Qualify_Entity_Names (N);
10520 -- First create the elaboration variable
10523 Make_Object_Declaration (Loc,
10524 Defining_Identifier =>
10525 Make_Defining_Identifier (Sloc (Tasktyp),
10526 Chars => New_External_Name (Tasknm, 'E')),
10527 Aliased_Present => True,
10528 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
10529 Expression => New_Reference_To (Standard_False, Loc));
10530 Insert_After (N, Elab_Decl);
10532 -- Next create the declaration of the size variable (tasknmZ)
10534 Set_Storage_Size_Variable (Tasktyp,
10535 Make_Defining_Identifier (Sloc (Tasktyp),
10536 Chars => New_External_Name (Tasknm, 'Z')));
10538 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then
10539 Is_Static_Expression (Expression (First (
10540 Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma (
10541 Taskdef, Name_Storage_Size)))))
10544 Make_Object_Declaration (Loc,
10545 Defining_Identifier => Storage_Size_Variable (Tasktyp),
10546 Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
10548 Convert_To (RTE (RE_Size_Type),
10550 Expression (First (
10551 Pragma_Argument_Associations (
10552 Find_Task_Or_Protected_Pragma
10553 (Taskdef, Name_Storage_Size)))))));
10557 Make_Object_Declaration (Loc,
10558 Defining_Identifier => Storage_Size_Variable (Tasktyp),
10559 Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
10560 Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc));
10563 Insert_After (Elab_Decl, Size_Decl);
10565 -- Next build the rest of the corresponding record declaration. This is
10566 -- done last, since the corresponding record initialization procedure
10567 -- will reference the previously created entities.
10569 -- Fill in the component declarations -- first the _Task_Id field
10572 Make_Component_Declaration (Loc,
10573 Defining_Identifier =>
10574 Make_Defining_Identifier (Loc, Name_uTask_Id),
10575 Component_Definition =>
10576 Make_Component_Definition (Loc,
10577 Aliased_Present => False,
10578 Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id),
10581 -- Declare static ATCB (that is, created by the expander) if we are
10582 -- using the Restricted run time.
10584 if Restricted_Profile then
10586 Make_Component_Declaration (Loc,
10587 Defining_Identifier =>
10588 Make_Defining_Identifier (Loc, Name_uATCB),
10590 Component_Definition =>
10591 Make_Component_Definition (Loc,
10592 Aliased_Present => True,
10593 Subtype_Indication => Make_Subtype_Indication (Loc,
10594 Subtype_Mark => New_Occurrence_Of
10595 (RTE (RE_Ada_Task_Control_Block), Loc),
10598 Make_Index_Or_Discriminant_Constraint (Loc,
10600 New_List (Make_Integer_Literal (Loc, 0)))))));
10604 -- Declare static stack (that is, created by the expander) if we are
10605 -- using the Restricted run time on a bare board configuration.
10607 if Restricted_Profile
10608 and then Preallocated_Stacks_On_Target
10610 -- First we need to extract the appropriate stack size
10612 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
10614 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
10616 Expr_N : constant Node_Id :=
10617 Expression (First (
10618 Pragma_Argument_Associations (
10619 Find_Task_Or_Protected_Pragma
10620 (Taskdef, Name_Storage_Size))));
10621 Etyp : constant Entity_Id := Etype (Expr_N);
10622 P : constant Node_Id := Parent (Expr_N);
10625 -- The stack is defined inside the corresponding record.
10626 -- Therefore if the size of the stack is set by means of
10627 -- a discriminant, we must reference the discriminant of the
10628 -- corresponding record type.
10630 if Nkind (Expr_N) in N_Has_Entity
10631 and then Present (Discriminal_Link (Entity (Expr_N)))
10635 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
10637 Set_Parent (Task_Size, P);
10638 Set_Etype (Task_Size, Etyp);
10639 Set_Analyzed (Task_Size);
10642 Task_Size := Relocate_Node (Expr_N);
10648 New_Reference_To (RTE (RE_Default_Stack_Size), Loc);
10651 Decl_Stack := Make_Component_Declaration (Loc,
10652 Defining_Identifier => Ent_Stack,
10654 Component_Definition =>
10655 Make_Component_Definition (Loc,
10656 Aliased_Present => True,
10657 Subtype_Indication => Make_Subtype_Indication (Loc,
10659 New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
10662 Make_Index_Or_Discriminant_Constraint (Loc,
10663 Constraints => New_List (Make_Range (Loc,
10664 Low_Bound => Make_Integer_Literal (Loc, 1),
10665 High_Bound => Convert_To (RTE (RE_Storage_Offset),
10668 Append_To (Cdecls, Decl_Stack);
10670 -- The appropriate alignment for the stack is ensured by the run-time
10671 -- code in charge of task creation.
10675 -- Add components for entry families
10677 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
10679 -- Add the _Priority component if a Priority pragma is present
10681 if Present (Taskdef) and then Has_Pragma_Priority (Taskdef) then
10683 Prag : constant Node_Id :=
10684 Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
10688 Expr := First (Pragma_Argument_Associations (Prag));
10690 if Nkind (Expr) = N_Pragma_Argument_Association then
10691 Expr := Expression (Expr);
10694 Expr := New_Copy_Tree (Expr);
10696 -- Add conversion to proper type to do range check if required
10697 -- Note that for runtime units, we allow out of range interrupt
10698 -- priority values to be used in a priority pragma. This is for
10699 -- the benefit of some versions of System.Interrupts which use
10700 -- a special server task with maximum interrupt priority.
10702 if Pragma_Name (Prag) = Name_Priority
10703 and then not GNAT_Mode
10705 Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
10707 Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
10711 Make_Component_Declaration (Loc,
10712 Defining_Identifier =>
10713 Make_Defining_Identifier (Loc, Name_uPriority),
10714 Component_Definition =>
10715 Make_Component_Definition (Loc,
10716 Aliased_Present => False,
10717 Subtype_Indication => New_Reference_To (Standard_Integer,
10719 Expression => Expr));
10723 -- Add the _Task_Size component if a Storage_Size pragma is present
10725 if Present (Taskdef)
10726 and then Has_Storage_Size_Pragma (Taskdef)
10729 Make_Component_Declaration (Loc,
10730 Defining_Identifier =>
10731 Make_Defining_Identifier (Loc, Name_uSize),
10733 Component_Definition =>
10734 Make_Component_Definition (Loc,
10735 Aliased_Present => False,
10736 Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
10740 Convert_To (RTE (RE_Size_Type),
10742 Expression (First (
10743 Pragma_Argument_Associations (
10744 Find_Task_Or_Protected_Pragma
10745 (Taskdef, Name_Storage_Size))))))));
10748 -- Add the _Task_Info component if a Task_Info pragma is present
10750 if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then
10752 Make_Component_Declaration (Loc,
10753 Defining_Identifier =>
10754 Make_Defining_Identifier (Loc, Name_uTask_Info),
10756 Component_Definition =>
10757 Make_Component_Definition (Loc,
10758 Aliased_Present => False,
10759 Subtype_Indication =>
10760 New_Reference_To (RTE (RE_Task_Info_Type), Loc)),
10762 Expression => New_Copy (
10763 Expression (First (
10764 Pragma_Argument_Associations (
10765 Find_Task_Or_Protected_Pragma
10766 (Taskdef, Name_Task_Info)))))));
10769 -- Add the _CPU component if a CPU pragma is present
10771 if Present (Taskdef) and then Has_Pragma_CPU (Taskdef) then
10773 Make_Component_Declaration (Loc,
10774 Defining_Identifier =>
10775 Make_Defining_Identifier (Loc, Name_uCPU),
10777 Component_Definition =>
10778 Make_Component_Definition (Loc,
10779 Aliased_Present => False,
10780 Subtype_Indication =>
10781 New_Reference_To (RTE (RE_CPU_Range), Loc)),
10783 Expression => New_Copy (
10784 Expression (First (
10785 Pragma_Argument_Associations (
10786 Find_Task_Or_Protected_Pragma
10787 (Taskdef, Name_CPU)))))));
10790 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
10791 -- present. If we are using a restricted run time this component will
10792 -- not be added (deadlines are not allowed by the Ravenscar profile).
10794 if not Restricted_Profile
10795 and then Present (Taskdef)
10796 and then Has_Relative_Deadline_Pragma (Taskdef)
10799 Make_Component_Declaration (Loc,
10800 Defining_Identifier =>
10801 Make_Defining_Identifier (Loc, Name_uRelative_Deadline),
10803 Component_Definition =>
10804 Make_Component_Definition (Loc,
10805 Aliased_Present => False,
10806 Subtype_Indication =>
10807 New_Reference_To (RTE (RE_Time_Span), Loc)),
10810 Convert_To (RTE (RE_Time_Span),
10812 Expression (First (
10813 Pragma_Argument_Associations (
10814 Find_Task_Or_Protected_Pragma
10815 (Taskdef, Name_Relative_Deadline))))))));
10818 Insert_After (Size_Decl, Rec_Decl);
10820 -- Analyze the record declaration immediately after construction,
10821 -- because the initialization procedure is needed for single task
10822 -- declarations before the next entity is analyzed.
10824 Analyze (Rec_Decl);
10826 -- Create the declaration of the task body procedure
10828 Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
10830 Make_Subprogram_Declaration (Loc,
10831 Specification => Proc_Spec);
10833 Insert_After (Rec_Decl, Body_Decl);
10835 -- The subprogram does not comes from source, so we have to indicate the
10836 -- need for debugging information explicitly.
10838 if Comes_From_Source (Original_Node (N)) then
10839 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec));
10842 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
10843 -- the corresponding record has been frozen.
10845 if Ada_Version >= Ada_2005 then
10846 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
10849 -- Ada 2005 (AI-345): We must defer freezing to allow further
10850 -- declaration of primitive subprograms covering task interfaces
10852 if Ada_Version <= Ada_95 then
10854 -- Now we can freeze the corresponding record. This needs manually
10855 -- freezing, since it is really part of the task type, and the task
10856 -- type is frozen at this stage. We of course need the initialization
10857 -- procedure for this corresponding record type and we won't get it
10858 -- in time if we don't freeze now.
10861 L : constant List_Id := Freeze_Entity (Rec_Ent, N);
10863 if Is_Non_Empty_List (L) then
10864 Insert_List_After (Body_Decl, L);
10869 -- Complete the expansion of access types to the current task type, if
10870 -- any were declared.
10872 Expand_Previous_Access_Type (Tasktyp);
10874 -- Create wrappers for entries that have pre/postconditions
10880 Ent := First_Entity (Tasktyp);
10881 while Present (Ent) loop
10882 if Ekind_In (Ent, E_Entry, E_Entry_Family)
10883 and then Present (Spec_PPC_List (Ent))
10885 Build_PPC_Wrapper (Ent, N);
10891 end Expand_N_Task_Type_Declaration;
10893 -------------------------------
10894 -- Expand_N_Timed_Entry_Call --
10895 -------------------------------
10897 -- A timed entry call in normal case is not implemented using ATC mechanism
10898 -- anymore for efficiency reason.
10908 -- is expanded as follow:
10910 -- 1) When T.E is a task entry_call;
10914 -- X : Task_Entry_Index := <entry index>;
10915 -- DX : Duration := To_Duration (D);
10916 -- M : Delay_Mode := <discriminant>;
10917 -- P : parms := (parm, parm, parm);
10920 -- Timed_Protected_Entry_Call
10921 -- (<acceptor-task>, X, P'Address, DX, M, B);
10929 -- 2) When T.E is a protected entry_call;
10933 -- X : Protected_Entry_Index := <entry index>;
10934 -- DX : Duration := To_Duration (D);
10935 -- M : Delay_Mode := <discriminant>;
10936 -- P : parms := (parm, parm, parm);
10939 -- Timed_Protected_Entry_Call
10940 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
10948 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
10951 -- B : Boolean := False;
10952 -- C : Ada.Tags.Prim_Op_Kind;
10953 -- DX : Duration := To_Duration (D)
10954 -- K : Ada.Tags.Tagged_Kind :=
10955 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
10956 -- M : Integer :=...;
10957 -- P : Parameters := (Param1 .. ParamN);
10961 -- if K = Ada.Tags.TK_Limited_Tagged then
10962 -- <dispatching-call>;
10963 -- <triggering-statements>
10967 -- Ada.Tags.Get_Offset_Index
10968 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
10970 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
10972 -- if C = POK_Protected_Entry
10973 -- or else C = POK_Task_Entry
10975 -- Param1 := P.Param1;
10977 -- ParamN := P.ParamN;
10981 -- if C = POK_Procedure
10982 -- or else C = POK_Protected_Procedure
10983 -- or else C = POK_Task_Procedure
10985 -- <dispatching-call>;
10988 -- <triggering-statements>
10990 -- <timed-statements>
10995 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
10996 Loc : constant Source_Ptr := Sloc (N);
10998 E_Call : Node_Id :=
10999 Entry_Call_Statement (Entry_Call_Alternative (N));
11000 E_Stats : constant List_Id :=
11001 Statements (Entry_Call_Alternative (N));
11002 D_Stat : Node_Id :=
11003 Delay_Statement (Delay_Alternative (N));
11004 D_Stats : constant List_Id :=
11005 Statements (Delay_Alternative (N));
11008 Blk_Typ : Entity_Id;
11010 Call_Ent : Entity_Id;
11011 Conc_Typ_Stmts : List_Id;
11015 D_Type : Entity_Id;
11021 Is_Disp_Select : Boolean;
11022 Lim_Typ_Stmts : List_Id;
11031 B : Entity_Id; -- Call status flag
11032 C : Entity_Id; -- Call kind
11033 D : Entity_Id; -- Delay
11034 K : Entity_Id; -- Tagged kind
11035 M : Entity_Id; -- Delay mode
11036 P : Entity_Id; -- Parameter block
11037 S : Entity_Id; -- Primitive operation slot
11040 -- Under the Ravenscar profile, timed entry calls are excluded. An error
11041 -- was already reported on spec, so do not attempt to expand the call.
11043 if Restriction_Active (No_Select_Statements) then
11047 -- The arguments in the call may require dynamic allocation, and the
11048 -- call statement may have been transformed into a block. The block
11049 -- may contain additional declarations for internal entities, and the
11050 -- original call is found by sequential search.
11052 if Nkind (E_Call) = N_Block_Statement then
11053 E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
11054 while not Nkind_In (E_Call, N_Procedure_Call_Statement,
11055 N_Entry_Call_Statement)
11062 Ada_Version >= Ada_2005
11063 and then Nkind (E_Call) = N_Procedure_Call_Statement;
11065 if Is_Disp_Select then
11066 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
11072 -- B : Boolean := False;
11074 B := Build_B (Loc, Decls);
11077 -- C : Ada.Tags.Prim_Op_Kind;
11079 C := Build_C (Loc, Decls);
11081 -- Because the analysis of all statements was disabled, manually
11082 -- analyze the delay statement.
11085 D_Stat := Original_Node (D_Stat);
11088 -- Build an entry call using Simple_Entry_Call
11090 Extract_Entry (E_Call, Concval, Ename, Index);
11091 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
11093 Decls := Declarations (E_Call);
11094 Stmts := Statements (Handled_Statement_Sequence (E_Call));
11103 B := Make_Defining_Identifier (Loc, Name_uB);
11106 Make_Object_Declaration (Loc,
11107 Defining_Identifier =>
11109 Object_Definition =>
11110 New_Reference_To (Standard_Boolean, Loc)));
11113 -- Duration and mode processing
11115 D_Type := Base_Type (Etype (Expression (D_Stat)));
11117 -- Use the type of the delay expression (Calendar or Real_Time) to
11118 -- generate the appropriate conversion.
11120 if Nkind (D_Stat) = N_Delay_Relative_Statement then
11121 D_Disc := Make_Integer_Literal (Loc, 0);
11122 D_Conv := Relocate_Node (Expression (D_Stat));
11124 elsif Is_RTE (D_Type, RO_CA_Time) then
11125 D_Disc := Make_Integer_Literal (Loc, 1);
11126 D_Conv := Make_Function_Call (Loc,
11127 New_Reference_To (RTE (RO_CA_To_Duration), Loc),
11128 New_List (New_Copy (Expression (D_Stat))));
11130 else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
11131 D_Disc := Make_Integer_Literal (Loc, 2);
11132 D_Conv := Make_Function_Call (Loc,
11133 New_Reference_To (RTE (RO_RT_To_Duration), Loc),
11134 New_List (New_Copy (Expression (D_Stat))));
11137 D := Make_Temporary (Loc, 'D');
11143 Make_Object_Declaration (Loc,
11144 Defining_Identifier =>
11146 Object_Definition =>
11147 New_Reference_To (Standard_Duration, Loc)));
11149 M := Make_Temporary (Loc, 'M');
11152 -- M : Integer := (0 | 1 | 2);
11155 Make_Object_Declaration (Loc,
11156 Defining_Identifier =>
11158 Object_Definition =>
11159 New_Reference_To (Standard_Integer, Loc),
11163 -- Do the assignment at this stage only because the evaluation of the
11164 -- expression must not occur before (see ACVC C97302A).
11167 Make_Assignment_Statement (Loc,
11169 New_Reference_To (D, Loc),
11173 -- Parameter block processing
11175 -- Manually create the parameter block for dispatching calls. In the
11176 -- case of entries, the block has already been created during the call
11177 -- to Build_Simple_Entry_Call.
11179 if Is_Disp_Select then
11181 -- Tagged kind processing, generate:
11182 -- K : Ada.Tags.Tagged_Kind :=
11183 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
11185 K := Build_K (Loc, Decls, Obj);
11187 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
11188 P := Parameter_Block_Pack
11189 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
11191 -- Dispatch table slot processing, generate:
11194 S := Build_S (Loc, Decls);
11197 -- S := Ada.Tags.Get_Offset_Index
11198 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
11201 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
11204 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
11206 -- where Obj is the controlling formal parameter, S is the dispatch
11207 -- table slot number of the dispatching operation, P is the wrapped
11208 -- parameter block, D is the duration, M is the duration mode, C is
11209 -- the call kind and B is the call status.
11211 Params := New_List;
11213 Append_To (Params, New_Copy_Tree (Obj));
11214 Append_To (Params, New_Reference_To (S, Loc));
11215 Append_To (Params, Make_Attribute_Reference (Loc,
11216 Prefix => New_Reference_To (P, Loc),
11217 Attribute_Name => Name_Address));
11218 Append_To (Params, New_Reference_To (D, Loc));
11219 Append_To (Params, New_Reference_To (M, Loc));
11220 Append_To (Params, New_Reference_To (C, Loc));
11221 Append_To (Params, New_Reference_To (B, Loc));
11223 Append_To (Conc_Typ_Stmts,
11224 Make_Procedure_Call_Statement (Loc,
11227 Find_Prim_Op (Etype (Etype (Obj)),
11228 Name_uDisp_Timed_Select),
11230 Parameter_Associations =>
11234 -- if C = POK_Protected_Entry
11235 -- or else C = POK_Task_Entry
11237 -- Param1 := P.Param1;
11239 -- ParamN := P.ParamN;
11242 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
11244 -- Generate the if statement only when the packed parameters need
11245 -- explicit assignments to their corresponding actuals.
11247 if Present (Unpack) then
11248 Append_To (Conc_Typ_Stmts,
11249 Make_If_Statement (Loc,
11256 New_Reference_To (C, Loc),
11258 New_Reference_To (RTE (
11259 RE_POK_Protected_Entry), Loc)),
11263 New_Reference_To (C, Loc),
11265 New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
11274 -- if C = POK_Procedure
11275 -- or else C = POK_Protected_Procedure
11276 -- or else C = POK_Task_Procedure
11278 -- <dispatching-call>
11280 -- <triggering-statements>
11282 -- <timed-statements>
11285 N_Stats := New_Copy_List_Tree (E_Stats);
11287 Prepend_To (N_Stats,
11288 Make_If_Statement (Loc,
11295 New_Reference_To (C, Loc),
11297 New_Reference_To (RTE (RE_POK_Procedure), Loc)),
11303 New_Reference_To (C, Loc),
11305 New_Reference_To (RTE (
11306 RE_POK_Protected_Procedure), Loc)),
11310 New_Reference_To (C, Loc),
11312 New_Reference_To (RTE (
11313 RE_POK_Task_Procedure), Loc)))),
11316 New_List (E_Call)));
11318 Append_To (Conc_Typ_Stmts,
11319 Make_If_Statement (Loc,
11320 Condition => New_Reference_To (B, Loc),
11321 Then_Statements => N_Stats,
11322 Else_Statements => D_Stats));
11325 -- <dispatching-call>;
11326 -- <triggering-statements>
11328 Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
11329 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
11332 -- if K = Ada.Tags.TK_Limited_Tagged then
11339 Make_If_Statement (Loc,
11343 New_Reference_To (K, Loc),
11345 New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
11354 -- Skip assignments to temporaries created for in-out parameters.
11355 -- This makes unwarranted assumptions about the shape of the expanded
11356 -- tree for the call, and should be cleaned up ???
11358 Stmt := First (Stmts);
11359 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
11363 -- Do the assignment at this stage only because the evaluation
11364 -- of the expression must not occur before (see ACVC C97302A).
11366 Insert_Before (Stmt,
11367 Make_Assignment_Statement (Loc,
11368 Name => New_Reference_To (D, Loc),
11369 Expression => D_Conv));
11372 Params := Parameter_Associations (Call);
11374 -- For a protected type, we build a Timed_Protected_Entry_Call
11376 if Is_Protected_Type (Etype (Concval)) then
11378 -- Create a new call statement
11380 Param := First (Params);
11381 while Present (Param)
11382 and then not Is_RTE (Etype (Param), RE_Call_Modes)
11387 Dummy := Remove_Next (Next (Param));
11389 -- Remove garbage is following the Cancel_Param if present
11391 Dummy := Next (Param);
11393 -- Remove the mode of the Protected_Entry_Call call, then remove
11394 -- the Communication_Block of the Protected_Entry_Call call, and
11395 -- finally add Duration and a Delay_Mode parameter
11397 pragma Assert (Present (Param));
11398 Rewrite (Param, New_Reference_To (D, Loc));
11400 Rewrite (Dummy, New_Reference_To (M, Loc));
11402 -- Add a Boolean flag for successful entry call
11404 Append_To (Params, New_Reference_To (B, Loc));
11406 case Corresponding_Runtime_Package (Etype (Concval)) is
11407 when System_Tasking_Protected_Objects_Entries =>
11409 Make_Procedure_Call_Statement (Loc,
11412 (RTE (RE_Timed_Protected_Entry_Call), Loc),
11413 Parameter_Associations => Params));
11415 when System_Tasking_Protected_Objects_Single_Entry =>
11416 Param := First (Params);
11417 while Present (Param)
11419 Is_RTE (Etype (Param), RE_Protected_Entry_Index)
11427 Make_Procedure_Call_Statement (Loc,
11428 Name => New_Reference_To (
11429 RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
11430 Parameter_Associations => Params));
11433 raise Program_Error;
11436 -- For the task case, build a Timed_Task_Entry_Call
11439 -- Create a new call statement
11441 Append_To (Params, New_Reference_To (D, Loc));
11442 Append_To (Params, New_Reference_To (M, Loc));
11443 Append_To (Params, New_Reference_To (B, Loc));
11446 Make_Procedure_Call_Statement (Loc,
11448 New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
11449 Parameter_Associations => Params));
11453 Make_Implicit_If_Statement (N,
11454 Condition => New_Reference_To (B, Loc),
11455 Then_Statements => E_Stats,
11456 Else_Statements => D_Stats));
11460 Make_Block_Statement (Loc,
11461 Declarations => Decls,
11462 Handled_Statement_Sequence =>
11463 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
11466 end Expand_N_Timed_Entry_Call;
11468 ----------------------------------------
11469 -- Expand_Protected_Body_Declarations --
11470 ----------------------------------------
11472 procedure Expand_Protected_Body_Declarations
11474 Spec_Id : Entity_Id)
11477 if No_Run_Time_Mode then
11478 Error_Msg_CRT ("protected body", N);
11481 elsif Expander_Active then
11483 -- Associate discriminals with the first subprogram or entry body to
11486 if Present (First_Protected_Operation (Declarations (N))) then
11487 Set_Discriminals (Parent (Spec_Id));
11490 end Expand_Protected_Body_Declarations;
11492 -------------------------
11493 -- External_Subprogram --
11494 -------------------------
11496 function External_Subprogram (E : Entity_Id) return Entity_Id is
11497 Subp : constant Entity_Id := Protected_Body_Subprogram (E);
11500 -- The internal and external subprograms follow each other on the entity
11501 -- chain. Note that previously private operations had no separate
11502 -- external subprogram. We now create one in all cases, because a
11503 -- private operation may actually appear in an external call, through
11504 -- a 'Access reference used for a callback.
11506 -- If the operation is a function that returns an anonymous access type,
11507 -- the corresponding itype appears before the operation, and must be
11510 -- This mechanism is fragile, there should be a real link between the
11511 -- two versions of the operation, but there is no place to put it ???
11513 if Is_Access_Type (Next_Entity (Subp)) then
11514 return Next_Entity (Next_Entity (Subp));
11516 return Next_Entity (Subp);
11518 end External_Subprogram;
11520 ------------------------------
11521 -- Extract_Dispatching_Call --
11522 ------------------------------
11524 procedure Extract_Dispatching_Call
11526 Call_Ent : out Entity_Id;
11527 Object : out Entity_Id;
11528 Actuals : out List_Id;
11529 Formals : out List_Id)
11531 Call_Nam : Node_Id;
11534 pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
11536 if Present (Original_Node (N)) then
11537 Call_Nam := Name (Original_Node (N));
11539 Call_Nam := Name (N);
11542 -- Retrieve the name of the dispatching procedure. It contains the
11543 -- dispatch table slot number.
11546 case Nkind (Call_Nam) is
11547 when N_Identifier =>
11550 when N_Selected_Component =>
11551 Call_Nam := Selector_Name (Call_Nam);
11554 raise Program_Error;
11559 Actuals := Parameter_Associations (N);
11560 Call_Ent := Entity (Call_Nam);
11561 Formals := Parameter_Specifications (Parent (Call_Ent));
11562 Object := First (Actuals);
11564 if Present (Original_Node (Object)) then
11565 Object := Original_Node (Object);
11568 -- If the type of the dispatching object is an access type then return
11569 -- an explicit dereference.
11571 if Is_Access_Type (Etype (Object)) then
11572 Object := Make_Explicit_Dereference (Sloc (N), Object);
11575 end Extract_Dispatching_Call;
11577 -------------------
11578 -- Extract_Entry --
11579 -------------------
11581 procedure Extract_Entry
11583 Concval : out Node_Id;
11584 Ename : out Node_Id;
11585 Index : out Node_Id)
11587 Nam : constant Node_Id := Name (N);
11590 -- For a simple entry, the name is a selected component, with the
11591 -- prefix being the task value, and the selector being the entry.
11593 if Nkind (Nam) = N_Selected_Component then
11594 Concval := Prefix (Nam);
11595 Ename := Selector_Name (Nam);
11598 -- For a member of an entry family, the name is an indexed component
11599 -- where the prefix is a selected component, whose prefix in turn is
11600 -- the task value, and whose selector is the entry family. The single
11601 -- expression in the expressions list of the indexed component is the
11602 -- subscript for the family.
11604 else pragma Assert (Nkind (Nam) = N_Indexed_Component);
11605 Concval := Prefix (Prefix (Nam));
11606 Ename := Selector_Name (Prefix (Nam));
11607 Index := First (Expressions (Nam));
11611 -------------------
11612 -- Family_Offset --
11613 -------------------
11615 function Family_Offset
11620 Cap : Boolean) return Node_Id
11626 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
11627 -- If one of the bounds is a reference to a discriminant, replace with
11628 -- corresponding discriminal of type. Within the body of a task retrieve
11629 -- the renamed discriminant by simple visibility, using its generated
11630 -- name. Within a protected object, find the original discriminant and
11631 -- replace it with the discriminal of the current protected operation.
11633 ------------------------------
11634 -- Convert_Discriminant_Ref --
11635 ------------------------------
11637 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
11638 Loc : constant Source_Ptr := Sloc (Bound);
11643 if Is_Entity_Name (Bound)
11644 and then Ekind (Entity (Bound)) = E_Discriminant
11646 if Is_Task_Type (Ttyp)
11647 and then Has_Completion (Ttyp)
11649 B := Make_Identifier (Loc, Chars (Entity (Bound)));
11650 Find_Direct_Name (B);
11652 elsif Is_Protected_Type (Ttyp) then
11653 D := First_Discriminant (Ttyp);
11654 while Chars (D) /= Chars (Entity (Bound)) loop
11655 Next_Discriminant (D);
11658 B := New_Reference_To (Discriminal (D), Loc);
11661 B := New_Reference_To (Discriminal (Entity (Bound)), Loc);
11664 elsif Nkind (Bound) = N_Attribute_Reference then
11668 B := New_Copy_Tree (Bound);
11672 Make_Attribute_Reference (Loc,
11673 Attribute_Name => Name_Pos,
11674 Prefix => New_Occurrence_Of (Etype (Bound), Loc),
11675 Expressions => New_List (B));
11676 end Convert_Discriminant_Ref;
11678 -- Start of processing for Family_Offset
11681 Real_Hi := Convert_Discriminant_Ref (Hi);
11682 Real_Lo := Convert_Discriminant_Ref (Lo);
11685 if Is_Task_Type (Ttyp) then
11686 Ityp := RTE (RE_Task_Entry_Index);
11688 Ityp := RTE (RE_Protected_Entry_Index);
11692 Make_Attribute_Reference (Loc,
11693 Prefix => New_Reference_To (Ityp, Loc),
11694 Attribute_Name => Name_Min,
11695 Expressions => New_List (
11697 Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
11700 Make_Attribute_Reference (Loc,
11701 Prefix => New_Reference_To (Ityp, Loc),
11702 Attribute_Name => Name_Max,
11703 Expressions => New_List (
11705 Make_Integer_Literal (Loc, -Entry_Family_Bound)));
11708 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
11715 function Family_Size
11720 Cap : Boolean) return Node_Id
11725 if Is_Task_Type (Ttyp) then
11726 Ityp := RTE (RE_Task_Entry_Index);
11728 Ityp := RTE (RE_Protected_Entry_Index);
11732 Make_Attribute_Reference (Loc,
11733 Prefix => New_Reference_To (Ityp, Loc),
11734 Attribute_Name => Name_Max,
11735 Expressions => New_List (
11738 Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
11740 Make_Integer_Literal (Loc, 1)),
11741 Make_Integer_Literal (Loc, 0)));
11744 -----------------------
11745 -- Find_Master_Scope --
11746 -----------------------
11748 function Find_Master_Scope (E : Entity_Id) return Entity_Id is
11752 -- In Ada2005, the master is the innermost enclosing scope that is not
11753 -- transient. If the enclosing block is the rewriting of a call or the
11754 -- scope is an extended return statement this is valid master. The
11755 -- master in an extended return is only used within the return, and is
11756 -- subsequently overwritten in Move_Activation_Chain, but it must exist
11757 -- now before that overwriting occurs.
11761 if Ada_Version >= Ada_2005 then
11762 while Is_Internal (S) loop
11763 if Nkind (Parent (S)) = N_Block_Statement
11765 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
11769 elsif Ekind (S) = E_Return_Statement then
11779 end Find_Master_Scope;
11781 -----------------------------------
11782 -- Find_Task_Or_Protected_Pragma --
11783 -----------------------------------
11785 function Find_Task_Or_Protected_Pragma
11787 P : Name_Id) return Node_Id
11792 N := First (Visible_Declarations (T));
11793 while Present (N) loop
11794 if Nkind (N) = N_Pragma then
11795 if Pragma_Name (N) = P then
11798 elsif P = Name_Priority
11799 and then Pragma_Name (N) = Name_Interrupt_Priority
11812 N := First (Private_Declarations (T));
11813 while Present (N) loop
11814 if Nkind (N) = N_Pragma then
11815 if Pragma_Name (N) = P then
11818 elsif P = Name_Priority
11819 and then Pragma_Name (N) = Name_Interrupt_Priority
11832 raise Program_Error;
11833 end Find_Task_Or_Protected_Pragma;
11835 -------------------------------
11836 -- First_Protected_Operation --
11837 -------------------------------
11839 function First_Protected_Operation (D : List_Id) return Node_Id is
11840 First_Op : Node_Id;
11843 First_Op := First (D);
11844 while Present (First_Op)
11845 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body)
11851 end First_Protected_Operation;
11853 ---------------------------------------
11854 -- Install_Private_Data_Declarations --
11855 ---------------------------------------
11857 procedure Install_Private_Data_Declarations
11859 Spec_Id : Entity_Id;
11860 Conc_Typ : Entity_Id;
11861 Body_Nod : Node_Id;
11863 Barrier : Boolean := False;
11864 Family : Boolean := False)
11866 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ);
11869 Insert_Node : Node_Id := Empty;
11870 Obj_Ent : Entity_Id;
11872 procedure Add (Decl : Node_Id);
11873 -- Add a single declaration after Insert_Node. If this is the first
11874 -- addition, Decl is added to the front of Decls and it becomes the
11877 function Replace_Bound (Bound : Node_Id) return Node_Id;
11878 -- The bounds of an entry index may depend on discriminants, create a
11879 -- reference to the corresponding prival. Otherwise return a duplicate
11880 -- of the original bound.
11886 procedure Add (Decl : Node_Id) is
11888 if No (Insert_Node) then
11889 Prepend_To (Decls, Decl);
11891 Insert_After (Insert_Node, Decl);
11894 Insert_Node := Decl;
11897 --------------------------
11898 -- Replace_Discriminant --
11899 --------------------------
11901 function Replace_Bound (Bound : Node_Id) return Node_Id is
11903 if Nkind (Bound) = N_Identifier
11904 and then Is_Discriminal (Entity (Bound))
11906 return Make_Identifier (Loc, Chars (Entity (Bound)));
11908 return Duplicate_Subexpr (Bound);
11912 -- Start of processing for Install_Private_Data_Declarations
11915 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
11916 -- formal parameter _O, _object or _task depending on the context.
11918 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ);
11920 -- Special processing of _O for barrier functions, protected entries
11927 (Ekind (Spec_Id) = E_Entry
11928 or else Ekind (Spec_Id) = E_Entry_Family))
11931 Conc_Rec : constant Entity_Id :=
11932 Corresponding_Record_Type (Conc_Typ);
11933 Typ_Id : constant Entity_Id :=
11934 Make_Defining_Identifier (Loc,
11935 New_External_Name (Chars (Conc_Rec), 'P'));
11938 -- type prot_typVP is access prot_typV;
11941 Make_Full_Type_Declaration (Loc,
11942 Defining_Identifier => Typ_Id,
11944 Make_Access_To_Object_Definition (Loc,
11945 Subtype_Indication =>
11946 New_Reference_To (Conc_Rec, Loc)));
11950 -- _object : prot_typVP := prot_typV (_O);
11953 Make_Object_Declaration (Loc,
11954 Defining_Identifier =>
11955 Make_Defining_Identifier (Loc, Name_uObject),
11956 Object_Definition => New_Reference_To (Typ_Id, Loc),
11958 Unchecked_Convert_To (Typ_Id,
11959 New_Reference_To (Obj_Ent, Loc)));
11962 -- Set the reference to the concurrent object
11964 Obj_Ent := Defining_Identifier (Decl);
11968 -- Step 2: Create the Protection object and build its declaration for
11969 -- any protected entry (family) of subprogram.
11971 if Is_Protected then
11973 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
11977 Set_Protection_Object (Spec_Id, Prot_Ent);
11979 -- Determine the proper protection type
11981 if Has_Attach_Handler (Conc_Typ)
11982 and then not Restricted_Profile
11984 Prot_Typ := RE_Static_Interrupt_Protection;
11986 elsif Has_Interrupt_Handler (Conc_Typ) then
11987 Prot_Typ := RE_Dynamic_Interrupt_Protection;
11989 -- The type has explicit entries or generated primitive entry
11992 elsif Has_Entries (Conc_Typ)
11994 (Ada_Version >= Ada_2005
11995 and then Present (Interface_List (Parent (Conc_Typ))))
11997 case Corresponding_Runtime_Package (Conc_Typ) is
11998 when System_Tasking_Protected_Objects_Entries =>
11999 Prot_Typ := RE_Protection_Entries;
12001 when System_Tasking_Protected_Objects_Single_Entry =>
12002 Prot_Typ := RE_Protection_Entry;
12005 raise Program_Error;
12009 Prot_Typ := RE_Protection;
12013 -- conc_typR : protection_typ renames _object._object;
12016 Make_Object_Renaming_Declaration (Loc,
12017 Defining_Identifier => Prot_Ent,
12019 New_Reference_To (RTE (Prot_Typ), Loc),
12021 Make_Selected_Component (Loc,
12022 Prefix => New_Reference_To (Obj_Ent, Loc),
12023 Selector_Name => Make_Identifier (Loc, Name_uObject)));
12028 -- Step 3: Add discriminant renamings (if any)
12030 if Has_Discriminants (Conc_Typ) then
12035 D := First_Discriminant (Conc_Typ);
12036 while Present (D) loop
12038 -- Adjust the source location
12040 Set_Sloc (Discriminal (D), Loc);
12043 -- discr_name : discr_typ renames _object.discr_name;
12045 -- discr_name : discr_typ renames _task.discr_name;
12048 Make_Object_Renaming_Declaration (Loc,
12049 Defining_Identifier => Discriminal (D),
12050 Subtype_Mark => New_Reference_To (Etype (D), Loc),
12052 Make_Selected_Component (Loc,
12053 Prefix => New_Reference_To (Obj_Ent, Loc),
12054 Selector_Name => Make_Identifier (Loc, Chars (D))));
12057 Next_Discriminant (D);
12062 -- Step 4: Add private component renamings (if any)
12064 if Is_Protected then
12065 Def := Protected_Definition (Parent (Conc_Typ));
12067 if Present (Private_Declarations (Def)) then
12070 Comp_Id : Entity_Id;
12071 Decl_Id : Entity_Id;
12074 Comp := First (Private_Declarations (Def));
12075 while Present (Comp) loop
12076 if Nkind (Comp) = N_Component_Declaration then
12077 Comp_Id := Defining_Identifier (Comp);
12079 Make_Defining_Identifier (Loc, Chars (Comp_Id));
12081 -- Minimal decoration
12083 if Ekind (Spec_Id) = E_Function then
12084 Set_Ekind (Decl_Id, E_Constant);
12086 Set_Ekind (Decl_Id, E_Variable);
12089 Set_Prival (Comp_Id, Decl_Id);
12090 Set_Prival_Link (Decl_Id, Comp_Id);
12091 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
12094 -- comp_name : comp_typ renames _object.comp_name;
12097 Make_Object_Renaming_Declaration (Loc,
12098 Defining_Identifier => Decl_Id,
12100 New_Reference_To (Etype (Comp_Id), Loc),
12102 Make_Selected_Component (Loc,
12104 New_Reference_To (Obj_Ent, Loc),
12106 Make_Identifier (Loc, Chars (Comp_Id))));
12116 -- Step 5: Add the declaration of the entry index and the associated
12117 -- type for barrier functions and entry families.
12119 if (Barrier and then Family)
12120 or else Ekind (Spec_Id) = E_Entry_Family
12123 E : constant Entity_Id := Index_Object (Spec_Id);
12124 Index : constant Entity_Id :=
12125 Defining_Identifier (
12126 Entry_Index_Specification (
12127 Entry_Body_Formal_Part (Body_Nod)));
12128 Index_Con : constant Entity_Id :=
12129 Make_Defining_Identifier (Loc, Chars (Index));
12131 Index_Typ : Entity_Id;
12135 -- Minimal decoration
12137 Set_Ekind (Index_Con, E_Constant);
12138 Set_Entry_Index_Constant (Index, Index_Con);
12139 Set_Discriminal_Link (Index_Con, Index);
12141 -- Retrieve the bounds of the entry family
12143 High := Type_High_Bound (Etype (Index));
12144 Low := Type_Low_Bound (Etype (Index));
12146 -- In the simple case the entry family is given by a subtype
12147 -- mark and the index constant has the same type.
12149 if Is_Entity_Name (Original_Node (
12150 Discrete_Subtype_Definition (Parent (Index))))
12152 Index_Typ := Etype (Index);
12154 -- Otherwise a new subtype declaration is required
12157 High := Replace_Bound (High);
12158 Low := Replace_Bound (Low);
12160 Index_Typ := Make_Temporary (Loc, 'J');
12163 -- subtype Jnn is <Etype of Index> range Low .. High;
12166 Make_Subtype_Declaration (Loc,
12167 Defining_Identifier => Index_Typ,
12168 Subtype_Indication =>
12169 Make_Subtype_Indication (Loc,
12171 New_Reference_To (Base_Type (Etype (Index)), Loc),
12173 Make_Range_Constraint (Loc,
12174 Range_Expression =>
12175 Make_Range (Loc, Low, High))));
12179 Set_Etype (Index_Con, Index_Typ);
12181 -- Create the object which designates the index:
12182 -- J : constant Jnn :=
12183 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
12185 -- where Jnn is the subtype created above or the original type of
12186 -- the index, _E is a formal of the protected body subprogram and
12187 -- <index expr> is the index of the first family member.
12190 Make_Object_Declaration (Loc,
12191 Defining_Identifier => Index_Con,
12192 Constant_Present => True,
12193 Object_Definition =>
12194 New_Reference_To (Index_Typ, Loc),
12197 Make_Attribute_Reference (Loc,
12199 New_Reference_To (Index_Typ, Loc),
12200 Attribute_Name => Name_Val,
12202 Expressions => New_List (
12206 Make_Op_Subtract (Loc,
12208 New_Reference_To (E, Loc),
12210 Entry_Index_Expression (Loc,
12211 Defining_Identifier (Body_Nod),
12215 Make_Attribute_Reference (Loc,
12217 New_Reference_To (Index_Typ, Loc),
12218 Attribute_Name => Name_Pos,
12219 Expressions => New_List (
12220 Make_Attribute_Reference (Loc,
12222 New_Reference_To (Index_Typ, Loc),
12223 Attribute_Name => Name_First)))))));
12227 end Install_Private_Data_Declarations;
12229 ---------------------------------
12230 -- Is_Potentially_Large_Family --
12231 ---------------------------------
12233 function Is_Potentially_Large_Family
12234 (Base_Index : Entity_Id;
12235 Conctyp : Entity_Id;
12237 Hi : Node_Id) return Boolean
12240 return Scope (Base_Index) = Standard_Standard
12241 and then Base_Index = Base_Type (Standard_Integer)
12242 and then Has_Discriminants (Conctyp)
12244 (Discriminant_Default_Value (First_Discriminant (Conctyp)))
12246 (Denotes_Discriminant (Lo, True)
12247 or else Denotes_Discriminant (Hi, True));
12248 end Is_Potentially_Large_Family;
12250 -------------------------------------
12251 -- Is_Private_Primitive_Subprogram --
12252 -------------------------------------
12254 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
12257 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
12258 and then Is_Private_Primitive (Id);
12259 end Is_Private_Primitive_Subprogram;
12265 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is
12266 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id);
12267 Formal : Entity_Id;
12270 Formal := First_Formal (Bod_Subp);
12271 while Present (Formal) loop
12273 -- Look for formal parameter _E
12275 if Chars (Formal) = Name_uE then
12279 Next_Formal (Formal);
12282 -- A protected body subprogram should always have the parameter in
12285 raise Program_Error;
12288 --------------------------------
12289 -- Make_Initialize_Protection --
12290 --------------------------------
12292 function Make_Initialize_Protection
12293 (Protect_Rec : Entity_Id) return List_Id
12295 Loc : constant Source_Ptr := Sloc (Protect_Rec);
12299 Ptyp : constant Node_Id :=
12300 Corresponding_Concurrent_Type (Protect_Rec);
12302 L : constant List_Id := New_List;
12303 Has_Entry : constant Boolean := Has_Entries (Ptyp);
12304 Restricted : constant Boolean := Restricted_Profile;
12307 -- We may need two calls to properly initialize the object, one to
12308 -- Initialize_Protection, and possibly one to Install_Handlers if we
12309 -- have a pragma Attach_Handler.
12311 -- Get protected declaration. In the case of a task type declaration,
12312 -- this is simply the parent of the protected type entity. In the single
12313 -- protected object declaration, this parent will be the implicit type,
12314 -- and we can find the corresponding single protected object declaration
12315 -- by searching forward in the declaration list in the tree.
12317 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
12318 -- of this type should have been removed during semantic analysis.
12320 Pdec := Parent (Ptyp);
12321 while not Nkind_In (Pdec, N_Protected_Type_Declaration,
12322 N_Single_Protected_Declaration)
12327 -- Now we can find the object definition from this declaration
12329 Pdef := Protected_Definition (Pdec);
12331 -- Build the parameter list for the call. Note that _Init is the name
12332 -- of the formal for the object to be initialized, which is the task
12333 -- value record itself.
12337 -- Object parameter. This is a pointer to the object of type
12338 -- Protection used by the GNARL to control the protected object.
12341 Make_Attribute_Reference (Loc,
12343 Make_Selected_Component (Loc,
12344 Prefix => Make_Identifier (Loc, Name_uInit),
12345 Selector_Name => Make_Identifier (Loc, Name_uObject)),
12346 Attribute_Name => Name_Unchecked_Access));
12348 -- Priority parameter. Set to Unspecified_Priority unless there is a
12349 -- priority pragma, in which case we take the value from the pragma,
12350 -- or there is an interrupt pragma and no priority pragma, and we
12351 -- set the ceiling to Interrupt_Priority'Last, an implementation-
12352 -- defined value, see D.3(10).
12355 and then Has_Pragma_Priority (Pdef)
12358 Prio : constant Node_Id :=
12361 (Pragma_Argument_Associations
12362 (Find_Task_Or_Protected_Pragma
12363 (Pdef, Name_Priority))));
12367 -- If priority is a static expression, then we can duplicate it
12368 -- with no problem and simply append it to the argument list.
12370 if Is_Static_Expression (Prio) then
12372 Duplicate_Subexpr_No_Checks (Prio));
12374 -- Otherwise, the priority may be a per-object expression, if it
12375 -- depends on a discriminant of the type. In this case, create
12376 -- local variable to capture the expression. Note that it is
12377 -- really necessary to create this variable explicitly. It might
12378 -- be thought that removing side effects would the appropriate
12379 -- approach, but that could generate declarations improperly
12380 -- placed in the enclosing scope.
12382 -- Note: Use System.Any_Priority as the expected type for the
12383 -- non-static priority expression, in case the expression has not
12384 -- been analyzed yet (as occurs for example with pragma
12385 -- Interrupt_Priority).
12388 Temp := Make_Temporary (Loc, 'R', Prio);
12390 Make_Object_Declaration (Loc,
12391 Defining_Identifier => Temp,
12392 Object_Definition =>
12393 New_Occurrence_Of (RTE (RE_Any_Priority), Loc),
12394 Expression => Relocate_Node (Prio)));
12396 Append_To (Args, New_Occurrence_Of (Temp, Loc));
12400 -- When no priority is specified but an xx_Handler pragma is, we default
12401 -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10).
12403 elsif Has_Interrupt_Handler (Ptyp)
12404 or else Has_Attach_Handler (Ptyp)
12407 New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
12409 -- Normal case, no priority or xx_Handler specified, default priority
12413 New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
12416 -- Test for Compiler_Info parameter. This parameter allows entry body
12417 -- procedures and barrier functions to be called from the runtime. It
12418 -- is a pointer to the record generated by the compiler to represent
12419 -- the protected object.
12421 -- A protected type without entries that covers an interface and
12422 -- overrides the abstract routines with protected procedures is
12423 -- considered equivalent to a protected type with entries in the
12424 -- context of dispatching select statements.
12427 or else Has_Interrupt_Handler (Ptyp)
12428 or else Has_Attach_Handler (Ptyp)
12429 or else Has_Interfaces (Protect_Rec)
12432 Pkg_Id : constant RTU_Id :=
12433 Corresponding_Runtime_Package (Ptyp);
12434 Called_Subp : RE_Id;
12438 when System_Tasking_Protected_Objects_Entries =>
12439 Called_Subp := RE_Initialize_Protection_Entries;
12441 when System_Tasking_Protected_Objects =>
12442 Called_Subp := RE_Initialize_Protection;
12444 when System_Tasking_Protected_Objects_Single_Entry =>
12445 Called_Subp := RE_Initialize_Protection_Entry;
12448 raise Program_Error;
12452 or else not Restricted
12453 or else Has_Interfaces (Protect_Rec)
12456 Make_Attribute_Reference (Loc,
12457 Prefix => Make_Identifier (Loc, Name_uInit),
12458 Attribute_Name => Name_Address));
12461 -- Entry_Bodies parameter. This is a pointer to an array of
12462 -- pointers to the entry body procedures and barrier functions of
12463 -- the object. If the protected type has no entries this object
12464 -- will not exist, in this case, pass a null.
12467 P_Arr := Entry_Bodies_Array (Ptyp);
12470 Make_Attribute_Reference (Loc,
12471 Prefix => New_Reference_To (P_Arr, Loc),
12472 Attribute_Name => Name_Unrestricted_Access));
12474 if Pkg_Id = System_Tasking_Protected_Objects_Entries then
12476 -- Find index mapping function (clumsy but ok for now)
12478 while Ekind (P_Arr) /= E_Function loop
12479 Next_Entity (P_Arr);
12483 Make_Attribute_Reference (Loc,
12485 New_Reference_To (P_Arr, Loc),
12486 Attribute_Name => Name_Unrestricted_Access));
12488 -- Build_Entry_Names generation flag. When set to true, the
12489 -- runtime will allocate an array to hold the string names
12490 -- of protected entries.
12492 if not Restricted_Profile then
12493 if Entry_Names_OK then
12495 New_Reference_To (Standard_True, Loc));
12498 New_Reference_To (Standard_False, Loc));
12503 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
12504 Append_To (Args, Make_Null (Loc));
12506 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
12507 Append_To (Args, Make_Null (Loc));
12508 Append_To (Args, Make_Null (Loc));
12509 Append_To (Args, New_Reference_To (Standard_False, Loc));
12513 Make_Procedure_Call_Statement (Loc,
12514 Name => New_Reference_To (RTE (Called_Subp), Loc),
12515 Parameter_Associations => Args));
12519 Make_Procedure_Call_Statement (Loc,
12520 Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
12521 Parameter_Associations => Args));
12524 if Has_Attach_Handler (Ptyp) then
12526 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
12527 -- make the following call:
12529 -- Install_Handlers (_object,
12530 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
12532 -- or, in the case of Ravenscar:
12534 -- Install_Restricted_Handlers
12535 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
12538 Args : constant List_Id := New_List;
12539 Table : constant List_Id := New_List;
12540 Ritem : Node_Id := First_Rep_Item (Ptyp);
12543 -- Build the Attach_Handler table argument
12545 while Present (Ritem) loop
12546 if Nkind (Ritem) = N_Pragma
12547 and then Pragma_Name (Ritem) = Name_Attach_Handler
12550 Handler : constant Node_Id :=
12551 First (Pragma_Argument_Associations (Ritem));
12553 Interrupt : constant Node_Id := Next (Handler);
12554 Expr : constant Node_Id := Expression (Interrupt);
12558 Make_Aggregate (Loc, Expressions => New_List (
12559 Unchecked_Convert_To
12560 (RTE (RE_System_Interrupt_Id), Expr),
12561 Make_Attribute_Reference (Loc,
12562 Prefix => Make_Selected_Component (Loc,
12563 Make_Identifier (Loc, Name_uInit),
12564 Duplicate_Subexpr_No_Checks
12565 (Expression (Handler))),
12566 Attribute_Name => Name_Access))));
12570 Next_Rep_Item (Ritem);
12573 -- Append the table argument we just built
12575 Append_To (Args, Make_Aggregate (Loc, Table));
12577 -- Append the Install_Handlers (or Install_Restricted_Handlers)
12578 -- call to the statements.
12581 -- Call a simplified version of Install_Handlers to be used
12582 -- when the Ravenscar restrictions are in effect
12583 -- (Install_Restricted_Handlers).
12586 Make_Procedure_Call_Statement (Loc,
12589 (RTE (RE_Install_Restricted_Handlers), Loc),
12590 Parameter_Associations => Args));
12593 -- First, prepends the _object argument
12596 Make_Attribute_Reference (Loc,
12598 Make_Selected_Component (Loc,
12599 Prefix => Make_Identifier (Loc, Name_uInit),
12600 Selector_Name => Make_Identifier (Loc, Name_uObject)),
12601 Attribute_Name => Name_Unchecked_Access));
12603 -- Then, insert call to Install_Handlers
12606 Make_Procedure_Call_Statement (Loc,
12607 Name => New_Reference_To (RTE (RE_Install_Handlers), Loc),
12608 Parameter_Associations => Args));
12614 end Make_Initialize_Protection;
12616 ---------------------------
12617 -- Make_Task_Create_Call --
12618 ---------------------------
12620 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
12621 Loc : constant Source_Ptr := Sloc (Task_Rec);
12631 Ttyp := Corresponding_Concurrent_Type (Task_Rec);
12632 Tnam := Chars (Ttyp);
12634 -- Get task declaration. In the case of a task type declaration, this is
12635 -- simply the parent of the task type entity. In the single task
12636 -- declaration, this parent will be the implicit type, and we can find
12637 -- the corresponding single task declaration by searching forward in the
12638 -- declaration list in the tree.
12640 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
12641 -- this type should have been removed during semantic analysis.
12643 Tdec := Parent (Ttyp);
12644 while not Nkind_In (Tdec, N_Task_Type_Declaration,
12645 N_Single_Task_Declaration)
12650 -- Now we can find the task definition from this declaration
12652 Tdef := Task_Definition (Tdec);
12654 -- Build the parameter list for the call. Note that _Init is the name
12655 -- of the formal for the object to be initialized, which is the task
12656 -- value record itself.
12660 -- Priority parameter. Set to Unspecified_Priority unless there is a
12661 -- priority pragma, in which case we take the value from the pragma.
12663 if Present (Tdef) and then Has_Pragma_Priority (Tdef) then
12665 Make_Selected_Component (Loc,
12666 Prefix => Make_Identifier (Loc, Name_uInit),
12667 Selector_Name => Make_Identifier (Loc, Name_uPriority)));
12670 New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
12673 -- Optional Stack parameter
12675 if Restricted_Profile then
12677 -- If the stack has been preallocated by the expander then
12678 -- pass its address. Otherwise, pass a null address.
12680 if Preallocated_Stacks_On_Target then
12682 Make_Attribute_Reference (Loc,
12684 Make_Selected_Component (Loc,
12685 Prefix => Make_Identifier (Loc, Name_uInit),
12686 Selector_Name => Make_Identifier (Loc, Name_uStack)),
12687 Attribute_Name => Name_Address));
12691 New_Reference_To (RTE (RE_Null_Address), Loc));
12695 -- Size parameter. If no Storage_Size pragma is present, then
12696 -- the size is taken from the taskZ variable for the type, which
12697 -- is either Unspecified_Size, or has been reset by the use of
12698 -- a Storage_Size attribute definition clause. If a pragma is
12699 -- present, then the size is taken from the _Size field of the
12700 -- task value record, which was set from the pragma value.
12703 and then Has_Storage_Size_Pragma (Tdef)
12706 Make_Selected_Component (Loc,
12707 Prefix => Make_Identifier (Loc, Name_uInit),
12708 Selector_Name => Make_Identifier (Loc, Name_uSize)));
12712 New_Reference_To (Storage_Size_Variable (Ttyp), Loc));
12715 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
12716 -- Task_Info pragma, in which case we take the value from the pragma.
12719 and then Has_Task_Info_Pragma (Tdef)
12722 Make_Selected_Component (Loc,
12723 Prefix => Make_Identifier (Loc, Name_uInit),
12724 Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
12728 New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc));
12731 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU pragma,
12732 -- in which case we take the value from the pragma. The parameter is
12733 -- passed as an Integer because in the case of unspecified CPU the
12734 -- value is not in the range of CPU_Range.
12736 if Present (Tdef) and then Has_Pragma_CPU (Tdef) then
12738 Convert_To (Standard_Integer,
12739 Make_Selected_Component (Loc,
12740 Prefix => Make_Identifier (Loc, Name_uInit),
12741 Selector_Name => Make_Identifier (Loc, Name_uCPU))));
12745 New_Reference_To (RTE (RE_Unspecified_CPU), Loc));
12748 if not Restricted_Profile then
12750 -- Deadline parameter. If no Relative_Deadline pragma is present,
12751 -- then the deadline is Time_Span_Zero. If a pragma is present, then
12752 -- the deadline is taken from the _Relative_Deadline field of the
12753 -- task value record, which was set from the pragma value. Note that
12754 -- this parameter must not be generated for the restricted profiles
12755 -- since Ravenscar does not allow deadlines.
12757 -- Case where pragma Relative_Deadline applies: use given value
12759 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
12761 Make_Selected_Component (Loc,
12763 Make_Identifier (Loc, Name_uInit),
12765 Make_Identifier (Loc, Name_uRelative_Deadline)));
12767 -- No pragma Relative_Deadline apply to the task
12771 New_Reference_To (RTE (RE_Time_Span_Zero), Loc));
12774 -- Number of entries. This is an expression of the form:
12776 -- n + _Init.a'Length + _Init.a'B'Length + ...
12778 -- where a,b... are the entry family names for the task definition
12781 Build_Entry_Count_Expression
12786 (Parent (Corresponding_Record_Type (Ttyp))))),
12788 Append_To (Args, Ecount);
12790 -- Master parameter. This is a reference to the _Master parameter of
12791 -- the initialization procedure, except in the case of the pragma
12792 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
12793 -- System.Tasking.Library_Task_Level.
12795 if Restriction_Active (No_Task_Hierarchy) = False then
12796 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
12799 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
12803 -- State parameter. This is a pointer to the task body procedure. The
12804 -- required value is obtained by taking 'Unrestricted_Access of the task
12805 -- body procedure and converting it (with an unchecked conversion) to
12806 -- the type required by the task kernel. For further details, see the
12807 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
12808 -- than 'Address in order to avoid creating trampolines.
12811 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp);
12812 Subp_Ptr_Typ : constant Node_Id :=
12813 Create_Itype (E_Access_Subprogram_Type, Tdec);
12814 Ref : constant Node_Id := Make_Itype_Reference (Loc);
12817 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc);
12818 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
12820 -- Be sure to freeze a reference to the access-to-subprogram type,
12821 -- otherwise gigi will complain that it's in the wrong scope, because
12822 -- it's actually inside the init procedure for the record type that
12823 -- corresponds to the task type.
12825 -- This processing is causing a crash in the .NET/JVM back ends that
12826 -- is not yet understood, so skip it in these cases ???
12828 if VM_Target = No_VM then
12829 Set_Itype (Ref, Subp_Ptr_Typ);
12830 Append_Freeze_Action (Task_Rec, Ref);
12833 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
12834 Make_Qualified_Expression (Loc,
12835 Subtype_Mark => New_Reference_To (Subp_Ptr_Typ, Loc),
12837 Make_Attribute_Reference (Loc,
12839 New_Occurrence_Of (Body_Proc, Loc),
12840 Attribute_Name => Name_Unrestricted_Access))));
12842 -- For the .NET/JVM cases revert to the original code below ???
12846 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
12847 Make_Attribute_Reference (Loc,
12849 New_Occurrence_Of (Body_Proc, Loc),
12850 Attribute_Name => Name_Address)));
12854 -- Discriminants parameter. This is just the address of the task
12855 -- value record itself (which contains the discriminant values
12858 Make_Attribute_Reference (Loc,
12859 Prefix => Make_Identifier (Loc, Name_uInit),
12860 Attribute_Name => Name_Address));
12862 -- Elaborated parameter. This is an access to the elaboration Boolean
12865 Make_Attribute_Reference (Loc,
12866 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
12867 Attribute_Name => Name_Unchecked_Access));
12869 -- Chain parameter. This is a reference to the _Chain parameter of
12870 -- the initialization procedure.
12872 Append_To (Args, Make_Identifier (Loc, Name_uChain));
12874 -- Task name parameter. Take this from the _Task_Id parameter to the
12875 -- init call unless there is a Task_Name pragma, in which case we take
12876 -- the value from the pragma.
12879 and then Has_Task_Name_Pragma (Tdef)
12881 -- Copy expression in full, because it may be dynamic and have
12887 (Pragma_Argument_Associations
12888 (Find_Task_Or_Protected_Pragma
12889 (Tdef, Name_Task_Name))))));
12892 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
12895 -- Created_Task parameter. This is the _Task_Id field of the task
12899 Make_Selected_Component (Loc,
12900 Prefix => Make_Identifier (Loc, Name_uInit),
12901 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
12903 -- Build_Entry_Names generation flag. When set to true, the runtime
12904 -- will allocate an array to hold the string names of task entries.
12906 if not Restricted_Profile then
12907 if Has_Entries (Ttyp)
12908 and then Entry_Names_OK
12910 Append_To (Args, New_Reference_To (Standard_True, Loc));
12912 Append_To (Args, New_Reference_To (Standard_False, Loc));
12916 if Restricted_Profile then
12917 Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
12919 Name := New_Reference_To (RTE (RE_Create_Task), Loc);
12923 Make_Procedure_Call_Statement (Loc,
12925 Parameter_Associations => Args);
12926 end Make_Task_Create_Call;
12928 ------------------------------
12929 -- Next_Protected_Operation --
12930 ------------------------------
12932 function Next_Protected_Operation (N : Node_Id) return Node_Id is
12936 Next_Op := Next (N);
12937 while Present (Next_Op)
12938 and then not Nkind_In (Next_Op, N_Subprogram_Body, N_Entry_Body)
12944 end Next_Protected_Operation;
12946 ---------------------
12947 -- Null_Statements --
12948 ---------------------
12950 function Null_Statements (Stats : List_Id) return Boolean is
12954 Stmt := First (Stats);
12955 while Nkind (Stmt) /= N_Empty
12956 and then (Nkind_In (Stmt, N_Null_Statement, N_Label)
12958 (Nkind (Stmt) = N_Pragma
12959 and then (Pragma_Name (Stmt) = Name_Unreferenced
12961 Pragma_Name (Stmt) = Name_Unmodified
12963 Pragma_Name (Stmt) = Name_Warnings)))
12968 return Nkind (Stmt) = N_Empty;
12969 end Null_Statements;
12971 --------------------------
12972 -- Parameter_Block_Pack --
12973 --------------------------
12975 function Parameter_Block_Pack
12977 Blk_Typ : Entity_Id;
12981 Stmts : List_Id) return Node_Id
12983 Actual : Entity_Id;
12984 Expr : Node_Id := Empty;
12985 Formal : Entity_Id;
12986 Has_Param : Boolean := False;
12989 Temp_Asn : Node_Id;
12990 Temp_Nam : Node_Id;
12993 Actual := First (Actuals);
12994 Formal := Defining_Identifier (First (Formals));
12995 Params := New_List;
12997 while Present (Actual) loop
12998 if Is_By_Copy_Type (Etype (Actual)) then
13000 -- Jnn : aliased <formal-type>
13002 Temp_Nam := Make_Temporary (Loc, 'J');
13005 Make_Object_Declaration (Loc,
13008 Defining_Identifier =>
13010 Object_Definition =>
13011 New_Reference_To (Etype (Formal), Loc)));
13013 if Ekind (Formal) /= E_Out_Parameter then
13019 New_Reference_To (Temp_Nam, Loc);
13021 Set_Assignment_OK (Temp_Asn);
13024 Make_Assignment_Statement (Loc,
13028 New_Copy_Tree (Actual)));
13032 -- Jnn'unchecked_access
13035 Make_Attribute_Reference (Loc,
13037 Name_Unchecked_Access,
13039 New_Reference_To (Temp_Nam, Loc)));
13043 -- The controlling parameter is omitted
13046 if not Is_Controlling_Actual (Actual) then
13048 Make_Reference (Loc, New_Copy_Tree (Actual)));
13054 Next_Actual (Actual);
13055 Next_Formal_With_Extras (Formal);
13059 Expr := Make_Aggregate (Loc, Params);
13064 -- J1'unchecked_access;
13065 -- <actual2>'reference;
13068 P := Make_Temporary (Loc, 'P');
13071 Make_Object_Declaration (Loc,
13072 Defining_Identifier =>
13074 Object_Definition =>
13075 New_Reference_To (Blk_Typ, Loc),
13080 end Parameter_Block_Pack;
13082 ----------------------------
13083 -- Parameter_Block_Unpack --
13084 ----------------------------
13086 function Parameter_Block_Unpack
13090 Formals : List_Id) return List_Id
13092 Actual : Entity_Id;
13094 Formal : Entity_Id;
13095 Has_Asnmt : Boolean := False;
13096 Result : constant List_Id := New_List;
13099 Actual := First (Actuals);
13100 Formal := Defining_Identifier (First (Formals));
13101 while Present (Actual) loop
13102 if Is_By_Copy_Type (Etype (Actual))
13103 and then Ekind (Formal) /= E_In_Parameter
13106 -- <actual> := P.<formal>;
13109 Make_Assignment_Statement (Loc,
13113 Make_Explicit_Dereference (Loc,
13114 Make_Selected_Component (Loc,
13116 New_Reference_To (P, Loc),
13118 Make_Identifier (Loc, Chars (Formal)))));
13120 Set_Assignment_OK (Name (Asnmt));
13121 Append_To (Result, Asnmt);
13126 Next_Actual (Actual);
13127 Next_Formal_With_Extras (Formal);
13133 return New_List (Make_Null_Statement (Loc));
13135 end Parameter_Block_Unpack;
13137 ----------------------
13138 -- Set_Discriminals --
13139 ----------------------
13141 procedure Set_Discriminals (Dec : Node_Id) is
13144 D_Minal : Entity_Id;
13147 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
13148 Pdef := Defining_Identifier (Dec);
13150 if Has_Discriminants (Pdef) then
13151 D := First_Discriminant (Pdef);
13152 while Present (D) loop
13154 Make_Defining_Identifier (Sloc (D),
13155 Chars => New_External_Name (Chars (D), 'D'));
13157 Set_Ekind (D_Minal, E_Constant);
13158 Set_Etype (D_Minal, Etype (D));
13159 Set_Scope (D_Minal, Pdef);
13160 Set_Discriminal (D, D_Minal);
13161 Set_Discriminal_Link (D_Minal, D);
13163 Next_Discriminant (D);
13166 end Set_Discriminals;
13168 -----------------------
13169 -- Trivial_Accept_OK --
13170 -----------------------
13172 function Trivial_Accept_OK return Boolean is
13174 case Opt.Task_Dispatching_Policy is
13176 -- If we have the default task dispatching policy in effect, we can
13177 -- definitely do the optimization (one way of looking at this is to
13178 -- think of the formal definition of the default policy being allowed
13179 -- to run any task it likes after a rendezvous, so even if notionally
13180 -- a full rescheduling occurs, we can say that our dispatching policy
13181 -- (i.e. the default dispatching policy) reorders the queue to be the
13182 -- same as just before the call.
13187 -- FIFO_Within_Priorities certainly does not permit this
13188 -- optimization since the Rendezvous is a scheduling action that may
13189 -- require some other task to be run.
13194 -- For now, disallow the optimization for all other policies. This
13195 -- may be over-conservative, but it is certainly not incorrect.
13201 end Trivial_Accept_OK;