1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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_Ch9; use Sem_Ch9;
55 with Sem_Ch11; use Sem_Ch11;
56 with Sem_Elab; use Sem_Elab;
57 with Sem_Eval; use Sem_Eval;
58 with Sem_Res; use Sem_Res;
59 with Sem_Util; use Sem_Util;
60 with Sinfo; use Sinfo;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Targparm; use Targparm;
64 with Tbuild; use Tbuild;
65 with Uintp; use Uintp;
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 entry
73 -- families of 128K should be reasonable in all cases, and is a documented
74 -- implementation restriction.
76 Entry_Family_Bound : constant Pos := 2**16;
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 function Actual_Index_Expression
86 Tsk : Entity_Id) return Node_Id;
87 -- Compute the index position for an entry call. Tsk is the target task. If
88 -- the bounds of some entry family depend on discriminants, the expression
89 -- computed by this function uses the discriminants of the target task.
91 procedure Add_Object_Pointer
95 -- Prepend an object pointer declaration to the declaration list Decls.
96 -- This object pointer is initialized to a type conversion of the System.
97 -- Address pointer passed to entry barrier functions and entry body
100 procedure Add_Formal_Renamings
105 -- Create renaming declarations for the formals, inside the procedure that
106 -- implements an entry body. The renamings make the original names of the
107 -- formals accessible to gdb, and serve no other purpose.
108 -- Spec is the specification of the procedure being built.
109 -- Decls is the list of declarations to be enhanced.
110 -- Ent is the entity for the original entry body.
112 function Build_Accept_Body (Astat : Node_Id) return Node_Id;
113 -- Transform accept statement into a block with added exception handler.
114 -- Used both for simple accept statements and for accept alternatives in
115 -- select statements. Astat is the accept statement.
117 function Build_Barrier_Function
120 Pid : Node_Id) return Node_Id;
121 -- Build the function body returning the value of the barrier expression
122 -- for the specified entry body.
124 function Build_Barrier_Function_Specification
126 Def_Id : Entity_Id) return Node_Id;
127 -- Build a specification for a function implementing the protected entry
128 -- barrier of the specified entry body.
130 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id);
131 -- Build the body of a wrapper procedure for an entry or entry family that
132 -- has contract cases, preconditions, or postconditions. The body gathers
133 -- the executable contract items and expands them in the usual way, and
134 -- performs the entry call itself. This way preconditions are evaluated
135 -- before the call is queued. E is the entry in question, and Decl is the
136 -- enclosing synchronized type declaration at whose freeze point the
137 -- generated body is analyzed.
139 function Build_Corresponding_Record
142 Loc : Source_Ptr) return Node_Id;
143 -- Common to tasks and protected types. Copy discriminant specifications,
144 -- build record declaration. N is the type declaration, Ctyp is the
145 -- concurrent entity (task type or protected type).
147 function Build_Dispatching_Tag_Check
149 N : Node_Id) return Node_Id;
150 -- Utility to create the tree to check whether the dispatching call in
151 -- a timed entry call, a conditional entry call, or an asynchronous
152 -- transfer of control is a call to a primitive of a non-synchronized type.
153 -- K is the temporary that holds the tagged kind of the target object, and
154 -- N is the enclosing construct.
156 function Build_Entry_Count_Expression
157 (Concurrent_Type : Node_Id;
158 Component_List : List_Id;
159 Loc : Source_Ptr) return Node_Id;
160 -- Compute number of entries for concurrent object. This is a count of
161 -- simple entries, followed by an expression that computes the length
162 -- of the range of each entry family. A single array with that size is
163 -- allocated for each concurrent object of the type.
165 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
166 -- Build the function that translates the entry index in the call
167 -- (which depends on the size of entry families) into an index into the
168 -- Entry_Bodies_Array, to determine the body and barrier function used
169 -- in a protected entry call. A pointer to this function appears in every
172 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
173 -- Build subprogram declaration for previous one
175 function Build_Lock_Free_Protected_Subprogram_Body
178 Unprot_Spec : Node_Id) return Node_Id;
179 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
180 -- the subprogram specification of the unprotected version of N. Transform
181 -- N such that it invokes the unprotected version of the body.
183 function Build_Lock_Free_Unprotected_Subprogram_Body
185 Prot_Typ : Node_Id) return Node_Id;
186 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
187 -- of N where the original statements of N are synchronized through atomic
188 -- actions such as compare and exchange. Prior to invoking this routine, it
189 -- has been established that N can be implemented in a lock-free fashion.
191 function Build_Parameter_Block
195 Decls : List_Id) return Entity_Id;
196 -- Generate an access type for each actual parameter in the list Actuals.
197 -- Create an encapsulating record that contains all the actuals and return
198 -- its type. Generate:
199 -- type Ann1 is access all <actual1-type>
201 -- type AnnN is access all <actualN-type>
202 -- type Pnn is record
208 function Build_Protected_Entry
211 Pid : Node_Id) return Node_Id;
212 -- Build the procedure implementing the statement sequence of the specified
215 function Build_Protected_Entry_Specification
218 Ent_Id : Entity_Id) return Node_Id;
219 -- Build a specification for the procedure implementing the statements of
220 -- the specified entry body. Add attributes associating it with the entry
221 -- defining identifier Ent_Id.
223 function Build_Protected_Spec
225 Obj_Type : Entity_Id;
227 Unprotected : Boolean := False) return List_Id;
228 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
229 -- Subprogram_Type. Builds signature of protected subprogram, adding the
230 -- formal that corresponds to the object itself. For an access to protected
231 -- subprogram, there is no object type to specify, so the parameter has
232 -- type Address and mode In. An indirect call through such a pointer will
233 -- convert the address to a reference to the actual object. The object is
234 -- a limited record and therefore a by_reference type.
236 function Build_Protected_Subprogram_Body
239 N_Op_Spec : Node_Id) return Node_Id;
240 -- This function is used to construct the protected version of a protected
241 -- subprogram. Its statement sequence first defers abort, then locks the
242 -- associated protected object, and then enters a block that contains a
243 -- call to the unprotected version of the subprogram (for details, see
244 -- Build_Unprotected_Subprogram_Body). This block statement requires a
245 -- cleanup handler that unlocks the object in all cases. For details,
246 -- see Exp_Ch7.Expand_Cleanup_Actions.
248 function Build_Renamed_Formal_Declaration
252 Renamed_Formal : Node_Id) return Node_Id;
253 -- Create a renaming declaration for a formal, within a protected entry
254 -- body or an accept body. The renamed object is a component of the
255 -- parameter block that is a parameter in the entry call.
257 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
258 -- does not dereference the corresponding component to prevent an illegal
259 -- use of the incomplete type (AI05-0151).
261 function Build_Selected_Name
263 Selector : Entity_Id;
264 Append_Char : Character := ' ') return Name_Id;
265 -- Build a name in the form of Prefix__Selector, with an optional character
266 -- appended. This is used for internal subprograms generated for operations
267 -- of protected types, including barrier functions. For the subprograms
268 -- generated for entry bodies and entry barriers, the generated name
269 -- includes a sequence number that makes names unique in the presence of
270 -- entry overloading. This is necessary because entry body procedures and
271 -- barrier functions all have the same signature.
273 procedure Build_Simple_Entry_Call
278 -- Some comments here would be useful ???
280 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
281 -- This routine constructs a specification for the procedure that we will
282 -- build for the task body for task type T. The spec has the form:
284 -- procedure tnameB (_Task : access tnameV);
286 -- where name is the character name taken from the task type entity that
287 -- is passed as the argument to the procedure, and tnameV is the task
288 -- value type that is associated with the task type.
290 function Build_Unprotected_Subprogram_Body
292 Pid : Node_Id) return Node_Id;
293 -- This routine constructs the unprotected version of a protected
294 -- subprogram body, which is contains all of the code in the original,
295 -- unexpanded body. This is the version of the protected subprogram that is
296 -- called from all protected operations on the same object, including the
297 -- protected version of the same subprogram.
299 procedure Build_Wrapper_Bodies
303 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
304 -- record of a concurrent type. N is the insertion node where all bodies
305 -- will be placed. This routine builds the bodies of the subprograms which
306 -- serve as an indirection mechanism to overriding primitives of concurrent
307 -- types, entries and protected procedures. Any new body is analyzed.
309 procedure Build_Wrapper_Specs
313 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
314 -- record of a concurrent type. N is the insertion node where all specs
315 -- will be placed. This routine builds the specs of the subprograms which
316 -- serve as an indirection mechanism to overriding primitives of concurrent
317 -- types, entries and protected procedures. Any new spec is analyzed.
319 procedure Collect_Entry_Families
322 Current_Node : in out Node_Id;
323 Conctyp : Entity_Id);
324 -- For each entry family in a concurrent type, create an anonymous array
325 -- type of the right size, and add a component to the corresponding_record.
327 function Concurrent_Object
328 (Spec_Id : Entity_Id;
329 Conc_Typ : Entity_Id) return Entity_Id;
330 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
331 -- the entity associated with the concurrent object in the Protected_Body_
332 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
333 -- denotes formal parameter _O, _object or _task.
335 function Copy_Result_Type (Res : Node_Id) return Node_Id;
336 -- Copy the result type of a function specification, when building the
337 -- internal operation corresponding to a protected function, or when
338 -- expanding an access to protected function. If the result is an anonymous
339 -- access to subprogram itself, we need to create a new signature with the
340 -- same parameter names and the same resolved types, but with new entities
343 procedure Debug_Private_Data_Declarations (Decls : List_Id);
344 -- Decls is a list which may contain the declarations created by Install_
345 -- Private_Data_Declarations. All generated entities are marked as needing
346 -- debug info and debug nodes are manually generation where necessary. This
347 -- step of the expansion must to be done after private data has been moved
348 -- to its final resting scope to ensure proper visibility of debug objects.
350 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id);
351 -- If control flow optimizations are suppressed, and Alt is an accept,
352 -- delay, or entry call alternative with no trailing statements, insert
353 -- a null trailing statement with the given Loc (which is the sloc of
354 -- the accept, delay, or entry call statement). There might not be any
355 -- generated code for the accept, delay, or entry call itself (the effect
356 -- of these statements is part of the general processsing done for the
357 -- enclosing selective accept, timed entry call, or asynchronous select),
358 -- and the null statement is there to carry the sloc of that statement to
359 -- the back-end for trace-based coverage analysis purposes.
361 procedure Extract_Dispatching_Call
363 Call_Ent : out Entity_Id;
364 Object : out Entity_Id;
365 Actuals : out List_Id;
366 Formals : out List_Id);
367 -- Given a dispatching call, extract the entity of the name of the call,
368 -- its actual dispatching object, its actual parameters and the formal
369 -- parameters of the overridden interface-level version. If the type of
370 -- the dispatching object is an access type then an explicit dereference
371 -- is returned in Object.
373 procedure Extract_Entry
375 Concval : out Node_Id;
377 Index : out Node_Id);
378 -- Given an entry call, returns the associated concurrent object, the entry
379 -- name, and the entry family index.
381 function Family_Offset
386 Cap : Boolean) return Node_Id;
387 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
388 -- accept statement, or the upper bound in the discrete subtype of an entry
389 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
390 -- type of the entry. If Cap is true, the result is capped according to
391 -- Entry_Family_Bound.
398 Cap : Boolean) return Node_Id;
399 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
400 -- family, and handle properly the superflat case. This is equivalent to
401 -- the use of 'Length on the index type, but must use Family_Offset to
402 -- handle properly the case of bounds that depend on discriminants. If
403 -- Cap is true, the result is capped according to Entry_Family_Bound.
405 procedure Find_Enclosing_Context
407 Context : out Node_Id;
408 Context_Id : out Entity_Id;
409 Context_Decls : out List_Id);
410 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
411 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
412 -- nearest enclosing body, block, package, or return statement and return
413 -- its constituents. Context is the enclosing construct, Context_Id is
414 -- the scope of Context_Id and Context_Decls is the declarative list of
417 function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
418 -- Given a subprogram identifier, return the entity which is associated
419 -- with the protection entry index in the Protected_Body_Subprogram or
420 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
423 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
424 -- Tell whether a given subprogram cannot raise an exception
426 function Is_Potentially_Large_Family
427 (Base_Index : Entity_Id;
430 Hi : Node_Id) return Boolean;
432 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
433 -- Determine whether Id is a function or a procedure and is marked as a
434 -- private primitive.
436 function Null_Statements (Stats : List_Id) return Boolean;
437 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
438 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
439 -- to still count as null. Returns True for a null sequence. The argument
440 -- is the list of statements from the DO-END sequence.
442 function Parameter_Block_Pack
448 Stmts : List_Id) return Entity_Id;
449 -- Set the components of the generated parameter block with the values
450 -- of the actual parameters. Generate aliased temporaries to capture the
451 -- values for types that are passed by copy. Otherwise generate a reference
452 -- to the actual's value. Return the address of the aggregate block.
454 -- Jnn1 : alias <formal-type1>;
455 -- Jnn1 := <actual1>;
458 -- Jnn1'unchecked_access;
459 -- <actual2>'reference;
462 function Parameter_Block_Unpack
466 Formals : List_Id) return List_Id;
467 -- Retrieve the values of the components from the parameter block and
468 -- assign then to the original actual parameters. Generate:
469 -- <actual1> := P.<formal1>;
471 -- <actualN> := P.<formalN>;
473 function Trivial_Accept_OK return Boolean;
474 -- If there is no DO-END block for an accept, or if the DO-END block has
475 -- only null statements, then it is possible to do the Rendezvous with much
476 -- less overhead using the Accept_Trivial routine in the run-time library.
477 -- However, this is not always a valid optimization. Whether it is valid or
478 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
479 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
480 -- a rescheduling is required, so this optimization is not allowed. This
481 -- function returns True if the optimization is permitted.
483 -----------------------------
484 -- Actual_Index_Expression --
485 -----------------------------
487 function Actual_Index_Expression
491 Tsk : Entity_Id) return Node_Id
493 Ttyp : constant Entity_Id := Etype (Tsk);
501 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
502 -- Compute difference between bounds of entry family
504 --------------------------
505 -- Actual_Family_Offset --
506 --------------------------
508 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
510 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
511 -- Replace a reference to a discriminant with a selected component
512 -- denoting the discriminant of the target task.
514 -----------------------------
515 -- Actual_Discriminant_Ref --
516 -----------------------------
518 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
519 Typ : constant Entity_Id := Etype (Bound);
523 if not Is_Entity_Name (Bound)
524 or else Ekind (Entity (Bound)) /= E_Discriminant
526 if Nkind (Bound) = N_Attribute_Reference then
529 B := New_Copy_Tree (Bound);
534 Make_Selected_Component (Sloc,
535 Prefix => New_Copy_Tree (Tsk),
536 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
538 Analyze_And_Resolve (B, Typ);
542 Make_Attribute_Reference (Sloc,
543 Attribute_Name => Name_Pos,
544 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
545 Expressions => New_List (B));
546 end Actual_Discriminant_Ref;
548 -- Start of processing for Actual_Family_Offset
552 Make_Op_Subtract (Sloc,
553 Left_Opnd => Actual_Discriminant_Ref (Hi),
554 Right_Opnd => Actual_Discriminant_Ref (Lo));
555 end Actual_Family_Offset;
557 -- Start of processing for Actual_Index_Expression
560 -- The queues of entries and entry families appear in textual order in
561 -- the associated record. The entry index is computed as the sum of the
562 -- number of queues for all entries that precede the designated one, to
563 -- which is added the index expression, if this expression denotes a
564 -- member of a family.
566 -- The following is a place holder for the count of simple entries
568 Num := Make_Integer_Literal (Sloc, 1);
570 -- We construct an expression which is a series of addition operations.
571 -- See comments in Entry_Index_Expression, which is identical in
574 if Present (Index) then
575 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
581 Actual_Family_Offset (
582 Make_Attribute_Reference (Sloc,
583 Attribute_Name => Name_Pos,
584 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
585 Expressions => New_List (Relocate_Node (Index))),
586 Type_Low_Bound (S)));
591 -- Now add lengths of preceding entries and entry families
593 Prev := First_Entity (Ttyp);
594 while Chars (Prev) /= Chars (Ent)
595 or else (Ekind (Prev) /= Ekind (Ent))
596 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
598 if Ekind (Prev) = E_Entry then
599 Set_Intval (Num, Intval (Num) + 1);
601 elsif Ekind (Prev) = E_Entry_Family then
603 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
605 -- The need for the following full view retrieval stems from this
606 -- complex case of nested generics and tasking:
609 -- type Formal_Index is range <>;
612 -- type Index is private;
619 -- type Index is new Formal_Index range 1 .. 10;
622 -- package body Outer is
624 -- entry Fam (Index); -- (2)
627 -- package body Inner is -- (3)
635 -- We are currently building the index expression for the entry
636 -- call "T.E" (1). Part of the expansion must mention the range
637 -- of the discrete type "Index" (2) of entry family "Fam".
639 -- However only the private view of type "Index" is available to
640 -- the inner generic (3) because there was no prior mention of
641 -- the type inside "Inner". This visibility requirement is
642 -- implicit and cannot be detected during the construction of
643 -- the generic trees and needs special handling.
646 and then Is_Private_Type (S)
647 and then Present (Full_View (S))
652 Lo := Type_Low_Bound (S);
653 Hi := Type_High_Bound (S);
660 Left_Opnd => Actual_Family_Offset (Hi, Lo),
661 Right_Opnd => Make_Integer_Literal (Sloc, 1)));
663 -- Other components are anonymous types to be ignored
673 end Actual_Index_Expression;
675 --------------------------
676 -- Add_Formal_Renamings --
677 --------------------------
679 procedure Add_Formal_Renamings
685 Ptr : constant Entity_Id :=
687 (Next (First (Parameter_Specifications (Spec))));
688 -- The name of the formal that holds the address of the parameter block
695 Renamed_Formal : Node_Id;
698 Formal := First_Formal (Ent);
699 while Present (Formal) loop
700 Comp := Entry_Component (Formal);
702 Make_Defining_Identifier (Sloc (Formal),
703 Chars => Chars (Formal));
704 Set_Etype (New_F, Etype (Formal));
705 Set_Scope (New_F, Ent);
707 -- Now we set debug info needed on New_F even though it does not come
708 -- from source, so that the debugger will get the right information
709 -- for these generated names.
711 Set_Debug_Info_Needed (New_F);
713 if Ekind (Formal) = E_In_Parameter then
714 Set_Ekind (New_F, E_Constant);
716 Set_Ekind (New_F, E_Variable);
717 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
720 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
723 Make_Selected_Component (Loc,
725 Unchecked_Convert_To (Entry_Parameters_Type (Ent),
726 Make_Identifier (Loc, Chars (Ptr))),
727 Selector_Name => New_Occurrence_Of (Comp, Loc));
730 Build_Renamed_Formal_Declaration
731 (New_F, Formal, Comp, Renamed_Formal);
733 Append (Decl, Decls);
734 Set_Renamed_Object (Formal, New_F);
735 Next_Formal (Formal);
737 end Add_Formal_Renamings;
739 ------------------------
740 -- Add_Object_Pointer --
741 ------------------------
743 procedure Add_Object_Pointer
745 Conc_Typ : Entity_Id;
748 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ);
753 -- Create the renaming declaration for the Protection object of a
754 -- protected type. _Object is used by Complete_Entry_Body.
755 -- ??? An attempt to make this a renaming was unsuccessful.
757 -- Build the entity for the access type
760 Make_Defining_Identifier (Loc,
761 New_External_Name (Chars (Rec_Typ), 'P'));
764 -- _object : poVP := poVP!O;
767 Make_Object_Declaration (Loc,
768 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject),
769 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc),
771 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO)));
772 Set_Debug_Info_Needed (Defining_Identifier (Decl));
773 Prepend_To (Decls, Decl);
776 -- type poVP is access poV;
779 Make_Full_Type_Declaration (Loc,
780 Defining_Identifier =>
783 Make_Access_To_Object_Definition (Loc,
784 Subtype_Indication =>
785 New_Occurrence_Of (Rec_Typ, Loc)));
786 Set_Debug_Info_Needed (Defining_Identifier (Decl));
787 Prepend_To (Decls, Decl);
788 end Add_Object_Pointer;
790 -----------------------
791 -- Build_Accept_Body --
792 -----------------------
794 function Build_Accept_Body (Astat : Node_Id) return Node_Id is
795 Loc : constant Source_Ptr := Sloc (Astat);
796 Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
803 -- At the end of the statement sequence, Complete_Rendezvous is called.
804 -- A label skipping the Complete_Rendezvous, and all other accept
805 -- processing, has already been added for the expansion of requeue
806 -- statements. The Sloc is copied from the last statement since it
807 -- is really part of this last statement.
811 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
812 Insert_Before (Last (Statements (Stats)), Call);
815 -- If exception handlers are present, then append Complete_Rendezvous
816 -- calls to the handlers, and construct the required outer block. As
817 -- above, the Sloc is copied from the last statement in the sequence.
819 if Present (Exception_Handlers (Stats)) then
820 Hand := First (Exception_Handlers (Stats));
821 while Present (Hand) loop
824 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
825 Append (Call, Statements (Hand));
831 Make_Handled_Sequence_Of_Statements (Loc,
832 Statements => New_List (
833 Make_Block_Statement (Loc,
834 Handled_Statement_Sequence => Stats)));
840 -- At this stage we know that the new statement sequence does
841 -- not have an exception handler part, so we supply one to call
842 -- Exceptional_Complete_Rendezvous. This handler is
844 -- when all others =>
845 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
847 -- We handle Abort_Signal to make sure that we properly catch the abort
848 -- case and wake up the caller.
850 Ohandle := Make_Others_Choice (Loc);
851 Set_All_Others (Ohandle);
853 Set_Exception_Handlers (New_S,
855 Make_Implicit_Exception_Handler (Loc,
856 Exception_Choices => New_List (Ohandle),
858 Statements => New_List (
859 Make_Procedure_Call_Statement (Sloc (Stats),
860 Name => New_Occurrence_Of (
861 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
862 Parameter_Associations => New_List (
863 Make_Function_Call (Sloc (Stats),
866 (RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
868 Set_Parent (New_S, Astat); -- temp parent for Analyze call
869 Analyze_Exception_Handlers (Exception_Handlers (New_S));
870 Expand_Exception_Handlers (New_S);
872 -- Exceptional_Complete_Rendezvous must be called with abort still
873 -- deferred, which is the case for a "when all others" handler.
876 end Build_Accept_Body;
878 -----------------------------------
879 -- Build_Activation_Chain_Entity --
880 -----------------------------------
882 procedure Build_Activation_Chain_Entity (N : Node_Id) is
883 function Has_Activation_Chain (Stmt : Node_Id) return Boolean;
884 -- Determine whether an extended return statement has activation chain
886 --------------------------
887 -- Has_Activation_Chain --
888 --------------------------
890 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is
894 Decl := First (Return_Object_Declarations (Stmt));
895 while Present (Decl) loop
896 if Nkind (Decl) = N_Object_Declaration
897 and then Chars (Defining_Identifier (Decl)) = Name_uChain
906 end Has_Activation_Chain;
911 Context_Id : Entity_Id;
914 -- Start of processing for Build_Activation_Chain_Entity
917 -- Activation chain is never used for sequential elaboration policy, see
918 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
920 if Partition_Elaboration_Policy = 'S' then
924 Find_Enclosing_Context (N, Context, Context_Id, Decls);
926 -- If activation chain entity has not been declared already, create one
928 if Nkind (Context) = N_Extended_Return_Statement
929 or else No (Activation_Chain_Entity (Context))
931 -- Since extended return statements do not store the entity of the
932 -- chain, examine the return object declarations to avoid creating
935 if Nkind (Context) = N_Extended_Return_Statement
936 and then Has_Activation_Chain (Context)
942 Loc : constant Source_Ptr := Sloc (Context);
947 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
949 -- Note: An extended return statement is not really a task
950 -- activator, but it does have an activation chain on which to
951 -- store the tasks temporarily. On successful return, the tasks
952 -- on this chain are moved to the chain passed in by the caller.
953 -- We do not build an Activation_Chain_Entity for an extended
954 -- return statement, because we do not want to build a call to
955 -- Activate_Tasks. Task activation is the responsibility of the
958 if Nkind (Context) /= N_Extended_Return_Statement then
959 Set_Activation_Chain_Entity (Context, Chain);
963 Make_Object_Declaration (Loc,
964 Defining_Identifier => Chain,
965 Aliased_Present => True,
967 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc));
969 Prepend_To (Decls, Decl);
971 -- Ensure that _chain appears in the proper scope of the context
973 if Context_Id /= Current_Scope then
974 Push_Scope (Context_Id);
982 end Build_Activation_Chain_Entity;
984 ----------------------------
985 -- Build_Barrier_Function --
986 ----------------------------
988 function Build_Barrier_Function
991 Pid : Node_Id) return Node_Id
993 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
994 Cond : constant Node_Id := Condition (Ent_Formals);
995 Loc : constant Source_Ptr := Sloc (Cond);
996 Func_Id : constant Entity_Id := Barrier_Function (Ent);
997 Op_Decls : constant List_Id := New_List;
1002 -- Add a declaration for the Protection object, renaming declarations
1003 -- for the discriminals and privals and finally a declaration for the
1004 -- entry family index (if applicable).
1006 Install_Private_Data_Declarations (Sloc (N),
1012 Family => Ekind (Ent) = E_Entry_Family);
1014 -- If compiling with -fpreserve-control-flow, make sure we insert an
1015 -- IF statement so that the back-end knows to generate a conditional
1016 -- branch instruction, even if the condition is just the name of a
1017 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1018 -- such redundant IF statements under -fpreserve-control-flow
1019 -- (whether coming from this routine, or directly from source).
1021 if Opt.Suppress_Control_Flow_Optimizations then
1023 Make_Implicit_If_Statement (Cond,
1025 Then_Statements => New_List (
1026 Make_Simple_Return_Statement (Loc,
1027 New_Occurrence_Of (Standard_True, Loc))),
1029 Else_Statements => New_List (
1030 Make_Simple_Return_Statement (Loc,
1031 New_Occurrence_Of (Standard_False, Loc))));
1034 Stmt := Make_Simple_Return_Statement (Loc, Cond);
1037 -- Note: the condition in the barrier function needs to be properly
1038 -- processed for the C/Fortran boolean possibility, but this happens
1039 -- automatically since the return statement does this normalization.
1042 Make_Subprogram_Body (Loc,
1044 Build_Barrier_Function_Specification (Loc,
1045 Make_Defining_Identifier (Loc, Chars (Func_Id))),
1046 Declarations => Op_Decls,
1047 Handled_Statement_Sequence =>
1048 Make_Handled_Sequence_Of_Statements (Loc,
1049 Statements => New_List (Stmt)));
1050 Set_Is_Entry_Barrier_Function (Func_Body);
1053 end Build_Barrier_Function;
1055 ------------------------------------------
1056 -- Build_Barrier_Function_Specification --
1057 ------------------------------------------
1059 function Build_Barrier_Function_Specification
1061 Def_Id : Entity_Id) return Node_Id
1064 Set_Debug_Info_Needed (Def_Id);
1067 Make_Function_Specification (Loc,
1068 Defining_Unit_Name => Def_Id,
1069 Parameter_Specifications => New_List (
1070 Make_Parameter_Specification (Loc,
1071 Defining_Identifier =>
1072 Make_Defining_Identifier (Loc, Name_uO),
1074 New_Occurrence_Of (RTE (RE_Address), Loc)),
1076 Make_Parameter_Specification (Loc,
1077 Defining_Identifier =>
1078 Make_Defining_Identifier (Loc, Name_uE),
1080 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
1082 Result_Definition =>
1083 New_Occurrence_Of (Standard_Boolean, Loc));
1084 end Build_Barrier_Function_Specification;
1086 --------------------------
1087 -- Build_Call_With_Task --
1088 --------------------------
1090 function Build_Call_With_Task
1092 E : Entity_Id) return Node_Id
1094 Loc : constant Source_Ptr := Sloc (N);
1097 Make_Function_Call (Loc,
1098 Name => New_Occurrence_Of (E, Loc),
1099 Parameter_Associations => New_List (Concurrent_Ref (N)));
1100 end Build_Call_With_Task;
1102 -----------------------------
1103 -- Build_Class_Wide_Master --
1104 -----------------------------
1106 procedure Build_Class_Wide_Master (Typ : Entity_Id) is
1107 Loc : constant Source_Ptr := Sloc (Typ);
1108 Master_Decl : Node_Id;
1109 Master_Id : Entity_Id;
1110 Master_Scope : Entity_Id;
1112 Related_Node : Node_Id;
1116 -- Nothing to do if there is no task hierarchy
1118 if Restriction_Active (No_Task_Hierarchy) then
1122 -- Find the declaration that created the access type, which is either a
1123 -- type declaration, or an object declaration with an access definition,
1124 -- in which case the type is anonymous.
1126 if Is_Itype (Typ) then
1127 Related_Node := Associated_Node_For_Itype (Typ);
1129 Related_Node := Parent (Typ);
1132 Master_Scope := Find_Master_Scope (Typ);
1134 -- Nothing to do if the master scope already contains a _master entity.
1135 -- The only exception to this is the following scenario:
1138 -- Transient_Scope_1
1141 -- Transient_Scope_2
1144 -- In this case the source scope is marked as having the master entity
1145 -- even though the actual declaration appears inside an inner scope. If
1146 -- the second transient scope requires a _master, it cannot use the one
1147 -- already declared because the entity is not visible.
1149 Name_Id := Make_Identifier (Loc, Name_uMaster);
1150 Master_Decl := Empty;
1152 if not Has_Master_Entity (Master_Scope)
1153 or else No (Current_Entity_In_Scope (Name_Id))
1156 Set_Has_Master_Entity (Master_Scope);
1159 -- _master : constant Integer := Current_Master.all;
1162 Make_Object_Declaration (Loc,
1163 Defining_Identifier =>
1164 Make_Defining_Identifier (Loc, Name_uMaster),
1165 Constant_Present => True,
1166 Object_Definition =>
1167 New_Occurrence_Of (Standard_Integer, Loc),
1169 Make_Explicit_Dereference (Loc,
1170 New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
1172 Insert_Action (Find_Hook_Context (Related_Node), Master_Decl);
1173 Analyze (Master_Decl);
1175 -- Mark the containing scope as a task master. Masters associated
1176 -- with return statements are already marked at this stage (see
1177 -- Analyze_Subprogram_Body).
1179 if Ekind (Current_Scope) /= E_Return_Statement then
1181 Par : Node_Id := Related_Node;
1184 while Nkind (Par) /= N_Compilation_Unit loop
1185 Par := Parent (Par);
1187 -- If we fall off the top, we are at the outer level,
1188 -- and the environment task is our effective master,
1189 -- so nothing to mark.
1191 if Nkind_In (Par, N_Block_Statement,
1195 Set_Is_Task_Master (Par);
1205 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M'));
1208 -- typeMnn renames _master;
1211 Make_Object_Renaming_Declaration (Loc,
1212 Defining_Identifier => Master_Id,
1213 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
1216 -- If the master is declared locally, add the renaming declaration
1217 -- immediately after it, to prevent access-before-elaboration in the
1220 if Present (Master_Decl) then
1221 Insert_After (Master_Decl, Ren_Decl);
1225 Insert_Action (Related_Node, Ren_Decl);
1228 Set_Master_Id (Typ, Master_Id);
1229 end Build_Class_Wide_Master;
1231 ----------------------------
1232 -- Build_Contract_Wrapper --
1233 ----------------------------
1235 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is
1236 Conc_Typ : constant Entity_Id := Scope (E);
1237 Loc : constant Source_Ptr := Sloc (E);
1239 procedure Add_Discriminant_Renamings
1240 (Obj_Id : Entity_Id;
1242 -- Add renaming declarations for all discriminants of concurrent type
1243 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1244 -- represents the concurrent object.
1246 procedure Add_Matching_Formals
1248 Actuals : in out List_Id);
1249 -- Add formal parameters that match those of entry E to list Formals.
1250 -- The routine also adds matching actuals for the new formals to list
1253 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id);
1254 -- Relocate pragma Prag to list To. The routine creates a new list if
1255 -- To does not exist.
1257 --------------------------------
1258 -- Add_Discriminant_Renamings --
1259 --------------------------------
1261 procedure Add_Discriminant_Renamings
1262 (Obj_Id : Entity_Id;
1268 -- Inspect the discriminants of the concurrent type and generate a
1269 -- renaming for each one.
1271 if Has_Discriminants (Conc_Typ) then
1272 Discr := First_Discriminant (Conc_Typ);
1273 while Present (Discr) loop
1275 Make_Object_Renaming_Declaration (Loc,
1276 Defining_Identifier =>
1277 Make_Defining_Identifier (Loc, Chars (Discr)),
1279 New_Occurrence_Of (Etype (Discr), Loc),
1281 Make_Selected_Component (Loc,
1282 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1284 Make_Identifier (Loc, Chars (Discr)))));
1286 Next_Discriminant (Discr);
1289 end Add_Discriminant_Renamings;
1291 --------------------------
1292 -- Add_Matching_Formals --
1293 --------------------------
1295 procedure Add_Matching_Formals
1297 Actuals : in out List_Id)
1300 New_Formal : Entity_Id;
1303 -- Inspect the formal parameters of the entry and generate a new
1304 -- matching formal with the same name for the wrapper. A reference
1305 -- to the new formal becomes an actual in the entry call.
1307 Formal := First_Formal (E);
1308 while Present (Formal) loop
1309 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal));
1311 Make_Parameter_Specification (Loc,
1312 Defining_Identifier => New_Formal,
1313 In_Present => In_Present (Parent (Formal)),
1314 Out_Present => Out_Present (Parent (Formal)),
1316 New_Occurrence_Of (Etype (Formal), Loc)));
1318 if No (Actuals) then
1319 Actuals := New_List;
1322 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
1323 Next_Formal (Formal);
1325 end Add_Matching_Formals;
1327 ---------------------
1328 -- Transfer_Pragma --
1329 ---------------------
1331 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is
1339 New_Prag := Relocate_Node (Prag);
1341 Set_Analyzed (New_Prag, False);
1342 Append (New_Prag, To);
1343 end Transfer_Pragma;
1347 Items : constant Node_Id := Contract (E);
1348 Actuals : List_Id := No_List;
1351 Decls : List_Id := No_List;
1353 Has_Pragma : Boolean := False;
1354 Index_Id : Entity_Id;
1357 Wrapper_Id : Entity_Id;
1359 -- Start of processing for Build_Contract_Wrapper
1362 -- This routine generates a specialized wrapper for a protected or task
1363 -- entry [family] which implements precondition/postcondition semantics.
1364 -- Preconditions and case guards of contract cases are checked before
1365 -- the protected action or rendezvous takes place. Postconditions and
1366 -- consequences of contract cases are checked after the protected action
1367 -- or rendezvous takes place. The structure of the generated wrapper is
1370 -- procedure Wrapper
1371 -- (Obj_Id : Conc_Typ; -- concurrent object
1372 -- [Index : Index_Typ;] -- index of entry family
1373 -- [Formal_1 : ...; -- parameters of original entry
1376 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1377 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1379 -- <precondition checks>
1380 -- <case guard checks>
1382 -- procedure _Postconditions is
1384 -- <postcondition checks>
1385 -- <consequence checks>
1386 -- end _Postconditions;
1389 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1393 -- Create the wrapper only when the entry has at least one executable
1394 -- contract item such as contract cases, precondition or postcondition.
1396 if Present (Items) then
1398 -- Inspect the list of pre/postconditions and transfer all available
1399 -- pragmas to the declarative list of the wrapper.
1401 Prag := Pre_Post_Conditions (Items);
1402 while Present (Prag) loop
1403 if Nam_In (Pragma_Name_Unmapped (Prag),
1404 Name_Postcondition, Name_Precondition)
1405 and then Is_Checked (Prag)
1408 Transfer_Pragma (Prag, To => Decls);
1411 Prag := Next_Pragma (Prag);
1414 -- Inspect the list of test/contract cases and transfer only contract
1415 -- cases pragmas to the declarative part of the wrapper.
1417 Prag := Contract_Test_Cases (Items);
1418 while Present (Prag) loop
1419 if Pragma_Name (Prag) = Name_Contract_Cases
1420 and then Is_Checked (Prag)
1423 Transfer_Pragma (Prag, To => Decls);
1426 Prag := Next_Pragma (Prag);
1430 -- The entry lacks executable contract items and a wrapper is not needed
1432 if not Has_Pragma then
1436 -- Create the profile of the wrapper. The first formal parameter is the
1437 -- concurrent object.
1440 Make_Defining_Identifier (Loc,
1441 Chars => New_External_Name (Chars (Conc_Typ), 'A'));
1443 Formals := New_List (
1444 Make_Parameter_Specification (Loc,
1445 Defining_Identifier => Obj_Id,
1446 Out_Present => True,
1448 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc)));
1450 -- Construct the call to the original entry. The call will be gradually
1451 -- augmented with an optional entry index and extra parameters.
1454 Make_Selected_Component (Loc,
1455 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1456 Selector_Name => New_Occurrence_Of (E, Loc));
1458 -- When creating a wrapper for an entry family, the second formal is the
1461 if Ekind (E) = E_Entry_Family then
1462 Index_Id := Make_Defining_Identifier (Loc, Name_I);
1465 Make_Parameter_Specification (Loc,
1466 Defining_Identifier => Index_Id,
1468 New_Occurrence_Of (Entry_Index_Type (E), Loc)));
1470 -- The call to the original entry becomes an indexed component to
1471 -- accommodate the entry index.
1474 Make_Indexed_Component (Loc,
1476 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc)));
1479 -- Add formal parameters to match those of the entry and build actuals
1480 -- for the entry call.
1482 Add_Matching_Formals (Formals, Actuals);
1485 Make_Procedure_Call_Statement (Loc,
1487 Parameter_Associations => Actuals);
1489 -- Add renaming declarations for the discriminants of the enclosing type
1490 -- as the various contract items may reference them.
1492 Add_Discriminant_Renamings (Obj_Id, Decls);
1495 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E'));
1496 Set_Contract_Wrapper (E, Wrapper_Id);
1497 Set_Is_Entry_Wrapper (Wrapper_Id);
1499 -- The wrapper body is analyzed when the enclosing type is frozen
1501 Append_Freeze_Action (Defining_Entity (Decl),
1502 Make_Subprogram_Body (Loc,
1504 Make_Procedure_Specification (Loc,
1505 Defining_Unit_Name => Wrapper_Id,
1506 Parameter_Specifications => Formals),
1507 Declarations => Decls,
1508 Handled_Statement_Sequence =>
1509 Make_Handled_Sequence_Of_Statements (Loc,
1510 Statements => New_List (Call))));
1511 end Build_Contract_Wrapper;
1513 --------------------------------
1514 -- Build_Corresponding_Record --
1515 --------------------------------
1517 function Build_Corresponding_Record
1520 Loc : Source_Ptr) return Node_Id
1522 Rec_Ent : constant Entity_Id :=
1523 Make_Defining_Identifier
1524 (Loc, New_External_Name (Chars (Ctyp), 'V'));
1527 New_Disc : Entity_Id;
1531 Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
1532 Set_Ekind (Rec_Ent, E_Record_Type);
1533 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
1534 Set_Is_Concurrent_Record_Type (Rec_Ent, True);
1535 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
1536 Set_Stored_Constraint (Rec_Ent, No_Elist);
1539 -- Use discriminals to create list of discriminants for record, and
1540 -- create new discriminals for use in default expressions, etc. It is
1541 -- worth noting that a task discriminant gives rise to 5 entities;
1543 -- a) The original discriminant.
1544 -- b) The discriminal for use in the task.
1545 -- c) The discriminant of the corresponding record.
1546 -- d) The discriminal for the init proc of the corresponding record.
1547 -- e) The local variable that renames the discriminant in the procedure
1548 -- for the task body.
1550 -- In fact the discriminals b) are used in the renaming declarations
1551 -- for e). See details in einfo (Handling of Discriminants).
1553 if Present (Discriminant_Specifications (N)) then
1555 Disc := First_Discriminant (Ctyp);
1557 while Present (Disc) loop
1558 New_Disc := CR_Discriminant (Disc);
1561 Make_Discriminant_Specification (Loc,
1562 Defining_Identifier => New_Disc,
1563 Discriminant_Type =>
1564 New_Occurrence_Of (Etype (Disc), Loc),
1566 New_Copy (Discriminant_Default_Value (Disc))));
1568 Next_Discriminant (Disc);
1575 -- Now we can construct the record type declaration. Note that this
1576 -- record is "limited tagged". It is "limited" to reflect the underlying
1577 -- limitedness of the task or protected object that it represents, and
1578 -- ensuring for example that it is properly passed by reference. It is
1579 -- "tagged" to give support to dispatching calls through interfaces. We
1580 -- propagate here the list of interfaces covered by the concurrent type
1581 -- (Ada 2005: AI-345).
1584 Make_Full_Type_Declaration (Loc,
1585 Defining_Identifier => Rec_Ent,
1586 Discriminant_Specifications => Dlist,
1588 Make_Record_Definition (Loc,
1590 Make_Component_List (Loc, Component_Items => Cdecls),
1592 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp),
1593 Interface_List => Interface_List (N),
1594 Limited_Present => True));
1595 end Build_Corresponding_Record;
1597 ---------------------------------
1598 -- Build_Dispatching_Tag_Check --
1599 ---------------------------------
1601 function Build_Dispatching_Tag_Check
1603 N : Node_Id) return Node_Id
1605 Loc : constant Source_Ptr := Sloc (N);
1612 New_Occurrence_Of (K, Loc),
1614 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)),
1618 New_Occurrence_Of (K, Loc),
1620 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc)));
1621 end Build_Dispatching_Tag_Check;
1623 ----------------------------------
1624 -- Build_Entry_Count_Expression --
1625 ----------------------------------
1627 function Build_Entry_Count_Expression
1628 (Concurrent_Type : Node_Id;
1629 Component_List : List_Id;
1630 Loc : Source_Ptr) return Node_Id
1642 -- Count number of non-family entries
1645 Ent := First_Entity (Concurrent_Type);
1646 while Present (Ent) loop
1647 if Ekind (Ent) = E_Entry then
1654 Ecount := Make_Integer_Literal (Loc, Eindx);
1656 -- Loop through entry families building the addition nodes
1658 Ent := First_Entity (Concurrent_Type);
1659 Comp := First (Component_List);
1660 while Present (Ent) loop
1661 if Ekind (Ent) = E_Entry_Family then
1662 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
1666 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1667 Hi := Type_High_Bound (Typ);
1668 Lo := Type_Low_Bound (Typ);
1669 Large := Is_Potentially_Large_Family
1670 (Base_Type (Typ), Concurrent_Type, Lo, Hi);
1673 Left_Opnd => Ecount,
1675 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large));
1682 end Build_Entry_Count_Expression;
1684 ---------------------------
1685 -- Build_Parameter_Block --
1686 ---------------------------
1688 function Build_Parameter_Block
1692 Decls : List_Id) return Entity_Id
1698 Has_Comp : Boolean := False;
1702 Actual := First (Actuals);
1704 Formal := Defining_Identifier (First (Formals));
1706 while Present (Actual) loop
1707 if not Is_Controlling_Actual (Actual) then
1710 -- type Ann is access all <actual-type>
1712 Comp_Nam := Make_Temporary (Loc, 'A');
1713 Set_Is_Param_Block_Component_Type (Comp_Nam);
1716 Make_Full_Type_Declaration (Loc,
1717 Defining_Identifier => Comp_Nam,
1719 Make_Access_To_Object_Definition (Loc,
1720 All_Present => True,
1721 Constant_Present => Ekind (Formal) = E_In_Parameter,
1722 Subtype_Indication =>
1723 New_Occurrence_Of (Etype (Actual), Loc))));
1729 Make_Component_Declaration (Loc,
1730 Defining_Identifier =>
1731 Make_Defining_Identifier (Loc, Chars (Formal)),
1732 Component_Definition =>
1733 Make_Component_Definition (Loc,
1736 Subtype_Indication =>
1737 New_Occurrence_Of (Comp_Nam, Loc))));
1742 Next_Actual (Actual);
1743 Next_Formal_With_Extras (Formal);
1746 Rec_Nam := Make_Temporary (Loc, 'P');
1751 -- type Pnn is record
1756 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1757 -- the original parameter names and Ann1 .. AnnN are the access to
1761 Make_Full_Type_Declaration (Loc,
1762 Defining_Identifier =>
1765 Make_Record_Definition (Loc,
1767 Make_Component_List (Loc, Comps))));
1770 -- type Pnn is null record;
1773 Make_Full_Type_Declaration (Loc,
1774 Defining_Identifier =>
1777 Make_Record_Definition (Loc,
1778 Null_Present => True,
1779 Component_List => Empty)));
1783 end Build_Parameter_Block;
1785 --------------------------------------
1786 -- Build_Renamed_Formal_Declaration --
1787 --------------------------------------
1789 function Build_Renamed_Formal_Declaration
1793 Renamed_Formal : Node_Id) return Node_Id
1795 Loc : constant Source_Ptr := Sloc (New_F);
1799 -- If the formal is a tagged incomplete type, it is already passed
1800 -- by reference, so it is sufficient to rename the pointer component
1801 -- that corresponds to the actual. Otherwise we need to dereference
1802 -- the pointer component to obtain the actual.
1804 if Is_Incomplete_Type (Etype (Formal))
1805 and then Is_Tagged_Type (Etype (Formal))
1808 Make_Object_Renaming_Declaration (Loc,
1809 Defining_Identifier => New_F,
1810 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc),
1811 Name => Renamed_Formal);
1815 Make_Object_Renaming_Declaration (Loc,
1816 Defining_Identifier => New_F,
1817 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc),
1819 Make_Explicit_Dereference (Loc, Renamed_Formal));
1823 end Build_Renamed_Formal_Declaration;
1825 --------------------------
1826 -- Build_Wrapper_Bodies --
1827 --------------------------
1829 procedure Build_Wrapper_Bodies
1834 Rec_Typ : Entity_Id;
1836 function Build_Wrapper_Body
1838 Subp_Id : Entity_Id;
1839 Obj_Typ : Entity_Id;
1840 Formals : List_Id) return Node_Id;
1841 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1842 -- associated with a protected or task type. Subp_Id is the subprogram
1843 -- name which will be wrapped. Obj_Typ is the type of the new formal
1844 -- parameter which handles dispatching and object notation. Formals are
1845 -- the original formals of Subp_Id which will be explicitly replicated.
1847 ------------------------
1848 -- Build_Wrapper_Body --
1849 ------------------------
1851 function Build_Wrapper_Body
1853 Subp_Id : Entity_Id;
1854 Obj_Typ : Entity_Id;
1855 Formals : List_Id) return Node_Id
1857 Body_Spec : Node_Id;
1860 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals);
1862 -- The subprogram is not overriding or is not a primitive declared
1863 -- between two views.
1865 if No (Body_Spec) then
1870 Actuals : List_Id := No_List;
1872 First_Form : Node_Id;
1877 -- Map formals to actuals. Use the list built for the wrapper
1878 -- spec, skipping the object notation parameter.
1880 First_Form := First (Parameter_Specifications (Body_Spec));
1882 Formal := First_Form;
1885 if Present (Formal) then
1886 Actuals := New_List;
1887 while Present (Formal) loop
1889 Make_Identifier (Loc,
1890 Chars => Chars (Defining_Identifier (Formal))));
1895 -- Special processing for primitives declared between a private
1896 -- type and its completion: the wrapper needs a properly typed
1897 -- parameter if the wrapped operation has a controlling first
1898 -- parameter. Note that this might not be the case for a function
1899 -- with a controlling result.
1901 if Is_Private_Primitive_Subprogram (Subp_Id) then
1902 if No (Actuals) then
1903 Actuals := New_List;
1906 if Is_Controlling_Formal (First_Formal (Subp_Id)) then
1907 Prepend_To (Actuals,
1908 Unchecked_Convert_To
1909 (Corresponding_Concurrent_Type (Obj_Typ),
1910 Make_Identifier (Loc, Name_uO)));
1913 Prepend_To (Actuals,
1914 Make_Identifier (Loc,
1915 Chars => Chars (Defining_Identifier (First_Form))));
1918 Nam := New_Occurrence_Of (Subp_Id, Loc);
1920 -- An access-to-variable object parameter requires an explicit
1921 -- dereference in the unchecked conversion. This case occurs
1922 -- when a protected entry wrapper must override an interface
1923 -- level procedure with interface access as first parameter.
1925 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1927 if Nkind (Parameter_Type (First_Form)) =
1931 Make_Explicit_Dereference (Loc,
1932 Prefix => Make_Identifier (Loc, Name_uO));
1934 Conv_Id := Make_Identifier (Loc, Name_uO);
1938 Make_Selected_Component (Loc,
1940 Unchecked_Convert_To
1941 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id),
1942 Selector_Name => New_Occurrence_Of (Subp_Id, Loc));
1945 -- Create the subprogram body. For a function, the call to the
1946 -- actual subprogram has to be converted to the corresponding
1947 -- record if it is a controlling result.
1949 if Ekind (Subp_Id) = E_Function then
1955 Make_Function_Call (Loc,
1957 Parameter_Associations => Actuals);
1959 if Has_Controlling_Result (Subp_Id) then
1961 Unchecked_Convert_To
1962 (Corresponding_Record_Type (Etype (Subp_Id)), Res);
1966 Make_Subprogram_Body (Loc,
1967 Specification => Body_Spec,
1968 Declarations => Empty_List,
1969 Handled_Statement_Sequence =>
1970 Make_Handled_Sequence_Of_Statements (Loc,
1971 Statements => New_List (
1972 Make_Simple_Return_Statement (Loc, Res))));
1977 Make_Subprogram_Body (Loc,
1978 Specification => Body_Spec,
1979 Declarations => Empty_List,
1980 Handled_Statement_Sequence =>
1981 Make_Handled_Sequence_Of_Statements (Loc,
1982 Statements => New_List (
1983 Make_Procedure_Call_Statement (Loc,
1985 Parameter_Associations => Actuals))));
1988 end Build_Wrapper_Body;
1990 -- Start of processing for Build_Wrapper_Bodies
1993 if Is_Concurrent_Type (Typ) then
1994 Rec_Typ := Corresponding_Record_Type (Typ);
1999 -- Generate wrapper bodies for a concurrent type which implements an
2002 if Present (Interfaces (Rec_Typ)) then
2004 Insert_Nod : Node_Id;
2006 Prim_Elmt : Elmt_Id;
2007 Prim_Decl : Node_Id;
2009 Wrap_Body : Node_Id;
2010 Wrap_Id : Entity_Id;
2015 -- Examine all primitive operations of the corresponding record
2016 -- type, looking for wrapper specs. Generate bodies in order to
2019 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ));
2020 while Present (Prim_Elmt) loop
2021 Prim := Node (Prim_Elmt);
2023 if (Ekind (Prim) = E_Function
2024 or else Ekind (Prim) = E_Procedure)
2025 and then Is_Primitive_Wrapper (Prim)
2027 Subp := Wrapped_Entity (Prim);
2028 Prim_Decl := Parent (Parent (Prim));
2031 Build_Wrapper_Body (Loc,
2034 Formals => Parameter_Specifications (Parent (Subp)));
2035 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body));
2037 Set_Corresponding_Spec (Wrap_Body, Prim);
2038 Set_Corresponding_Body (Prim_Decl, Wrap_Id);
2040 Insert_After (Insert_Nod, Wrap_Body);
2041 Insert_Nod := Wrap_Body;
2043 Analyze (Wrap_Body);
2046 Next_Elmt (Prim_Elmt);
2050 end Build_Wrapper_Bodies;
2052 ------------------------
2053 -- Build_Wrapper_Spec --
2054 ------------------------
2056 function Build_Wrapper_Spec
2057 (Subp_Id : Entity_Id;
2058 Obj_Typ : Entity_Id;
2059 Formals : List_Id) return Node_Id
2061 function Overriding_Possible
2062 (Iface_Op : Entity_Id;
2063 Wrapper : Entity_Id) return Boolean;
2064 -- Determine whether a primitive operation can be overridden by Wrapper.
2065 -- Iface_Op is the candidate primitive operation of an interface type,
2066 -- Wrapper is the generated entry wrapper.
2068 function Replicate_Formals
2070 Formals : List_Id) return List_Id;
2071 -- An explicit parameter replication is required due to the Is_Entry_
2072 -- Formal flag being set for all the formals of an entry. The explicit
2073 -- replication removes the flag that would otherwise cause a different
2074 -- path of analysis.
2076 -------------------------
2077 -- Overriding_Possible --
2078 -------------------------
2080 function Overriding_Possible
2081 (Iface_Op : Entity_Id;
2082 Wrapper : Entity_Id) return Boolean
2084 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op);
2085 Wrapper_Spec : constant Node_Id := Parent (Wrapper);
2087 function Type_Conformant_Parameters
2088 (Iface_Op_Params : List_Id;
2089 Wrapper_Params : List_Id) return Boolean;
2090 -- Determine whether the parameters of the generated entry wrapper
2091 -- and those of a primitive operation are type conformant. During
2092 -- this check, the first parameter of the primitive operation is
2093 -- skipped if it is a controlling argument: protected functions
2094 -- may have a controlling result.
2096 --------------------------------
2097 -- Type_Conformant_Parameters --
2098 --------------------------------
2100 function Type_Conformant_Parameters
2101 (Iface_Op_Params : List_Id;
2102 Wrapper_Params : List_Id) return Boolean
2104 Iface_Op_Param : Node_Id;
2105 Iface_Op_Typ : Entity_Id;
2106 Wrapper_Param : Node_Id;
2107 Wrapper_Typ : Entity_Id;
2110 -- Skip the first (controlling) parameter of primitive operation
2112 Iface_Op_Param := First (Iface_Op_Params);
2114 if Present (First_Formal (Iface_Op))
2115 and then Is_Controlling_Formal (First_Formal (Iface_Op))
2117 Iface_Op_Param := Next (Iface_Op_Param);
2120 Wrapper_Param := First (Wrapper_Params);
2121 while Present (Iface_Op_Param)
2122 and then Present (Wrapper_Param)
2124 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param);
2125 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param);
2127 -- The two parameters must be mode conformant
2129 if not Conforming_Types
2130 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant)
2135 Next (Iface_Op_Param);
2136 Next (Wrapper_Param);
2139 -- One of the lists is longer than the other
2141 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then
2146 end Type_Conformant_Parameters;
2148 -- Start of processing for Overriding_Possible
2151 if Chars (Iface_Op) /= Chars (Wrapper) then
2155 -- If an inherited subprogram is implemented by a protected procedure
2156 -- or an entry, then the first parameter of the inherited subprogram
2157 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2159 if Ekind (Iface_Op) = E_Procedure
2160 and then Present (Parameter_Specifications (Iface_Op_Spec))
2163 Obj_Param : constant Node_Id :=
2164 First (Parameter_Specifications (Iface_Op_Spec));
2166 if not Out_Present (Obj_Param)
2167 and then Nkind (Parameter_Type (Obj_Param)) /=
2176 Type_Conformant_Parameters
2177 (Parameter_Specifications (Iface_Op_Spec),
2178 Parameter_Specifications (Wrapper_Spec));
2179 end Overriding_Possible;
2181 -----------------------
2182 -- Replicate_Formals --
2183 -----------------------
2185 function Replicate_Formals
2187 Formals : List_Id) return List_Id
2189 New_Formals : constant List_Id := New_List;
2191 Param_Type : Node_Id;
2194 Formal := First (Formals);
2196 -- Skip the object parameter when dealing with primitives declared
2197 -- between two views.
2199 if Is_Private_Primitive_Subprogram (Subp_Id)
2200 and then not Has_Controlling_Result (Subp_Id)
2202 Formal := Next (Formal);
2205 while Present (Formal) loop
2207 -- Create an explicit copy of the entry parameter
2209 -- When creating the wrapper subprogram for a primitive operation
2210 -- of a protected interface we must construct an equivalent
2211 -- signature to that of the overriding operation. For regular
2212 -- parameters we can just use the type of the formal, but for
2213 -- access to subprogram parameters we need to reanalyze the
2214 -- parameter type to create local entities for the signature of
2215 -- the subprogram type. Using the entities of the overriding
2216 -- subprogram will result in out-of-scope errors in the back-end.
2218 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then
2219 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal));
2222 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc);
2225 Append_To (New_Formals,
2226 Make_Parameter_Specification (Loc,
2227 Defining_Identifier =>
2228 Make_Defining_Identifier (Loc,
2229 Chars => Chars (Defining_Identifier (Formal))),
2230 In_Present => In_Present (Formal),
2231 Out_Present => Out_Present (Formal),
2232 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
2233 Parameter_Type => Param_Type));
2239 end Replicate_Formals;
2243 Loc : constant Source_Ptr := Sloc (Subp_Id);
2244 First_Param : Node_Id := Empty;
2246 Iface_Elmt : Elmt_Id;
2247 Iface_Op : Entity_Id;
2248 Iface_Op_Elmt : Elmt_Id;
2249 Overridden_Subp : Entity_Id;
2251 -- Start of processing for Build_Wrapper_Spec
2254 -- No point in building wrappers for untagged concurrent types
2256 pragma Assert (Is_Tagged_Type (Obj_Typ));
2258 -- Check if this subprogram has a profile that matches some interface
2261 Check_Synchronized_Overriding (Subp_Id, Overridden_Subp);
2263 if Present (Overridden_Subp) then
2265 First (Parameter_Specifications (Parent (Overridden_Subp)));
2267 -- An entry or a protected procedure can override a routine where the
2268 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2269 -- type. Since the wrapper must have the exact same signature as that of
2270 -- the overridden subprogram, we try to find the overriding candidate
2271 -- and use its controlling formal.
2273 -- Check every implemented interface
2275 elsif Present (Interfaces (Obj_Typ)) then
2276 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
2277 Search : while Present (Iface_Elmt) loop
2278 Iface := Node (Iface_Elmt);
2280 -- Check every interface primitive
2282 if Present (Primitive_Operations (Iface)) then
2283 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
2284 while Present (Iface_Op_Elmt) loop
2285 Iface_Op := Node (Iface_Op_Elmt);
2287 -- Ignore predefined primitives
2289 if not Is_Predefined_Dispatching_Operation (Iface_Op) then
2290 Iface_Op := Ultimate_Alias (Iface_Op);
2292 -- The current primitive operation can be overridden by
2293 -- the generated entry wrapper.
2295 if Overriding_Possible (Iface_Op, Subp_Id) then
2297 First (Parameter_Specifications (Parent (Iface_Op)));
2303 Next_Elmt (Iface_Op_Elmt);
2307 Next_Elmt (Iface_Elmt);
2311 -- Do not generate the wrapper if no interface primitive is covered by
2312 -- the subprogram and it is not a primitive declared between two views
2313 -- (see Process_Full_View).
2316 and then not Is_Private_Primitive_Subprogram (Subp_Id)
2322 Wrapper_Id : constant Entity_Id :=
2323 Make_Defining_Identifier (Loc, Chars (Subp_Id));
2324 New_Formals : List_Id;
2325 Obj_Param : Node_Id;
2326 Obj_Param_Typ : Entity_Id;
2329 -- Minimum decoration is needed to catch the entity in
2330 -- Sem_Ch6.Override_Dispatching_Operation.
2332 if Ekind (Subp_Id) = E_Function then
2333 Set_Ekind (Wrapper_Id, E_Function);
2335 Set_Ekind (Wrapper_Id, E_Procedure);
2338 Set_Is_Primitive_Wrapper (Wrapper_Id);
2339 Set_Wrapped_Entity (Wrapper_Id, Subp_Id);
2340 Set_Is_Private_Primitive (Wrapper_Id,
2341 Is_Private_Primitive_Subprogram (Subp_Id));
2343 -- Process the formals
2345 New_Formals := Replicate_Formals (Loc, Formals);
2347 -- A function with a controlling result and no first controlling
2348 -- formal needs no additional parameter.
2350 if Has_Controlling_Result (Subp_Id)
2352 (No (First_Formal (Subp_Id))
2353 or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
2357 -- Routine Subp_Id has been found to override an interface primitive.
2358 -- If the interface operation has an access parameter, create a copy
2359 -- of it, with the same null exclusion indicator if present.
2361 elsif Present (First_Param) then
2362 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
2364 Make_Access_Definition (Loc,
2366 New_Occurrence_Of (Obj_Typ, Loc),
2367 Null_Exclusion_Present =>
2368 Null_Exclusion_Present (Parameter_Type (First_Param)),
2370 Constant_Present (Parameter_Type (First_Param)));
2372 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc);
2376 Make_Parameter_Specification (Loc,
2377 Defining_Identifier =>
2378 Make_Defining_Identifier (Loc,
2380 In_Present => In_Present (First_Param),
2381 Out_Present => Out_Present (First_Param),
2382 Parameter_Type => Obj_Param_Typ);
2384 Prepend_To (New_Formals, Obj_Param);
2386 -- If we are dealing with a primitive declared between two views,
2387 -- implemented by a synchronized operation, we need to create
2388 -- a default parameter. The mode of the parameter must match that
2389 -- of the primitive operation.
2392 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
2395 Make_Parameter_Specification (Loc,
2396 Defining_Identifier =>
2397 Make_Defining_Identifier (Loc, Name_uO),
2399 In_Present (Parent (First_Entity (Subp_Id))),
2400 Out_Present => Ekind (Subp_Id) /= E_Function,
2401 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
2403 Prepend_To (New_Formals, Obj_Param);
2406 -- Build the final spec. If it is a function with a controlling
2407 -- result, it is a primitive operation of the corresponding
2408 -- record type, so mark the spec accordingly.
2410 if Ekind (Subp_Id) = E_Function then
2415 if Has_Controlling_Result (Subp_Id) then
2418 (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
2420 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
2424 Make_Function_Specification (Loc,
2425 Defining_Unit_Name => Wrapper_Id,
2426 Parameter_Specifications => New_Formals,
2427 Result_Definition => Res_Def);
2431 Make_Procedure_Specification (Loc,
2432 Defining_Unit_Name => Wrapper_Id,
2433 Parameter_Specifications => New_Formals);
2436 end Build_Wrapper_Spec;
2438 -------------------------
2439 -- Build_Wrapper_Specs --
2440 -------------------------
2442 procedure Build_Wrapper_Specs
2448 Rec_Typ : Entity_Id;
2449 procedure Scan_Declarations (L : List_Id);
2450 -- Common processing for visible and private declarations
2451 -- of a protected type.
2453 procedure Scan_Declarations (L : List_Id) is
2455 Wrap_Decl : Node_Id;
2456 Wrap_Spec : Node_Id;
2464 while Present (Decl) loop
2467 if Nkind (Decl) = N_Entry_Declaration
2468 and then Ekind (Defining_Identifier (Decl)) = E_Entry
2472 (Subp_Id => Defining_Identifier (Decl),
2474 Formals => Parameter_Specifications (Decl));
2476 elsif Nkind (Decl) = N_Subprogram_Declaration then
2479 (Subp_Id => Defining_Unit_Name (Specification (Decl)),
2482 Parameter_Specifications (Specification (Decl)));
2485 if Present (Wrap_Spec) then
2487 Make_Subprogram_Declaration (Loc,
2488 Specification => Wrap_Spec);
2490 Insert_After (N, Wrap_Decl);
2493 Analyze (Wrap_Decl);
2498 end Scan_Declarations;
2500 -- start of processing for Build_Wrapper_Specs
2503 if Is_Protected_Type (Typ) then
2504 Def := Protected_Definition (Parent (Typ));
2505 else pragma Assert (Is_Task_Type (Typ));
2506 Def := Task_Definition (Parent (Typ));
2509 Rec_Typ := Corresponding_Record_Type (Typ);
2511 -- Generate wrapper specs for a concurrent type which implements an
2512 -- interface. Operations in both the visible and private parts may
2513 -- implement progenitor operations.
2515 if Present (Interfaces (Rec_Typ)) and then Present (Def) then
2516 Scan_Declarations (Visible_Declarations (Def));
2517 Scan_Declarations (Private_Declarations (Def));
2519 end Build_Wrapper_Specs;
2521 ---------------------------
2522 -- Build_Find_Body_Index --
2523 ---------------------------
2525 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
2526 Loc : constant Source_Ptr := Sloc (Typ);
2529 Has_F : Boolean := False;
2531 If_St : Node_Id := Empty;
2534 Decls : List_Id := New_List;
2537 Siz : Node_Id := Empty;
2539 procedure Add_If_Clause (Expr : Node_Id);
2540 -- Add test for range of current entry
2542 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
2543 -- If a bound of an entry is given by a discriminant, retrieve the
2544 -- actual value of the discriminant from the enclosing object.
2550 procedure Add_If_Clause (Expr : Node_Id) is
2552 Stats : constant List_Id :=
2554 Make_Simple_Return_Statement (Loc,
2555 Expression => Make_Integer_Literal (Loc, Index + 1)));
2558 -- Index for current entry body
2562 -- Compute total length of entry queues so far
2570 Right_Opnd => Expr);
2575 Left_Opnd => Make_Identifier (Loc, Name_uE),
2578 -- Map entry queue indexes in the range of the current family
2579 -- into the current index, that designates the entry body.
2583 Make_Implicit_If_Statement (Typ,
2585 Then_Statements => Stats,
2586 Elsif_Parts => New_List);
2590 Append_To (Elsif_Parts (If_St),
2591 Make_Elsif_Part (Loc,
2593 Then_Statements => Stats));
2597 ------------------------------
2598 -- Convert_Discriminant_Ref --
2599 ------------------------------
2601 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
2605 if Is_Entity_Name (Bound)
2606 and then Ekind (Entity (Bound)) = E_Discriminant
2609 Make_Selected_Component (Loc,
2611 Unchecked_Convert_To (Corresponding_Record_Type (Typ),
2612 Make_Explicit_Dereference (Loc,
2613 Make_Identifier (Loc, Name_uObject))),
2614 Selector_Name => Make_Identifier (Loc, Chars (Bound)));
2615 Set_Etype (B, Etype (Entity (Bound)));
2617 B := New_Copy_Tree (Bound);
2621 end Convert_Discriminant_Ref;
2623 -- Start of processing for Build_Find_Body_Index
2626 Spec := Build_Find_Body_Index_Spec (Typ);
2628 Ent := First_Entity (Typ);
2629 while Present (Ent) loop
2630 if Ekind (Ent) = E_Entry_Family then
2640 -- If the protected type has no entry families, there is a one-one
2641 -- correspondence between entry queue and entry body.
2644 Make_Simple_Return_Statement (Loc,
2645 Expression => Make_Identifier (Loc, Name_uE));
2648 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2651 -- if E <= l1 then return 1;
2652 -- elsif E <= l1 + l2 then return 2;
2657 Ent := First_Entity (Typ);
2659 Add_Object_Pointer (Loc, Typ, Decls);
2661 while Present (Ent) loop
2662 if Ekind (Ent) = E_Entry then
2663 Add_If_Clause (Make_Integer_Literal (Loc, 1));
2665 elsif Ekind (Ent) = E_Entry_Family then
2666 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
2667 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
2668 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
2669 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
2678 Make_Simple_Return_Statement (Loc,
2679 Expression => Make_Integer_Literal (Loc, 1));
2681 elsif Nkind (Ret) = N_If_Statement then
2683 -- Ranges are in increasing order, so last one doesn't need guard
2686 Nod : constant Node_Id := Last (Elsif_Parts (Ret));
2689 Set_Else_Statements (Ret, Then_Statements (Nod));
2695 Make_Subprogram_Body (Loc,
2696 Specification => Spec,
2697 Declarations => Decls,
2698 Handled_Statement_Sequence =>
2699 Make_Handled_Sequence_Of_Statements (Loc,
2700 Statements => New_List (Ret)));
2701 end Build_Find_Body_Index;
2703 --------------------------------
2704 -- Build_Find_Body_Index_Spec --
2705 --------------------------------
2707 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
2708 Loc : constant Source_Ptr := Sloc (Typ);
2709 Id : constant Entity_Id :=
2710 Make_Defining_Identifier (Loc,
2711 Chars => New_External_Name (Chars (Typ), 'F'));
2712 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
2713 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
2717 Make_Function_Specification (Loc,
2718 Defining_Unit_Name => Id,
2719 Parameter_Specifications => New_List (
2720 Make_Parameter_Specification (Loc,
2721 Defining_Identifier => Parm1,
2723 New_Occurrence_Of (RTE (RE_Address), Loc)),
2725 Make_Parameter_Specification (Loc,
2726 Defining_Identifier => Parm2,
2728 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
2730 Result_Definition => New_Occurrence_Of (
2731 RTE (RE_Protected_Entry_Index), Loc));
2732 end Build_Find_Body_Index_Spec;
2734 -----------------------------------------------
2735 -- Build_Lock_Free_Protected_Subprogram_Body --
2736 -----------------------------------------------
2738 function Build_Lock_Free_Protected_Subprogram_Body
2741 Unprot_Spec : Node_Id) return Node_Id
2743 Actuals : constant List_Id := New_List;
2744 Loc : constant Source_Ptr := Sloc (N);
2745 Spec : constant Node_Id := Specification (N);
2746 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec);
2748 Prot_Spec : Node_Id;
2752 -- Create the protected version of the body
2755 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode);
2757 -- Build the actual parameters which appear in the call to the
2758 -- unprotected version of the body.
2760 Formal := First (Parameter_Specifications (Prot_Spec));
2761 while Present (Formal) loop
2763 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
2768 -- Function case, generate:
2769 -- return <Unprot_Func_Call>;
2771 if Nkind (Spec) = N_Function_Specification then
2773 Make_Simple_Return_Statement (Loc,
2775 Make_Function_Call (Loc,
2777 Make_Identifier (Loc, Chars (Unprot_Id)),
2778 Parameter_Associations => Actuals));
2780 -- Procedure case, call the unprotected version
2784 Make_Procedure_Call_Statement (Loc,
2786 Make_Identifier (Loc, Chars (Unprot_Id)),
2787 Parameter_Associations => Actuals);
2791 Make_Subprogram_Body (Loc,
2792 Declarations => Empty_List,
2793 Specification => Prot_Spec,
2794 Handled_Statement_Sequence =>
2795 Make_Handled_Sequence_Of_Statements (Loc,
2796 Statements => New_List (Stmt)));
2797 end Build_Lock_Free_Protected_Subprogram_Body;
2799 -------------------------------------------------
2800 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2801 -------------------------------------------------
2803 -- Procedures which meet the lock-free implementation requirements and
2804 -- reference a unique scalar component Comp are expanded in the following
2807 -- procedure P (...) is
2808 -- Expected_Comp : constant Comp_Type :=
2810 -- (System.Atomic_Primitives.Lock_Free_Read_N
2811 -- (_Object.Comp'Address));
2815 -- <original declarations before the object renaming declaration
2818 -- Desired_Comp : Comp_Type := Expected_Comp;
2819 -- Comp : Comp_Type renames Desired_Comp;
2821 -- <original delarations after the object renaming declaration
2825 -- <original statements>
2826 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2827 -- (_Object.Comp'Address,
2828 -- Interfaces.Unsigned_N (Expected_Comp),
2829 -- Interfaces.Unsigned_N (Desired_Comp));
2834 -- Each return and raise statement of P is transformed into an atomic
2837 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2838 -- (_Object.Comp'Address,
2839 -- Interfaces.Unsigned_N (Expected_Comp),
2840 -- Interfaces.Unsigned_N (Desired_Comp));
2842 -- <original statement>
2847 -- Functions which meet the lock-free implementation requirements and
2848 -- reference a unique scalar component Comp are expanded in the following
2851 -- function F (...) return ... is
2852 -- <original declarations before the object renaming declaration
2855 -- Expected_Comp : constant Comp_Type :=
2857 -- (System.Atomic_Primitives.Lock_Free_Read_N
2858 -- (_Object.Comp'Address));
2859 -- Comp : Comp_Type renames Expected_Comp;
2861 -- <original delarations after the object renaming declaration of
2865 -- <original statements>
2868 function Build_Lock_Free_Unprotected_Subprogram_Body
2870 Prot_Typ : Node_Id) return Node_Id
2872 function Referenced_Component (N : Node_Id) return Entity_Id;
2873 -- Subprograms which meet the lock-free implementation criteria are
2874 -- allowed to reference only one unique component. Return the prival
2875 -- of the said component.
2877 --------------------------
2878 -- Referenced_Component --
2879 --------------------------
2881 function Referenced_Component (N : Node_Id) return Entity_Id is
2884 Source_Comp : Entity_Id := Empty;
2887 -- Find the unique source component which N references in its
2890 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop
2892 Element : Lock_Free_Subprogram renames
2893 Lock_Free_Subprogram_Table.Table (Index);
2895 if Element.Sub_Body = N then
2896 Source_Comp := Element.Comp_Id;
2902 if No (Source_Comp) then
2906 -- Find the prival which corresponds to the source component within
2907 -- the declarations of N.
2909 Decl := First (Declarations (N));
2910 while Present (Decl) loop
2912 -- Privals appear as object renamings
2914 if Nkind (Decl) = N_Object_Renaming_Declaration then
2915 Comp := Defining_Identifier (Decl);
2917 if Present (Prival_Link (Comp))
2918 and then Prival_Link (Comp) = Source_Comp
2928 end Referenced_Component;
2932 Comp : constant Entity_Id := Referenced_Component (N);
2933 Loc : constant Source_Ptr := Sloc (N);
2934 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N);
2935 Decls : List_Id := Declarations (N);
2937 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
2940 -- Add renamings for the protection object, discriminals, privals, and
2941 -- the entry index constant for use by debugger.
2943 Debug_Private_Data_Declarations (Decls);
2945 -- Perform the lock-free expansion when the subprogram references a
2946 -- protected component.
2948 if Present (Comp) then
2949 Protected_Component_Ref : declare
2950 Comp_Decl : constant Node_Id := Parent (Comp);
2951 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl);
2952 Comp_Type : constant Entity_Id := Etype (Comp);
2954 Is_Procedure : constant Boolean :=
2955 Ekind (Corresponding_Spec (N)) = E_Procedure;
2956 -- Indicates if N is a protected procedure body
2958 Block_Decls : List_Id;
2959 Try_Write : Entity_Id;
2960 Desired_Comp : Entity_Id;
2963 Label_Id : Entity_Id := Empty;
2965 Expected_Comp : Entity_Id;
2968 New_Copy_List (Statements (Hand_Stmt_Seq));
2970 Unsigned : Entity_Id;
2972 function Process_Node (N : Node_Id) return Traverse_Result;
2973 -- Transform a single node if it is a return statement, a raise
2974 -- statement or a reference to Comp.
2976 procedure Process_Stmts (Stmts : List_Id);
2977 -- Given a statement sequence Stmts, wrap any return or raise
2978 -- statements in the following manner:
2980 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2981 -- (_Object.Comp'Address,
2982 -- Interfaces.Unsigned_N (Expected_Comp),
2983 -- Interfaces.Unsigned_N (Desired_Comp))
2994 function Process_Node (N : Node_Id) return Traverse_Result is
2996 procedure Wrap_Statement (Stmt : Node_Id);
2997 -- Wrap an arbitrary statement inside an if statement where the
2998 -- condition does an atomic check on the state of the object.
3000 --------------------
3001 -- Wrap_Statement --
3002 --------------------
3004 procedure Wrap_Statement (Stmt : Node_Id) is
3006 -- The first time through, create the declaration of a label
3007 -- which is used to skip the remainder of source statements
3008 -- if the state of the object has changed.
3010 if No (Label_Id) then
3012 Make_Identifier (Loc, New_External_Name ('L', 0));
3013 Set_Entity (Label_Id,
3014 Make_Defining_Identifier (Loc, Chars (Label_Id)));
3018 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3019 -- (_Object.Comp'Address,
3020 -- Interfaces.Unsigned_N (Expected_Comp),
3021 -- Interfaces.Unsigned_N (Desired_Comp))
3029 Make_Implicit_If_Statement (N,
3031 Make_Function_Call (Loc,
3033 New_Occurrence_Of (Try_Write, Loc),
3034 Parameter_Associations => New_List (
3035 Make_Attribute_Reference (Loc,
3036 Prefix => Relocate_Node (Comp_Sel_Nam),
3037 Attribute_Name => Name_Address),
3039 Unchecked_Convert_To (Unsigned,
3040 New_Occurrence_Of (Expected_Comp, Loc)),
3042 Unchecked_Convert_To (Unsigned,
3043 New_Occurrence_Of (Desired_Comp, Loc)))),
3045 Then_Statements => New_List (Relocate_Node (Stmt)),
3047 Else_Statements => New_List (
3048 Make_Goto_Statement (Loc,
3050 New_Occurrence_Of (Entity (Label_Id), Loc)))));
3053 -- Start of processing for Process_Node
3056 -- Wrap each return and raise statement that appear inside a
3057 -- procedure. Skip the last return statement which is added by
3058 -- default since it is transformed into an exit statement.
3061 and then ((Nkind (N) = N_Simple_Return_Statement
3062 and then N /= Last (Stmts))
3063 or else Nkind (N) = N_Extended_Return_Statement
3064 or else (Nkind_In (N, N_Raise_Constraint_Error,
3065 N_Raise_Program_Error,
3067 N_Raise_Storage_Error)
3068 and then Comes_From_Source (N)))
3076 Set_Analyzed (N, False);
3081 procedure Process_Nodes is new Traverse_Proc (Process_Node);
3087 procedure Process_Stmts (Stmts : List_Id) is
3090 Stmt := First (Stmts);
3091 while Present (Stmt) loop
3092 Process_Nodes (Stmt);
3097 -- Start of processing for Protected_Component_Ref
3100 -- Get the type size
3102 if Known_Static_Esize (Comp_Type) then
3103 Typ_Size := UI_To_Int (Esize (Comp_Type));
3105 -- If the Esize (Object_Size) is unknown at compile time, look at
3106 -- the RM_Size (Value_Size) since it may have been set by an
3107 -- explicit representation clause.
3109 elsif Known_Static_RM_Size (Comp_Type) then
3110 Typ_Size := UI_To_Int (RM_Size (Comp_Type));
3112 -- Should not happen since this has already been checked in
3113 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3116 raise Program_Error;
3119 -- Retrieve all relevant atomic routines and types
3123 Try_Write := RTE (RE_Lock_Free_Try_Write_8);
3124 Read := RTE (RE_Lock_Free_Read_8);
3125 Unsigned := RTE (RE_Uint8);
3128 Try_Write := RTE (RE_Lock_Free_Try_Write_16);
3129 Read := RTE (RE_Lock_Free_Read_16);
3130 Unsigned := RTE (RE_Uint16);
3133 Try_Write := RTE (RE_Lock_Free_Try_Write_32);
3134 Read := RTE (RE_Lock_Free_Read_32);
3135 Unsigned := RTE (RE_Uint32);
3138 Try_Write := RTE (RE_Lock_Free_Try_Write_64);
3139 Read := RTE (RE_Lock_Free_Read_64);
3140 Unsigned := RTE (RE_Uint64);
3143 raise Program_Error;
3147 -- Expected_Comp : constant Comp_Type :=
3149 -- (System.Atomic_Primitives.Lock_Free_Read_N
3150 -- (_Object.Comp'Address));
3153 Make_Defining_Identifier (Loc,
3154 New_External_Name (Chars (Comp), Suffix => "_saved"));
3157 Make_Object_Declaration (Loc,
3158 Defining_Identifier => Expected_Comp,
3159 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3160 Constant_Present => True,
3162 Unchecked_Convert_To (Comp_Type,
3163 Make_Function_Call (Loc,
3164 Name => New_Occurrence_Of (Read, Loc),
3165 Parameter_Associations => New_List (
3166 Make_Attribute_Reference (Loc,
3167 Prefix => Relocate_Node (Comp_Sel_Nam),
3168 Attribute_Name => Name_Address)))));
3170 -- Protected procedures
3172 if Is_Procedure then
3173 -- Move the original declarations inside the generated block
3175 Block_Decls := Decls;
3177 -- Reset the declarations list of the protected procedure to
3178 -- contain only Decl.
3180 Decls := New_List (Decl);
3183 -- Desired_Comp : Comp_Type := Expected_Comp;
3186 Make_Defining_Identifier (Loc,
3187 New_External_Name (Chars (Comp), Suffix => "_current"));
3189 -- Insert the declarations of Expected_Comp and Desired_Comp in
3190 -- the block declarations right before the renaming of the
3191 -- protected component.
3193 Insert_Before (Comp_Decl,
3194 Make_Object_Declaration (Loc,
3195 Defining_Identifier => Desired_Comp,
3196 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3198 New_Occurrence_Of (Expected_Comp, Loc)));
3200 -- Protected function
3203 Desired_Comp := Expected_Comp;
3205 -- Insert the declaration of Expected_Comp in the function
3206 -- declarations right before the renaming of the protected
3209 Insert_Before (Comp_Decl, Decl);
3212 -- Rewrite the protected component renaming declaration to be a
3213 -- renaming of Desired_Comp.
3216 -- Comp : Comp_Type renames Desired_Comp;
3219 Make_Object_Renaming_Declaration (Loc,
3220 Defining_Identifier =>
3221 Defining_Identifier (Comp_Decl),
3223 New_Occurrence_Of (Comp_Type, Loc),
3225 New_Occurrence_Of (Desired_Comp, Loc)));
3227 -- Wrap any return or raise statements in Stmts in same the manner
3228 -- described in Process_Stmts.
3230 Process_Stmts (Stmts);
3233 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3234 -- (_Object.Comp'Address,
3235 -- Interfaces.Unsigned_N (Expected_Comp),
3236 -- Interfaces.Unsigned_N (Desired_Comp))
3238 if Is_Procedure then
3240 Make_Exit_Statement (Loc,
3242 Make_Function_Call (Loc,
3244 New_Occurrence_Of (Try_Write, Loc),
3245 Parameter_Associations => New_List (
3246 Make_Attribute_Reference (Loc,
3247 Prefix => Relocate_Node (Comp_Sel_Nam),
3248 Attribute_Name => Name_Address),
3250 Unchecked_Convert_To (Unsigned,
3251 New_Occurrence_Of (Expected_Comp, Loc)),
3253 Unchecked_Convert_To (Unsigned,
3254 New_Occurrence_Of (Desired_Comp, Loc)))));
3256 -- Small optimization: transform the default return statement
3257 -- of a procedure into the atomic exit statement.
3259 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then
3260 Rewrite (Last (Stmts), Stmt);
3262 Append_To (Stmts, Stmt);
3266 -- Create the declaration of the label used to skip the rest of
3267 -- the source statements when the object state changes.
3269 if Present (Label_Id) then
3270 Label := Make_Label (Loc, Label_Id);
3272 Make_Implicit_Label_Declaration (Loc,
3273 Defining_Identifier => Entity (Label_Id),
3274 Label_Construct => Label));
3275 Append_To (Stmts, Label);
3287 if Is_Procedure then
3290 Make_Loop_Statement (Loc,
3291 Statements => New_List (
3292 Make_Block_Statement (Loc,
3293 Declarations => Block_Decls,
3294 Handled_Statement_Sequence =>
3295 Make_Handled_Sequence_Of_Statements (Loc,
3296 Statements => Stmts))),
3297 End_Label => Empty));
3301 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts);
3302 end Protected_Component_Ref;
3305 -- Make an unprotected version of the subprogram for use within the same
3306 -- object, with new name and extra parameter representing the object.
3309 Make_Subprogram_Body (Loc,
3311 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode),
3312 Declarations => Decls,
3313 Handled_Statement_Sequence => Hand_Stmt_Seq);
3314 end Build_Lock_Free_Unprotected_Subprogram_Body;
3316 -------------------------
3317 -- Build_Master_Entity --
3318 -------------------------
3320 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is
3321 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ);
3323 Context_Id : Entity_Id;
3329 if Is_Itype (Obj_Or_Typ) then
3330 Par := Associated_Node_For_Itype (Obj_Or_Typ);
3332 Par := Parent (Obj_Or_Typ);
3335 -- When creating a master for a record component which is either a task
3336 -- or access-to-task, the enclosing record is the master scope and the
3337 -- proper insertion point is the component list.
3339 if Is_Record_Type (Current_Scope) then
3341 Context_Id := Current_Scope;
3342 Decls := List_Containing (Context);
3344 -- Default case for object declarations and access types. Note that the
3345 -- context is updated to the nearest enclosing body, block, package, or
3346 -- return statement.
3349 Find_Enclosing_Context (Par, Context, Context_Id, Decls);
3352 -- Do not create a master if one already exists or there is no task
3355 if Has_Master_Entity (Context_Id)
3356 or else Restriction_Active (No_Task_Hierarchy)
3361 -- Create a master, generate:
3362 -- _Master : constant Master_Id := Current_Master.all;
3365 Make_Object_Declaration (Loc,
3366 Defining_Identifier =>
3367 Make_Defining_Identifier (Loc, Name_uMaster),
3368 Constant_Present => True,
3369 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
3371 Make_Explicit_Dereference (Loc,
3372 New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
3374 -- The master is inserted at the start of the declarative list of the
3377 Prepend_To (Decls, Decl);
3379 -- In certain cases where transient scopes are involved, the immediate
3380 -- scope is not always the proper master scope. Ensure that the master
3381 -- declaration and entity appear in the same context.
3383 if Context_Id /= Current_Scope then
3384 Push_Scope (Context_Id);
3391 -- Mark the enclosing scope and its associated construct as being task
3394 Set_Has_Master_Entity (Context_Id);
3396 while Present (Context)
3397 and then Nkind (Context) /= N_Compilation_Unit
3399 if Nkind_In (Context, N_Block_Statement,
3403 Set_Is_Task_Master (Context);
3406 elsif Nkind (Parent (Context)) = N_Subunit then
3407 Context := Corresponding_Stub (Parent (Context));
3410 Context := Parent (Context);
3412 end Build_Master_Entity;
3414 ---------------------------
3415 -- Build_Master_Renaming --
3416 ---------------------------
3418 procedure Build_Master_Renaming
3419 (Ptr_Typ : Entity_Id;
3420 Ins_Nod : Node_Id := Empty)
3422 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
3424 Master_Decl : Node_Id;
3425 Master_Id : Entity_Id;
3428 -- Nothing to do if there is no task hierarchy
3430 if Restriction_Active (No_Task_Hierarchy) then
3434 -- Determine the proper context to insert the master renaming
3436 if Present (Ins_Nod) then
3438 elsif Is_Itype (Ptr_Typ) then
3439 Context := Associated_Node_For_Itype (Ptr_Typ);
3441 Context := Parent (Ptr_Typ);
3445 -- <Ptr_Typ>M : Master_Id renames _Master;
3448 Make_Defining_Identifier (Loc,
3449 New_External_Name (Chars (Ptr_Typ), 'M'));
3452 Make_Object_Renaming_Declaration (Loc,
3453 Defining_Identifier => Master_Id,
3454 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
3455 Name => Make_Identifier (Loc, Name_uMaster));
3457 Insert_Action (Context, Master_Decl);
3459 -- The renamed master now services the access type
3461 Set_Master_Id (Ptr_Typ, Master_Id);
3462 end Build_Master_Renaming;
3464 -----------------------------------------
3465 -- Build_Private_Protected_Declaration --
3466 -----------------------------------------
3468 function Build_Private_Protected_Declaration
3469 (N : Node_Id) return Entity_Id
3471 Loc : constant Source_Ptr := Sloc (N);
3472 Body_Id : constant Entity_Id := Defining_Entity (N);
3477 Spec_Id : Entity_Id;
3480 Formal := First_Formal (Body_Id);
3482 -- The protected operation always has at least one formal, namely the
3483 -- object itself, but it is only placed in the parameter list if
3484 -- expansion is enabled.
3486 if Present (Formal) or else Expander_Active then
3487 Plist := Copy_Parameter_List (Body_Id);
3492 if Nkind (Specification (N)) = N_Procedure_Specification then
3494 Make_Procedure_Specification (Loc,
3495 Defining_Unit_Name =>
3496 Make_Defining_Identifier (Sloc (Body_Id),
3497 Chars => Chars (Body_Id)),
3498 Parameter_Specifications =>
3502 Make_Function_Specification (Loc,
3503 Defining_Unit_Name =>
3504 Make_Defining_Identifier (Sloc (Body_Id),
3505 Chars => Chars (Body_Id)),
3506 Parameter_Specifications => Plist,
3507 Result_Definition =>
3508 New_Occurrence_Of (Etype (Body_Id), Loc));
3511 Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec);
3512 Insert_Before (N, Decl);
3513 Spec_Id := Defining_Unit_Name (New_Spec);
3515 -- Indicate that the entity comes from source, to ensure that cross-
3516 -- reference information is properly generated. The body itself is
3517 -- rewritten during expansion, and the body entity will not appear in
3518 -- calls to the operation.
3520 Set_Comes_From_Source (Spec_Id, True);
3522 Set_Has_Completion (Spec_Id);
3523 Set_Convention (Spec_Id, Convention_Protected);
3525 end Build_Private_Protected_Declaration;
3527 ---------------------------
3528 -- Build_Protected_Entry --
3529 ---------------------------
3531 function Build_Protected_Entry
3534 Pid : Node_Id) return Node_Id
3536 Bod_Decls : constant List_Id := New_List;
3537 Decls : constant List_Id := Declarations (N);
3538 End_Lab : constant Node_Id :=
3539 End_Label (Handled_Statement_Sequence (N));
3540 End_Loc : constant Source_Ptr :=
3541 Sloc (Last (Statements (Handled_Statement_Sequence (N))));
3542 -- Used for the generated call to Complete_Entry_Body
3544 Loc : constant Source_Ptr := Sloc (N);
3548 Bod_Stmts : List_Id;
3552 EH_Loc : Source_Ptr;
3553 -- Used for the exception handler, inserted at end of the body
3556 -- Set the source location on the exception handler only when debugging
3557 -- the expanded code (see Make_Implicit_Exception_Handler).
3559 if Debug_Generated_Code then
3562 -- Otherwise the inserted code should not be visible to the debugger
3565 EH_Loc := No_Location;
3569 Make_Defining_Identifier (Loc,
3570 Chars => Chars (Protected_Body_Subprogram (Ent)));
3571 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty);
3573 -- Add the following declarations:
3575 -- type poVP is access poV;
3576 -- _object : poVP := poVP (_O);
3578 -- where _O is the formal parameter associated with the concurrent
3579 -- object. These declarations are needed for Complete_Entry_Body.
3581 Add_Object_Pointer (Loc, Pid, Bod_Decls);
3583 -- Add renamings for all formals, the Protection object, discriminals,
3584 -- privals and the entry index constant for use by debugger.
3586 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc);
3587 Debug_Private_Data_Declarations (Decls);
3589 -- Put the declarations and the statements from the entry
3593 Make_Block_Statement (Loc,
3594 Declarations => Decls,
3595 Handled_Statement_Sequence => Handled_Statement_Sequence (N)));
3597 case Corresponding_Runtime_Package (Pid) is
3598 when System_Tasking_Protected_Objects_Entries =>
3599 Append_To (Bod_Stmts,
3600 Make_Procedure_Call_Statement (End_Loc,
3602 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
3603 Parameter_Associations => New_List (
3604 Make_Attribute_Reference (End_Loc,
3606 Make_Selected_Component (End_Loc,
3608 Make_Identifier (End_Loc, Name_uObject),
3610 Make_Identifier (End_Loc, Name_uObject)),
3611 Attribute_Name => Name_Unchecked_Access))));
3613 when System_Tasking_Protected_Objects_Single_Entry =>
3615 -- Historically, a call to Complete_Single_Entry_Body was
3616 -- inserted, but it was a null procedure.
3621 raise Program_Error;
3624 -- When exceptions can not be propagated, we never need to call
3625 -- Exception_Complete_Entry_Body.
3627 if No_Exception_Handlers_Set then
3629 Make_Subprogram_Body (Loc,
3630 Specification => Bod_Spec,
3631 Declarations => Bod_Decls,
3632 Handled_Statement_Sequence =>
3633 Make_Handled_Sequence_Of_Statements (Loc,
3634 Statements => Bod_Stmts,
3635 End_Label => End_Lab));
3638 Ohandle := Make_Others_Choice (Loc);
3639 Set_All_Others (Ohandle);
3641 case Corresponding_Runtime_Package (Pid) is
3642 when System_Tasking_Protected_Objects_Entries =>
3645 (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
3647 when System_Tasking_Protected_Objects_Single_Entry =>
3650 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
3653 raise Program_Error;
3656 -- Establish link between subprogram body entity and source entry
3658 Set_Corresponding_Protected_Entry (Bod_Id, Ent);
3660 -- Create body of entry procedure. The renaming declarations are
3661 -- placed ahead of the block that contains the actual entry body.
3664 Make_Subprogram_Body (Loc,
3665 Specification => Bod_Spec,
3666 Declarations => Bod_Decls,
3667 Handled_Statement_Sequence =>
3668 Make_Handled_Sequence_Of_Statements (Loc,
3669 Statements => Bod_Stmts,
3670 End_Label => End_Lab,
3671 Exception_Handlers => New_List (
3672 Make_Implicit_Exception_Handler (EH_Loc,
3673 Exception_Choices => New_List (Ohandle),
3675 Statements => New_List (
3676 Make_Procedure_Call_Statement (EH_Loc,
3678 Parameter_Associations => New_List (
3679 Make_Attribute_Reference (EH_Loc,
3681 Make_Selected_Component (EH_Loc,
3683 Make_Identifier (EH_Loc, Name_uObject),
3685 Make_Identifier (EH_Loc, Name_uObject)),
3686 Attribute_Name => Name_Unchecked_Access),
3688 Make_Function_Call (EH_Loc,
3691 (RTE (RE_Get_GNAT_Exception), Loc)))))))));
3693 end Build_Protected_Entry;
3695 -----------------------------------------
3696 -- Build_Protected_Entry_Specification --
3697 -----------------------------------------
3699 function Build_Protected_Entry_Specification
3702 Ent_Id : Entity_Id) return Node_Id
3704 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP);
3707 Set_Debug_Info_Needed (Def_Id);
3709 if Present (Ent_Id) then
3710 Append_Elmt (P, Accept_Address (Ent_Id));
3714 Make_Procedure_Specification (Loc,
3715 Defining_Unit_Name => Def_Id,
3716 Parameter_Specifications => New_List (
3717 Make_Parameter_Specification (Loc,
3718 Defining_Identifier =>
3719 Make_Defining_Identifier (Loc, Name_uO),
3721 New_Occurrence_Of (RTE (RE_Address), Loc)),
3723 Make_Parameter_Specification (Loc,
3724 Defining_Identifier => P,
3726 New_Occurrence_Of (RTE (RE_Address), Loc)),
3728 Make_Parameter_Specification (Loc,
3729 Defining_Identifier =>
3730 Make_Defining_Identifier (Loc, Name_uE),
3732 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))));
3733 end Build_Protected_Entry_Specification;
3735 --------------------------
3736 -- Build_Protected_Spec --
3737 --------------------------
3739 function Build_Protected_Spec
3741 Obj_Type : Entity_Id;
3743 Unprotected : Boolean := False) return List_Id
3745 Loc : constant Source_Ptr := Sloc (N);
3748 New_Plist : List_Id;
3749 New_Param : Node_Id;
3752 New_Plist := New_List;
3754 Formal := First_Formal (Ident);
3755 while Present (Formal) loop
3757 Make_Parameter_Specification (Loc,
3758 Defining_Identifier =>
3759 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
3760 Aliased_Present => Aliased_Present (Parent (Formal)),
3761 In_Present => In_Present (Parent (Formal)),
3762 Out_Present => Out_Present (Parent (Formal)),
3763 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc));
3766 Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
3769 Append (New_Param, New_Plist);
3770 Next_Formal (Formal);
3773 -- If the subprogram is a procedure and the context is not an access
3774 -- to protected subprogram, the parameter is in-out. Otherwise it is
3778 Make_Parameter_Specification (Loc,
3779 Defining_Identifier =>
3780 Make_Defining_Identifier (Loc, Name_uObject),
3783 (Etype (Ident) = Standard_Void_Type
3784 and then not Is_RTE (Obj_Type, RE_Address)),
3786 New_Occurrence_Of (Obj_Type, Loc));
3787 Set_Debug_Info_Needed (Defining_Identifier (Decl));
3788 Prepend_To (New_Plist, Decl);
3791 end Build_Protected_Spec;
3793 ---------------------------------------
3794 -- Build_Protected_Sub_Specification --
3795 ---------------------------------------
3797 function Build_Protected_Sub_Specification
3799 Prot_Typ : Entity_Id;
3800 Mode : Subprogram_Protection_Mode) return Node_Id
3802 Loc : constant Source_Ptr := Sloc (N);
3806 New_Plist : List_Id;
3809 Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
3810 (Dispatching_Mode => ' ',
3811 Protected_Mode => 'P',
3812 Unprotected_Mode => 'N');
3815 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
3817 Decl := Unit_Declaration_Node (Corresponding_Spec (N));
3822 Def_Id := Defining_Unit_Name (Specification (Decl));
3825 Build_Protected_Spec
3826 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id,
3827 Mode = Unprotected_Mode);
3829 Make_Defining_Identifier (Loc,
3830 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
3832 -- Reference the original nondispatching subprogram since the analysis
3833 -- of the object.operation notation may need its original name (see
3834 -- Sem_Ch4.Names_Match).
3836 if Mode = Dispatching_Mode then
3837 Set_Ekind (New_Id, Ekind (Def_Id));
3838 Set_Original_Protected_Subprogram (New_Id, Def_Id);
3841 -- The unprotected operation carries the user code, and debugging
3842 -- information must be generated for it, even though this spec does
3843 -- not come from source. It is also convenient to allow gdb to step
3844 -- into the protected operation, even though it only contains lock/
3847 Set_Debug_Info_Needed (New_Id);
3849 -- If a pragma Eliminate applies to the source entity, the internal
3850 -- subprograms will be eliminated as well.
3852 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
3854 if Nkind (Specification (Decl)) = N_Procedure_Specification then
3856 Make_Procedure_Specification (Loc,
3857 Defining_Unit_Name => New_Id,
3858 Parameter_Specifications => New_Plist);
3860 -- Create a new specification for the anonymous subprogram type
3864 Make_Function_Specification (Loc,
3865 Defining_Unit_Name => New_Id,
3866 Parameter_Specifications => New_Plist,
3867 Result_Definition =>
3868 Copy_Result_Type (Result_Definition (Specification (Decl))));
3870 Set_Return_Present (Defining_Unit_Name (New_Spec));
3874 end Build_Protected_Sub_Specification;
3876 -------------------------------------
3877 -- Build_Protected_Subprogram_Body --
3878 -------------------------------------
3880 function Build_Protected_Subprogram_Body
3883 N_Op_Spec : Node_Id) return Node_Id
3885 Loc : constant Source_Ptr := Sloc (N);
3887 P_Op_Spec : Node_Id;
3890 Unprot_Call : Node_Id;
3892 Lock_Name : Node_Id;
3893 Lock_Stmt : Node_Id;
3895 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
3896 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
3898 Object_Parm : Node_Id;
3903 Op_Spec := Specification (N);
3904 Exc_Safe := Is_Exception_Safe (N);
3907 Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
3909 -- Build a list of the formal parameters of the protected version of
3910 -- the subprogram to use as the actual parameters of the unprotected
3913 Uactuals := New_List;
3914 Pformal := First (Parameter_Specifications (P_Op_Spec));
3915 while Present (Pformal) loop
3916 Append_To (Uactuals,
3917 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
3921 -- Make a call to the unprotected version of the subprogram built above
3922 -- for use by the protected version built below.
3924 if Nkind (Op_Spec) = N_Function_Specification then
3926 R := Make_Temporary (Loc, 'R');
3929 Make_Object_Declaration (Loc,
3930 Defining_Identifier => R,
3931 Constant_Present => True,
3932 Object_Definition =>
3933 New_Copy (Result_Definition (N_Op_Spec)),
3935 Make_Function_Call (Loc,
3937 Make_Identifier (Loc,
3938 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
3939 Parameter_Associations => Uactuals));
3942 Make_Simple_Return_Statement (Loc,
3943 Expression => New_Occurrence_Of (R, Loc));
3947 Make_Simple_Return_Statement (Loc,
3949 Make_Function_Call (Loc,
3951 Make_Identifier (Loc,
3952 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
3953 Parameter_Associations => Uactuals));
3956 Lock_Kind := RE_Lock_Read_Only;
3960 Make_Procedure_Call_Statement (Loc,
3962 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
3963 Parameter_Associations => Uactuals);
3965 Lock_Kind := RE_Lock;
3968 -- Wrap call in block that will be covered by an at_end handler
3970 if not Exc_Safe then
3972 Make_Block_Statement (Loc,
3973 Handled_Statement_Sequence =>
3974 Make_Handled_Sequence_Of_Statements (Loc,
3975 Statements => New_List (Unprot_Call)));
3978 -- Make the protected subprogram body. This locks the protected
3979 -- object and calls the unprotected version of the subprogram.
3981 case Corresponding_Runtime_Package (Pid) is
3982 when System_Tasking_Protected_Objects_Entries =>
3983 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc);
3985 when System_Tasking_Protected_Objects_Single_Entry =>
3986 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc);
3988 when System_Tasking_Protected_Objects =>
3989 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc);
3992 raise Program_Error;
3996 Make_Attribute_Reference (Loc,
3998 Make_Selected_Component (Loc,
3999 Prefix => Make_Identifier (Loc, Name_uObject),
4000 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4001 Attribute_Name => Name_Unchecked_Access);
4004 Make_Procedure_Call_Statement (Loc,
4006 Parameter_Associations => New_List (Object_Parm));
4008 if Abort_Allowed then
4010 Build_Runtime_Call (Loc, RE_Abort_Defer),
4014 Stmts := New_List (Lock_Stmt);
4017 if not Exc_Safe then
4018 Append (Unprot_Call, Stmts);
4020 if Nkind (Op_Spec) = N_Function_Specification then
4022 Stmts := Empty_List;
4024 Append (Unprot_Call, Stmts);
4027 -- Historical note: Previously, call to the cleanup was inserted
4028 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4029 -- which is also shared by the 'not Exc_Safe' path.
4031 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
4033 if Nkind (Op_Spec) = N_Function_Specification then
4034 Append_To (Stmts, Return_Stmt);
4035 Append_To (Pre_Stmts,
4036 Make_Block_Statement (Loc,
4037 Declarations => New_List (Unprot_Call),
4038 Handled_Statement_Sequence =>
4039 Make_Handled_Sequence_Of_Statements (Loc,
4040 Statements => Stmts)));
4046 Make_Subprogram_Body (Loc,
4047 Declarations => Empty_List,
4048 Specification => P_Op_Spec,
4049 Handled_Statement_Sequence =>
4050 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
4052 -- Mark this subprogram as a protected subprogram body so that the
4053 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4054 -- path as otherwise the cleanup has already been inserted.
4056 if not Exc_Safe then
4057 Set_Is_Protected_Subprogram_Body (Sub_Body);
4061 end Build_Protected_Subprogram_Body;
4063 -------------------------------------
4064 -- Build_Protected_Subprogram_Call --
4065 -------------------------------------
4067 procedure Build_Protected_Subprogram_Call
4071 External : Boolean := True)
4073 Loc : constant Source_Ptr := Sloc (N);
4074 Sub : constant Entity_Id := Entity (Name);
4080 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
4083 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
4086 if Present (Parameter_Associations (N)) then
4087 Params := New_Copy_List_Tree (Parameter_Associations (N));
4092 -- If the type is an untagged derived type, convert to the root type,
4093 -- which is the one on which the operations are defined.
4095 if Nkind (Rec) = N_Unchecked_Type_Conversion
4096 and then not Is_Tagged_Type (Etype (Rec))
4097 and then Is_Derived_Type (Etype (Rec))
4099 Set_Etype (Rec, Root_Type (Etype (Rec)));
4100 Set_Subtype_Mark (Rec,
4101 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
4104 Prepend (Rec, Params);
4106 if Ekind (Sub) = E_Procedure then
4108 Make_Procedure_Call_Statement (Loc,
4110 Parameter_Associations => Params));
4113 pragma Assert (Ekind (Sub) = E_Function);
4115 Make_Function_Call (Loc,
4117 Parameter_Associations => Params));
4119 -- Preserve type of call for subsequent processing (required for
4120 -- call to Wrap_Transient_Expression in the case of a shared passive
4123 Set_Etype (N, Etype (New_Sub));
4127 and then Nkind (Rec) = N_Unchecked_Type_Conversion
4128 and then Is_Entity_Name (Expression (Rec))
4129 and then Is_Shared_Passive (Entity (Expression (Rec)))
4131 Add_Shared_Var_Lock_Procs (N);
4133 end Build_Protected_Subprogram_Call;
4135 ---------------------------------------------
4136 -- Build_Protected_Subprogram_Call_Cleanup --
4137 ---------------------------------------------
4139 procedure Build_Protected_Subprogram_Call_Cleanup
4148 -- If the associated protected object has entries, a protected
4149 -- procedure has to service entry queues. In this case generate:
4151 -- Service_Entries (_object._object'Access);
4153 if Nkind (Op_Spec) = N_Procedure_Specification
4154 and then Has_Entries (Conc_Typ)
4156 case Corresponding_Runtime_Package (Conc_Typ) is
4157 when System_Tasking_Protected_Objects_Entries =>
4158 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc);
4160 when System_Tasking_Protected_Objects_Single_Entry =>
4161 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc);
4164 raise Program_Error;
4168 Make_Procedure_Call_Statement (Loc,
4170 Parameter_Associations => New_List (
4171 Make_Attribute_Reference (Loc,
4173 Make_Selected_Component (Loc,
4174 Prefix => Make_Identifier (Loc, Name_uObject),
4175 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4176 Attribute_Name => Name_Unchecked_Access))));
4180 -- Unlock (_object._object'Access);
4182 case Corresponding_Runtime_Package (Conc_Typ) is
4183 when System_Tasking_Protected_Objects_Entries =>
4184 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc);
4186 when System_Tasking_Protected_Objects_Single_Entry =>
4187 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc);
4189 when System_Tasking_Protected_Objects =>
4190 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc);
4193 raise Program_Error;
4197 Make_Procedure_Call_Statement (Loc,
4199 Parameter_Associations => New_List (
4200 Make_Attribute_Reference (Loc,
4202 Make_Selected_Component (Loc,
4203 Prefix => Make_Identifier (Loc, Name_uObject),
4204 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4205 Attribute_Name => Name_Unchecked_Access))));
4211 if Abort_Allowed then
4212 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4214 end Build_Protected_Subprogram_Call_Cleanup;
4216 -------------------------
4217 -- Build_Selected_Name --
4218 -------------------------
4220 function Build_Selected_Name
4221 (Prefix : Entity_Id;
4222 Selector : Entity_Id;
4223 Append_Char : Character := ' ') return Name_Id
4225 Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
4226 Select_Len : Natural;
4229 Get_Name_String (Chars (Selector));
4230 Select_Len := Name_Len;
4231 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
4232 Get_Name_String (Chars (Prefix));
4234 -- If scope is anonymous type, discard suffix to recover name of
4235 -- single protected object. Otherwise use protected type name.
4237 if Name_Buffer (Name_Len) = 'T' then
4238 Name_Len := Name_Len - 1;
4241 Add_Str_To_Name_Buffer ("__");
4242 for J in 1 .. Select_Len loop
4243 Add_Char_To_Name_Buffer (Select_Buffer (J));
4246 -- Now add the Append_Char if specified. The encoding to follow
4247 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4248 -- then the entity is associated to a protected type subprogram.
4249 -- Otherwise, it is a protected type entry. For each case, the
4250 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4252 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4254 if Append_Char /= ' ' then
4255 if Append_Char = 'P' or Append_Char = 'N' then
4256 Add_Char_To_Name_Buffer (Append_Char);
4259 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
4260 return New_External_Name (Name_Find, ' ', -1);
4265 end Build_Selected_Name;
4267 -----------------------------
4268 -- Build_Simple_Entry_Call --
4269 -----------------------------
4271 -- A task entry call is converted to a call to Call_Simple
4274 -- P : parms := (parm, parm, parm);
4276 -- Call_Simple (acceptor-task, entry-index, P'Address);
4282 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4283 -- the parameters, and the constructed aggregate value contains either the
4284 -- parameters or, in the case of non-elementary types, references to these
4285 -- parameters. Then the address of this aggregate is passed to the runtime
4286 -- routine, along with the task id value and the task entry index value.
4287 -- Pnn is only required if parameters are present.
4289 -- The assignments after the call are present only in the case of in-out
4290 -- or out parameters for elementary types, and are used to assign back the
4291 -- resulting values of such parameters.
4293 -- Note: the reason that we insert a block here is that in the context
4294 -- of selects, conditional entry calls etc. the entry call statement
4295 -- appears on its own, not as an element of a list.
4297 -- A protected entry call is converted to a Protected_Entry_Call:
4300 -- P : E1_Params := (param, param, param);
4302 -- Bnn : Communications_Block;
4305 -- P : E1_Params := (param, param, param);
4306 -- Bnn : Communications_Block;
4309 -- Protected_Entry_Call (
4310 -- Object => po._object'Access,
4311 -- E => <entry index>;
4312 -- Uninterpreted_Data => P'Address;
4313 -- Mode => Simple_Call;
4320 procedure Build_Simple_Entry_Call
4329 -- If call has been inlined, nothing left to do
4331 if Nkind (N) = N_Block_Statement then
4335 -- Convert entry call to Call_Simple call
4338 Loc : constant Source_Ptr := Sloc (N);
4339 Parms : constant List_Id := Parameter_Associations (N);
4340 Stats : constant List_Id := New_List;
4343 Comm_Name : Entity_Id;
4347 Ent_Acc : Entity_Id;
4349 Iface_Tag : Entity_Id;
4350 Iface_Typ : Entity_Id;
4363 -- Simple entry and entry family cases merge here
4365 Ent := Entity (Ename);
4366 Ent_Acc := Entry_Parameters_Type (Ent);
4367 Conctyp := Etype (Concval);
4369 -- If prefix is an access type, dereference to obtain the task type
4371 if Is_Access_Type (Conctyp) then
4372 Conctyp := Designated_Type (Conctyp);
4375 -- Special case for protected subprogram calls
4377 if Is_Protected_Type (Conctyp)
4378 and then Is_Subprogram (Entity (Ename))
4380 if not Is_Eliminated (Entity (Ename)) then
4381 Build_Protected_Subprogram_Call
4382 (N, Ename, Convert_Concurrent (Concval, Conctyp));
4389 -- First parameter is the Task_Id value from the task value or the
4390 -- Object from the protected object value, obtained by selecting
4391 -- the _Task_Id or _Object from the result of doing an unchecked
4392 -- conversion to convert the value to the corresponding record type.
4394 if Nkind (Concval) = N_Function_Call
4395 and then Is_Task_Type (Conctyp)
4396 and then Ada_Version >= Ada_2005
4399 ExpR : constant Node_Id := Relocate_Node (Concval);
4400 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR);
4405 Make_Object_Declaration (Loc,
4406 Defining_Identifier => Obj,
4407 Object_Definition => New_Occurrence_Of (Conctyp, Loc),
4408 Expression => ExpR);
4409 Set_Etype (Obj, Conctyp);
4410 Decls := New_List (Decl);
4411 Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
4418 Parm1 := Concurrent_Ref (Concval);
4420 -- Second parameter is the entry index, computed by the routine
4421 -- provided for this purpose. The value of this expression is
4422 -- assigned to an intermediate variable to assure that any entry
4423 -- family index expressions are evaluated before the entry
4426 if not Is_Protected_Type (Conctyp)
4428 Corresponding_Runtime_Package (Conctyp) =
4429 System_Tasking_Protected_Objects_Entries
4431 X := Make_Defining_Identifier (Loc, Name_uX);
4434 Make_Object_Declaration (Loc,
4435 Defining_Identifier => X,
4436 Object_Definition =>
4437 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
4438 Expression => Actual_Index_Expression (
4439 Loc, Entity (Ename), Index, Concval));
4441 Append_To (Decls, Xdecl);
4442 Parm2 := New_Occurrence_Of (X, Loc);
4449 -- The third parameter is the packaged parameters. If there are
4450 -- none, then it is just the null address, since nothing is passed.
4453 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
4456 -- Case of parameters present, where third argument is the address
4457 -- of a packaged record containing the required parameter values.
4460 -- First build a list of parameter values, which are references to
4461 -- objects of the parameter types.
4465 Actual := First_Actual (N);
4466 Formal := First_Formal (Ent);
4467 while Present (Actual) loop
4469 -- If it is a by-copy type, copy it to a new variable. The
4470 -- packaged record has a field that points to this variable.
4472 if Is_By_Copy_Type (Etype (Actual)) then
4474 Make_Object_Declaration (Loc,
4475 Defining_Identifier => Make_Temporary (Loc, 'J'),
4476 Aliased_Present => True,
4477 Object_Definition =>
4478 New_Occurrence_Of (Etype (Formal), Loc));
4480 -- Mark the object as not needing initialization since the
4481 -- initialization is performed separately, avoiding errors
4482 -- on cases such as formals of null-excluding access types.
4484 Set_No_Initialization (N_Node);
4486 -- We must make a separate assignment statement for the
4487 -- case of limited types. We cannot assign it unless the
4488 -- Assignment_OK flag is set first. An out formal of an
4489 -- access type or whose type has a Default_Value must also
4490 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4491 -- but no constraint, predicate, or null-exclusion check is
4492 -- applied before the call.
4494 if Ekind (Formal) /= E_Out_Parameter
4495 or else Is_Access_Type (Etype (Formal))
4497 (Is_Scalar_Type (Etype (Formal))
4499 Present (Default_Aspect_Value (Etype (Formal))))
4502 New_Occurrence_Of (Defining_Identifier (N_Node), Loc);
4503 Set_Assignment_OK (N_Var);
4505 Make_Assignment_Statement (Loc,
4507 Expression => Relocate_Node (Actual)));
4509 -- Mark the object as internal, so we don't later reset
4510 -- No_Initialization flag in Default_Initialize_Object,
4511 -- which would lead to needless default initialization.
4512 -- We don't set this outside the if statement, because
4513 -- out scalar parameters without Default_Value do require
4514 -- default initialization if Initialize_Scalars applies.
4516 Set_Is_Internal (Defining_Identifier (N_Node));
4518 -- If actual is an out parameter of a null-excluding
4519 -- access type, there is access check on entry, so set
4520 -- Suppress_Assignment_Checks on the generated statement
4521 -- that assigns the actual to the parameter block
4523 Set_Suppress_Assignment_Checks (Last (Stats));
4526 Append (N_Node, Decls);
4529 Make_Attribute_Reference (Loc,
4530 Attribute_Name => Name_Unchecked_Access,
4533 (Defining_Identifier (N_Node), Loc)));
4536 -- Interface class-wide formal
4538 if Ada_Version >= Ada_2005
4539 and then Ekind (Etype (Formal)) = E_Class_Wide_Type
4540 and then Is_Interface (Etype (Formal))
4542 Iface_Typ := Etype (Etype (Formal));
4545 -- formal_iface_type! (actual.iface_tag)'reference
4548 Find_Interface_Tag (Etype (Actual), Iface_Typ);
4549 pragma Assert (Present (Iface_Tag));
4552 Make_Reference (Loc,
4553 Unchecked_Convert_To (Iface_Typ,
4554 Make_Selected_Component (Loc,
4556 Relocate_Node (Actual),
4558 New_Occurrence_Of (Iface_Tag, Loc)))));
4564 Make_Reference (Loc, Relocate_Node (Actual)));
4568 Next_Actual (Actual);
4569 Next_Formal_With_Extras (Formal);
4572 -- Now build the declaration of parameters initialized with the
4573 -- aggregate containing this constructed parameter list.
4575 P := Make_Defining_Identifier (Loc, Name_uP);
4578 Make_Object_Declaration (Loc,
4579 Defining_Identifier => P,
4580 Object_Definition =>
4581 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc),
4583 Make_Aggregate (Loc, Expressions => Plist));
4586 Make_Attribute_Reference (Loc,
4587 Prefix => New_Occurrence_Of (P, Loc),
4588 Attribute_Name => Name_Address);
4590 Append (Pdecl, Decls);
4593 -- Now we can create the call, case of protected type
4595 if Is_Protected_Type (Conctyp) then
4596 case Corresponding_Runtime_Package (Conctyp) is
4597 when System_Tasking_Protected_Objects_Entries =>
4599 -- Change the type of the index declaration
4601 Set_Object_Definition (Xdecl,
4602 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc));
4604 -- Some additional declarations for protected entry calls
4610 -- Bnn : Communications_Block;
4612 Comm_Name := Make_Temporary (Loc, 'B');
4615 Make_Object_Declaration (Loc,
4616 Defining_Identifier => Comm_Name,
4617 Object_Definition =>
4619 (RTE (RE_Communication_Block), Loc)));
4621 -- Some additional statements for protected entry calls
4623 -- Protected_Entry_Call (
4624 -- Object => po._object'Access,
4625 -- E => <entry index>;
4626 -- Uninterpreted_Data => P'Address;
4627 -- Mode => Simple_Call;
4631 Make_Procedure_Call_Statement (Loc,
4633 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
4635 Parameter_Associations => New_List (
4636 Make_Attribute_Reference (Loc,
4637 Attribute_Name => Name_Unchecked_Access,
4641 New_Occurrence_Of (RTE (RE_Simple_Call), Loc),
4642 New_Occurrence_Of (Comm_Name, Loc)));
4644 when System_Tasking_Protected_Objects_Single_Entry =>
4645 -- Protected_Single_Entry_Call (
4646 -- Object => po._object'Access,
4647 -- Uninterpreted_Data => P'Address);
4650 Make_Procedure_Call_Statement (Loc,
4653 (RTE (RE_Protected_Single_Entry_Call), Loc),
4655 Parameter_Associations => New_List (
4656 Make_Attribute_Reference (Loc,
4657 Attribute_Name => Name_Unchecked_Access,
4662 raise Program_Error;
4665 -- Case of task type
4669 Make_Procedure_Call_Statement (Loc,
4671 New_Occurrence_Of (RTE (RE_Call_Simple), Loc),
4672 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
4676 Append_To (Stats, Call);
4678 -- If there are out or in/out parameters by copy add assignment
4679 -- statements for the result values.
4681 if Present (Parms) then
4682 Actual := First_Actual (N);
4683 Formal := First_Formal (Ent);
4685 Set_Assignment_OK (Actual);
4686 while Present (Actual) loop
4687 if Is_By_Copy_Type (Etype (Actual))
4688 and then Ekind (Formal) /= E_In_Parameter
4691 Make_Assignment_Statement (Loc,
4692 Name => New_Copy (Actual),
4694 Make_Explicit_Dereference (Loc,
4695 Make_Selected_Component (Loc,
4696 Prefix => New_Occurrence_Of (P, Loc),
4698 Make_Identifier (Loc, Chars (Formal)))));
4700 -- In all cases (including limited private types) we want
4701 -- the assignment to be valid.
4703 Set_Assignment_OK (Name (N_Node));
4705 -- If the call is the triggering alternative in an
4706 -- asynchronous select, or the entry_call alternative of a
4707 -- conditional entry call, the assignments for in-out
4708 -- parameters are incorporated into the statement list that
4709 -- follows, so that there are executed only if the entry
4712 if (Nkind (Parent (N)) = N_Triggering_Alternative
4713 and then N = Triggering_Statement (Parent (N)))
4715 (Nkind (Parent (N)) = N_Entry_Call_Alternative
4716 and then N = Entry_Call_Statement (Parent (N)))
4718 if No (Statements (Parent (N))) then
4719 Set_Statements (Parent (N), New_List);
4722 Prepend (N_Node, Statements (Parent (N)));
4725 Insert_After (Call, N_Node);
4729 Next_Actual (Actual);
4730 Next_Formal_With_Extras (Formal);
4734 -- Finally, create block and analyze it
4737 Make_Block_Statement (Loc,
4738 Declarations => Decls,
4739 Handled_Statement_Sequence =>
4740 Make_Handled_Sequence_Of_Statements (Loc,
4741 Statements => Stats)));
4745 end Build_Simple_Entry_Call;
4747 --------------------------------
4748 -- Build_Task_Activation_Call --
4749 --------------------------------
4751 procedure Build_Task_Activation_Call (N : Node_Id) is
4752 Loc : constant Source_Ptr := Sloc (N);
4759 -- For sequential elaboration policy, all the tasks will be activated at
4760 -- the end of the elaboration.
4762 if Partition_Elaboration_Policy = 'S' then
4766 -- Get the activation chain entity. Except in the case of a package
4767 -- body, this is in the node that was passed. For a package body, we
4768 -- have to find the corresponding package declaration node.
4770 if Nkind (N) = N_Package_Body then
4771 P := Corresponding_Spec (N);
4774 exit when Nkind (P) = N_Package_Declaration;
4777 Chain := Activation_Chain_Entity (P);
4780 Chain := Activation_Chain_Entity (N);
4783 if Present (Chain) then
4784 if Restricted_Profile then
4785 Name := New_Occurrence_Of
4786 (RTE (RE_Activate_Restricted_Tasks), Loc);
4788 Name := New_Occurrence_Of
4789 (RTE (RE_Activate_Tasks), Loc);
4793 Make_Procedure_Call_Statement (Loc,
4795 Parameter_Associations =>
4796 New_List (Make_Attribute_Reference (Loc,
4797 Prefix => New_Occurrence_Of (Chain, Loc),
4798 Attribute_Name => Name_Unchecked_Access)));
4800 if Nkind (N) = N_Package_Declaration then
4801 if Present (Corresponding_Body (N)) then
4804 elsif Present (Private_Declarations (Specification (N))) then
4805 Append (Call, Private_Declarations (Specification (N)));
4808 Append (Call, Visible_Declarations (Specification (N)));
4812 if Present (Handled_Statement_Sequence (N)) then
4814 -- The call goes at the start of the statement sequence after
4815 -- the start of exception range label if one is present.
4821 Stm := First (Statements (Handled_Statement_Sequence (N)));
4823 -- A special case, skip exception range label if one is
4824 -- present (from front end zcx processing).
4826 if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
4830 -- Another special case, if the first statement is a block
4831 -- from optimization of a local raise to a goto, then the
4832 -- call goes inside this block.
4834 if Nkind (Stm) = N_Block_Statement
4835 and then Exception_Junk (Stm)
4838 First (Statements (Handled_Statement_Sequence (Stm)));
4841 -- Insertion point is after any exception label pushes,
4842 -- since we want it covered by any local handlers.
4844 while Nkind (Stm) in N_Push_xxx_Label loop
4848 -- Now we have the proper insertion point
4850 Insert_Before (Stm, Call);
4854 Set_Handled_Statement_Sequence (N,
4855 Make_Handled_Sequence_Of_Statements (Loc,
4856 Statements => New_List (Call)));
4861 Check_Task_Activation (N);
4863 end Build_Task_Activation_Call;
4865 -------------------------------
4866 -- Build_Task_Allocate_Block --
4867 -------------------------------
4869 procedure Build_Task_Allocate_Block
4874 T : constant Entity_Id := Entity (Expression (N));
4875 Init : constant Entity_Id := Base_Init_Proc (T);
4876 Loc : constant Source_Ptr := Sloc (N);
4877 Chain : constant Entity_Id :=
4878 Make_Defining_Identifier (Loc, Name_uChain);
4879 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
4884 Make_Block_Statement (Loc,
4885 Identifier => New_Occurrence_Of (Blkent, Loc),
4886 Declarations => New_List (
4888 -- _Chain : Activation_Chain;
4890 Make_Object_Declaration (Loc,
4891 Defining_Identifier => Chain,
4892 Aliased_Present => True,
4893 Object_Definition =>
4894 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
4896 Handled_Statement_Sequence =>
4897 Make_Handled_Sequence_Of_Statements (Loc,
4899 Statements => New_List (
4903 Make_Procedure_Call_Statement (Loc,
4904 Name => New_Occurrence_Of (Init, Loc),
4905 Parameter_Associations => Args),
4907 -- Activate_Tasks (_Chain);
4909 Make_Procedure_Call_Statement (Loc,
4910 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
4911 Parameter_Associations => New_List (
4912 Make_Attribute_Reference (Loc,
4913 Prefix => New_Occurrence_Of (Chain, Loc),
4914 Attribute_Name => Name_Unchecked_Access))))),
4916 Has_Created_Identifier => True,
4917 Is_Task_Allocation_Block => True);
4920 Make_Implicit_Label_Declaration (Loc,
4921 Defining_Identifier => Blkent,
4922 Label_Construct => Block));
4924 Append_To (Actions, Block);
4926 Set_Activation_Chain_Entity (Block, Chain);
4927 end Build_Task_Allocate_Block;
4929 -----------------------------------------------
4930 -- Build_Task_Allocate_Block_With_Init_Stmts --
4931 -----------------------------------------------
4933 procedure Build_Task_Allocate_Block_With_Init_Stmts
4936 Init_Stmts : List_Id)
4938 Loc : constant Source_Ptr := Sloc (N);
4939 Chain : constant Entity_Id :=
4940 Make_Defining_Identifier (Loc, Name_uChain);
4941 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
4945 Append_To (Init_Stmts,
4946 Make_Procedure_Call_Statement (Loc,
4947 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
4948 Parameter_Associations => New_List (
4949 Make_Attribute_Reference (Loc,
4950 Prefix => New_Occurrence_Of (Chain, Loc),
4951 Attribute_Name => Name_Unchecked_Access))));
4954 Make_Block_Statement (Loc,
4955 Identifier => New_Occurrence_Of (Blkent, Loc),
4956 Declarations => New_List (
4958 -- _Chain : Activation_Chain;
4960 Make_Object_Declaration (Loc,
4961 Defining_Identifier => Chain,
4962 Aliased_Present => True,
4963 Object_Definition =>
4964 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
4966 Handled_Statement_Sequence =>
4967 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
4969 Has_Created_Identifier => True,
4970 Is_Task_Allocation_Block => True);
4973 Make_Implicit_Label_Declaration (Loc,
4974 Defining_Identifier => Blkent,
4975 Label_Construct => Block));
4977 Append_To (Actions, Block);
4979 Set_Activation_Chain_Entity (Block, Chain);
4980 end Build_Task_Allocate_Block_With_Init_Stmts;
4982 -----------------------------------
4983 -- Build_Task_Proc_Specification --
4984 -----------------------------------
4986 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
4987 Loc : constant Source_Ptr := Sloc (T);
4988 Spec_Id : Entity_Id;
4991 -- Case of explicit task type, suffix TB
4993 if Comes_From_Source (T) then
4995 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB"));
4997 -- Case of anonymous task type, suffix B
5001 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B'));
5004 Set_Is_Internal (Spec_Id);
5006 -- Associate the procedure with the task, if this is the declaration
5007 -- (and not the body) of the procedure.
5009 if No (Task_Body_Procedure (T)) then
5010 Set_Task_Body_Procedure (T, Spec_Id);
5014 Make_Procedure_Specification (Loc,
5015 Defining_Unit_Name => Spec_Id,
5016 Parameter_Specifications => New_List (
5017 Make_Parameter_Specification (Loc,
5018 Defining_Identifier =>
5019 Make_Defining_Identifier (Loc, Name_uTask),
5021 Make_Access_Definition (Loc,
5023 New_Occurrence_Of (Corresponding_Record_Type (T), Loc)))));
5024 end Build_Task_Proc_Specification;
5026 ---------------------------------------
5027 -- Build_Unprotected_Subprogram_Body --
5028 ---------------------------------------
5030 function Build_Unprotected_Subprogram_Body
5032 Pid : Node_Id) return Node_Id
5034 Decls : constant List_Id := Declarations (N);
5037 -- Add renamings for the Protection object, discriminals, privals, and
5038 -- the entry index constant for use by debugger.
5040 Debug_Private_Data_Declarations (Decls);
5042 -- Make an unprotected version of the subprogram for use within the same
5043 -- object, with a new name and an additional parameter representing the
5047 Make_Subprogram_Body (Sloc (N),
5049 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
5050 Declarations => Decls,
5051 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
5052 end Build_Unprotected_Subprogram_Body;
5054 ----------------------------
5055 -- Collect_Entry_Families --
5056 ----------------------------
5058 procedure Collect_Entry_Families
5061 Current_Node : in out Node_Id;
5062 Conctyp : Entity_Id)
5065 Efam_Decl : Node_Id;
5066 Efam_Type : Entity_Id;
5069 Efam := First_Entity (Conctyp);
5070 while Present (Efam) loop
5071 if Ekind (Efam) = E_Entry_Family then
5072 Efam_Type := Make_Temporary (Loc, 'F');
5077 (Etype (Discrete_Subtype_Definition (Parent (Efam))));
5079 Bas_Decl : Node_Id := Empty;
5084 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
5086 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
5087 Bas := Make_Temporary (Loc, 'B');
5090 Make_Subtype_Declaration (Loc,
5091 Defining_Identifier => Bas,
5092 Subtype_Indication =>
5093 Make_Subtype_Indication (Loc,
5095 New_Occurrence_Of (Standard_Integer, Loc),
5097 Make_Range_Constraint (Loc,
5098 Range_Expression => Make_Range (Loc,
5099 Make_Integer_Literal
5100 (Loc, -Entry_Family_Bound),
5101 Make_Integer_Literal
5102 (Loc, Entry_Family_Bound - 1)))));
5104 Insert_After (Current_Node, Bas_Decl);
5105 Current_Node := Bas_Decl;
5110 Make_Full_Type_Declaration (Loc,
5111 Defining_Identifier => Efam_Type,
5113 Make_Unconstrained_Array_Definition (Loc,
5115 (New_List (New_Occurrence_Of (Bas, Loc))),
5117 Component_Definition =>
5118 Make_Component_Definition (Loc,
5119 Aliased_Present => False,
5120 Subtype_Indication =>
5121 New_Occurrence_Of (Standard_Character, Loc))));
5124 Insert_After (Current_Node, Efam_Decl);
5125 Current_Node := Efam_Decl;
5126 Analyze (Efam_Decl);
5129 Make_Component_Declaration (Loc,
5130 Defining_Identifier =>
5131 Make_Defining_Identifier (Loc, Chars (Efam)),
5133 Component_Definition =>
5134 Make_Component_Definition (Loc,
5135 Aliased_Present => False,
5136 Subtype_Indication =>
5137 Make_Subtype_Indication (Loc,
5139 New_Occurrence_Of (Efam_Type, Loc),
5142 Make_Index_Or_Discriminant_Constraint (Loc,
5143 Constraints => New_List (
5145 (Etype (Discrete_Subtype_Definition
5146 (Parent (Efam))), Loc)))))));
5152 end Collect_Entry_Families;
5154 -----------------------
5155 -- Concurrent_Object --
5156 -----------------------
5158 function Concurrent_Object
5159 (Spec_Id : Entity_Id;
5160 Conc_Typ : Entity_Id) return Entity_Id
5163 -- Parameter _O or _object
5165 if Is_Protected_Type (Conc_Typ) then
5166 return First_Formal (Protected_Body_Subprogram (Spec_Id));
5171 pragma Assert (Is_Task_Type (Conc_Typ));
5172 return First_Formal (Task_Body_Procedure (Conc_Typ));
5174 end Concurrent_Object;
5176 ----------------------
5177 -- Copy_Result_Type --
5178 ----------------------
5180 function Copy_Result_Type (Res : Node_Id) return Node_Id is
5181 New_Res : constant Node_Id := New_Copy_Tree (Res);
5186 -- If the result type is an access_to_subprogram, we must create new
5187 -- entities for its spec.
5189 if Nkind (New_Res) = N_Access_Definition
5190 and then Present (Access_To_Subprogram_Definition (New_Res))
5192 -- Provide new entities for the formals
5194 Par_Spec := First (Parameter_Specifications
5195 (Access_To_Subprogram_Definition (New_Res)));
5196 while Present (Par_Spec) loop
5197 Formal := Defining_Identifier (Par_Spec);
5198 Set_Defining_Identifier (Par_Spec,
5199 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
5205 end Copy_Result_Type;
5207 --------------------
5208 -- Concurrent_Ref --
5209 --------------------
5211 -- The expression returned for a reference to a concurrent object has the
5214 -- taskV!(name)._Task_Id
5218 -- objectV!(name)._Object
5220 -- for a protected object. For the case of an access to a concurrent
5221 -- object, there is an extra explicit dereference:
5223 -- taskV!(name.all)._Task_Id
5224 -- objectV!(name.all)._Object
5226 -- here taskV and objectV are the types for the associated records, which
5227 -- contain the required _Task_Id and _Object fields for tasks and protected
5228 -- objects, respectively.
5230 -- For the case of a task type name, the expression is
5234 -- i.e. a call to the Self function which returns precisely this Task_Id
5236 -- For the case of a protected type name, the expression is
5240 -- which is a renaming of the _object field of the current object
5241 -- record, passed into protected operations as a parameter.
5243 function Concurrent_Ref (N : Node_Id) return Node_Id is
5244 Loc : constant Source_Ptr := Sloc (N);
5245 Ntyp : constant Entity_Id := Etype (N);
5249 function Is_Current_Task (T : Entity_Id) return Boolean;
5250 -- Check whether the reference is to the immediately enclosing task
5251 -- type, or to an outer one (rare but legal).
5253 ---------------------
5254 -- Is_Current_Task --
5255 ---------------------
5257 function Is_Current_Task (T : Entity_Id) return Boolean is
5261 Scop := Current_Scope;
5262 while Present (Scop) and then Scop /= Standard_Standard loop
5266 elsif Is_Task_Type (Scop) then
5269 -- If this is a procedure nested within the task type, we must
5270 -- assume that it can be called from an inner task, and therefore
5271 -- cannot treat it as a local reference.
5273 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then
5277 Scop := Scope (Scop);
5281 -- We know that we are within the task body, so should have found it
5284 raise Program_Error;
5285 end Is_Current_Task;
5287 -- Start of processing for Concurrent_Ref
5290 if Is_Access_Type (Ntyp) then
5291 Dtyp := Designated_Type (Ntyp);
5293 if Is_Protected_Type (Dtyp) then
5294 Sel := Name_uObject;
5296 Sel := Name_uTask_Id;
5300 Make_Selected_Component (Loc,
5302 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
5303 Make_Explicit_Dereference (Loc, N)),
5304 Selector_Name => Make_Identifier (Loc, Sel));
5306 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then
5307 if Is_Task_Type (Entity (N)) then
5309 if Is_Current_Task (Entity (N)) then
5311 Make_Function_Call (Loc,
5312 Name => New_Occurrence_Of (RTE (RE_Self), Loc));
5317 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T');
5318 T_Body : constant Node_Id :=
5319 Parent (Corresponding_Body (Parent (Entity (N))));
5323 Make_Object_Declaration (Loc,
5324 Defining_Identifier => T_Self,
5325 Object_Definition =>
5326 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
5328 Make_Function_Call (Loc,
5329 Name => New_Occurrence_Of (RTE (RE_Self), Loc)));
5330 Prepend (Decl, Declarations (T_Body));
5332 Set_Scope (T_Self, Entity (N));
5333 return New_Occurrence_Of (T_Self, Loc);
5338 pragma Assert (Is_Protected_Type (Entity (N)));
5341 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc);
5345 if Is_Protected_Type (Ntyp) then
5346 Sel := Name_uObject;
5347 elsif Is_Task_Type (Ntyp) then
5348 Sel := Name_uTask_Id;
5350 raise Program_Error;
5354 Make_Selected_Component (Loc,
5356 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
5358 Selector_Name => Make_Identifier (Loc, Sel));
5362 ------------------------
5363 -- Convert_Concurrent --
5364 ------------------------
5366 function Convert_Concurrent
5368 Typ : Entity_Id) return Node_Id
5371 if not Is_Concurrent_Type (Typ) then
5375 Unchecked_Convert_To
5376 (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
5378 end Convert_Concurrent;
5380 -------------------------------------
5381 -- Debug_Private_Data_Declarations --
5382 -------------------------------------
5384 procedure Debug_Private_Data_Declarations (Decls : List_Id) is
5385 Debug_Nod : Node_Id;
5389 Decl := First (Decls);
5390 while Present (Decl) and then not Comes_From_Source (Decl) loop
5392 -- Declaration for concurrent entity _object and its access type,
5393 -- along with the entry index subtype:
5394 -- type prot_typVP is access prot_typV;
5395 -- _object : prot_typVP := prot_typV (_O);
5396 -- subtype Jnn is <Type of Index> range Low .. High;
5398 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then
5399 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5401 -- Declaration for the Protection object, discriminals, privals, and
5402 -- entry index constant:
5403 -- conc_typR : protection_typ renames _object._object;
5404 -- discr_nameD : discr_typ renames _object.discr_name;
5405 -- discr_nameD : discr_typ renames _task.discr_name;
5406 -- prival_name : comp_typ renames _object.comp_name;
5407 -- J : constant Jnn :=
5408 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5410 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
5411 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5412 Debug_Nod := Debug_Renaming_Declaration (Decl);
5414 if Present (Debug_Nod) then
5415 Insert_After (Decl, Debug_Nod);
5421 end Debug_Private_Data_Declarations;
5423 ------------------------------
5424 -- Ensure_Statement_Present --
5425 ------------------------------
5427 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is
5431 if Opt.Suppress_Control_Flow_Optimizations
5432 and then Is_Empty_List (Statements (Alt))
5434 Stmt := Make_Null_Statement (Loc);
5436 -- Mark NULL statement as coming from source so that it is not
5437 -- eliminated by GIGI.
5439 -- Another covert channel. If this is a requirement, it must be
5440 -- documented in sinfo/einfo ???
5442 Set_Comes_From_Source (Stmt, True);
5444 Set_Statements (Alt, New_List (Stmt));
5446 end Ensure_Statement_Present;
5448 ----------------------------
5449 -- Entry_Index_Expression --
5450 ----------------------------
5452 function Entry_Index_Expression
5456 Ttyp : Entity_Id) return Node_Id
5466 -- The queues of entries and entry families appear in textual order in
5467 -- the associated record. The entry index is computed as the sum of the
5468 -- number of queues for all entries that precede the designated one, to
5469 -- which is added the index expression, if this expression denotes a
5470 -- member of a family.
5472 -- The following is a place holder for the count of simple entries
5474 Num := Make_Integer_Literal (Sloc, 1);
5476 -- We construct an expression which is a series of addition operations.
5477 -- The first operand is the number of single entries that precede this
5478 -- one, the second operand is the index value relative to the start of
5479 -- the referenced family, and the remaining operands are the lengths of
5480 -- the entry families that precede this entry, i.e. the constructed
5483 -- number_simple_entries +
5484 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5485 -- family'length + ...
5487 -- where index-value is the given index value, and s is the index
5488 -- subtype (we have to use pos because the subtype might be an
5489 -- enumeration type preventing direct subtraction). Note that the task
5490 -- entry array is one-indexed.
5492 -- The upper bound of the entry family may be a discriminant, so we
5493 -- retrieve the lower bound explicitly to compute offset, rather than
5494 -- using the index subtype which may mention a discriminant.
5496 if Present (Index) then
5497 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
5505 Make_Attribute_Reference (Sloc,
5506 Attribute_Name => Name_Pos,
5507 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
5508 Expressions => New_List (Relocate_Node (Index))),
5516 -- Now add lengths of preceding entries and entry families
5518 Prev := First_Entity (Ttyp);
5519 while Chars (Prev) /= Chars (Ent)
5520 or else (Ekind (Prev) /= Ekind (Ent))
5521 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
5523 if Ekind (Prev) = E_Entry then
5524 Set_Intval (Num, Intval (Num) + 1);
5526 elsif Ekind (Prev) = E_Entry_Family then
5527 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
5528 Lo := Type_Low_Bound (S);
5529 Hi := Type_High_Bound (S);
5534 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
5536 -- Other components are anonymous types to be ignored
5546 end Entry_Index_Expression;
5548 ---------------------------
5549 -- Establish_Task_Master --
5550 ---------------------------
5552 procedure Establish_Task_Master (N : Node_Id) is
5556 if Restriction_Active (No_Task_Hierarchy) = False then
5557 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
5559 -- The block may have no declarations (and nevertheless be a task
5560 -- master) if it contains a call that may return an object that
5563 if No (Declarations (N)) then
5564 Set_Declarations (N, New_List (Call));
5566 Prepend_To (Declarations (N), Call);
5571 end Establish_Task_Master;
5573 --------------------------------
5574 -- Expand_Accept_Declarations --
5575 --------------------------------
5577 -- Part of the expansion of an accept statement involves the creation of
5578 -- a declaration that can be referenced from the statement sequence of
5583 -- This declaration is inserted immediately before the accept statement
5584 -- and it is important that it be inserted before the statements of the
5585 -- statement sequence are analyzed. Thus it would be too late to create
5586 -- this declaration in the Expand_N_Accept_Statement routine, which is
5587 -- why there is a separate procedure to be called directly from Sem_Ch9.
5589 -- Ann is used to hold the address of the record containing the parameters
5590 -- (see Expand_N_Entry_Call for more details on how this record is built).
5591 -- References to the parameters do an unchecked conversion of this address
5592 -- to a pointer to the required record type, and then access the field that
5593 -- holds the value of the required parameter. The entity for the address
5594 -- variable is held as the top stack element (i.e. the last element) of the
5595 -- Accept_Address stack in the corresponding entry entity, and this element
5596 -- must be set in place before the statements are processed.
5598 -- The above description applies to the case of a stand alone accept
5599 -- statement, i.e. one not appearing as part of a select alternative.
5601 -- For the case of an accept that appears as part of a select alternative
5602 -- of a selective accept, we must still create the declaration right away,
5603 -- since Ann is needed immediately, but there is an important difference:
5605 -- The declaration is inserted before the selective accept, not before
5606 -- the accept statement (which is not part of a list anyway, and so would
5607 -- not accommodate inserted declarations)
5609 -- We only need one address variable for the entire selective accept. So
5610 -- the Ann declaration is created only for the first accept alternative,
5611 -- and subsequent accept alternatives reference the same Ann variable.
5613 -- We can distinguish the two cases by seeing whether the accept statement
5614 -- is part of a list. If not, then it must be in an accept alternative.
5616 -- To expand the requeue statement, a label is provided at the end of the
5617 -- accept statement or alternative of which it is a part, so that the
5618 -- statement can be skipped after the requeue is complete. This label is
5619 -- created here rather than during the expansion of the accept statement,
5620 -- because it will be needed by any requeue statements within the accept,
5621 -- which are expanded before the accept.
5623 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
5624 Loc : constant Source_Ptr := Sloc (N);
5625 Stats : constant Node_Id := Handled_Statement_Sequence (N);
5626 Ann : Entity_Id := Empty;
5633 if Expander_Active then
5635 -- If we have no handled statement sequence, we may need to build
5636 -- a dummy sequence consisting of a null statement. This can be
5637 -- skipped if the trivial accept optimization is permitted.
5639 if not Trivial_Accept_OK
5640 and then (No (Stats) or else Null_Statements (Statements (Stats)))
5642 Set_Handled_Statement_Sequence (N,
5643 Make_Handled_Sequence_Of_Statements (Loc,
5644 Statements => New_List (Make_Null_Statement (Loc))));
5647 -- Create and declare two labels to be placed at the end of the
5648 -- accept statement. The first label is used to allow requeues to
5649 -- skip the remainder of entry processing. The second label is used
5650 -- to skip the remainder of entry processing if the rendezvous
5651 -- completes in the middle of the accept body.
5653 if Present (Handled_Statement_Sequence (N)) then
5658 Ent := Make_Temporary (Loc, 'L');
5659 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5661 Make_Implicit_Label_Declaration (Loc,
5662 Defining_Identifier => Ent,
5663 Label_Construct => Lab);
5664 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5666 Ent := Make_Temporary (Loc, 'L');
5667 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
5669 Make_Implicit_Label_Declaration (Loc,
5670 Defining_Identifier => Ent,
5671 Label_Construct => Lab);
5672 Append (Lab, Statements (Handled_Statement_Sequence (N)));
5680 -- Case of stand alone accept statement
5682 if Is_List_Member (N) then
5684 if Present (Handled_Statement_Sequence (N)) then
5685 Ann := Make_Temporary (Loc, 'A');
5688 Make_Object_Declaration (Loc,
5689 Defining_Identifier => Ann,
5690 Object_Definition =>
5691 New_Occurrence_Of (RTE (RE_Address), Loc));
5693 Insert_Before_And_Analyze (N, Adecl);
5694 Insert_Before_And_Analyze (N, Ldecl);
5695 Insert_Before_And_Analyze (N, Ldecl2);
5698 -- Case of accept statement which is in an accept alternative
5702 Acc_Alt : constant Node_Id := Parent (N);
5703 Sel_Acc : constant Node_Id := Parent (Acc_Alt);
5707 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
5708 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
5710 -- ??? Consider a single label for select statements
5712 if Present (Handled_Statement_Sequence (N)) then
5714 Statements (Handled_Statement_Sequence (N)));
5718 Statements (Handled_Statement_Sequence (N)));
5722 -- Find first accept alternative of the selective accept. A
5723 -- valid selective accept must have at least one accept in it.
5725 Alt := First (Select_Alternatives (Sel_Acc));
5727 while Nkind (Alt) /= N_Accept_Alternative loop
5731 -- If this is the first accept statement, then we have to
5732 -- create the Ann variable, as for the stand alone case, except
5733 -- that it is inserted before the selective accept. Similarly,
5734 -- a label for requeue expansion must be declared.
5736 if N = Accept_Statement (Alt) then
5737 Ann := Make_Temporary (Loc, 'A');
5739 Make_Object_Declaration (Loc,
5740 Defining_Identifier => Ann,
5741 Object_Definition =>
5742 New_Occurrence_Of (RTE (RE_Address), Loc));
5744 Insert_Before_And_Analyze (Sel_Acc, Adecl);
5746 -- If this is not the first accept statement, then find the Ann
5747 -- variable allocated by the first accept and use it.
5751 Node (Last_Elmt (Accept_Address
5752 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
5757 -- Merge here with Ann either created or referenced, and Adecl
5758 -- pointing to the corresponding declaration. Remaining processing
5759 -- is the same for the two cases.
5761 if Present (Ann) then
5762 Append_Elmt (Ann, Accept_Address (Ent));
5763 Set_Debug_Info_Needed (Ann);
5766 -- Create renaming declarations for the entry formals. Each reference
5767 -- to a formal becomes a dereference of a component of the parameter
5768 -- block, whose address is held in Ann. These declarations are
5769 -- eventually inserted into the accept block, and analyzed there so
5770 -- that they have the proper scope for gdb and do not conflict with
5771 -- other declarations.
5773 if Present (Parameter_Specifications (N))
5774 and then Present (Handled_Statement_Sequence (N))
5781 Renamed_Formal : Node_Id;
5785 Formal := First_Formal (Ent);
5787 while Present (Formal) loop
5788 Comp := Entry_Component (Formal);
5789 New_F := Make_Defining_Identifier (Loc, Chars (Formal));
5791 Set_Etype (New_F, Etype (Formal));
5792 Set_Scope (New_F, Ent);
5794 -- Now we set debug info needed on New_F even though it does
5795 -- not come from source, so that the debugger will get the
5796 -- right information for these generated names.
5798 Set_Debug_Info_Needed (New_F);
5800 if Ekind (Formal) = E_In_Parameter then
5801 Set_Ekind (New_F, E_Constant);
5803 Set_Ekind (New_F, E_Variable);
5804 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
5807 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
5810 Make_Selected_Component (Loc,
5812 Unchecked_Convert_To (
5813 Entry_Parameters_Type (Ent),
5814 New_Occurrence_Of (Ann, Loc)),
5816 New_Occurrence_Of (Comp, Loc));
5819 Build_Renamed_Formal_Declaration
5820 (New_F, Formal, Comp, Renamed_Formal);
5822 if No (Declarations (N)) then
5823 Set_Declarations (N, New_List);
5826 Append (Decl, Declarations (N));
5827 Set_Renamed_Object (Formal, New_F);
5828 Next_Formal (Formal);
5835 end Expand_Accept_Declarations;
5837 ---------------------------------------------
5838 -- Expand_Access_Protected_Subprogram_Type --
5839 ---------------------------------------------
5841 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
5842 Loc : constant Source_Ptr := Sloc (N);
5843 T : constant Entity_Id := Defining_Identifier (N);
5844 D_T : constant Entity_Id := Designated_Type (T);
5845 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D');
5846 E_T : constant Entity_Id := Make_Temporary (Loc, 'E');
5847 P_List : constant List_Id :=
5848 Build_Protected_Spec (N, RTE (RE_Address), D_T, False);
5856 -- Create access to subprogram with full signature
5858 if Etype (D_T) /= Standard_Void_Type then
5860 Make_Access_Function_Definition (Loc,
5861 Parameter_Specifications => P_List,
5862 Result_Definition =>
5863 Copy_Result_Type (Result_Definition (Type_Definition (N))));
5867 Make_Access_Procedure_Definition (Loc,
5868 Parameter_Specifications => P_List);
5872 Make_Full_Type_Declaration (Loc,
5873 Defining_Identifier => D_T2,
5874 Type_Definition => Def1);
5876 -- Declare the new types before the original one since the latter will
5877 -- refer to them through the Equivalent_Type slot.
5879 Insert_Before_And_Analyze (N, Decl1);
5881 -- Associate the access to subprogram with its original access to
5882 -- protected subprogram type. Needed by the backend to know that this
5883 -- type corresponds with an access to protected subprogram type.
5885 Set_Original_Access_Type (D_T2, T);
5887 -- Create Equivalent_Type, a record with two components for an access to
5888 -- object and an access to subprogram.
5891 Make_Component_Declaration (Loc,
5892 Defining_Identifier => Make_Temporary (Loc, 'P'),
5893 Component_Definition =>
5894 Make_Component_Definition (Loc,
5895 Aliased_Present => False,
5896 Subtype_Indication =>
5897 New_Occurrence_Of (RTE (RE_Address), Loc))),
5899 Make_Component_Declaration (Loc,
5900 Defining_Identifier => Make_Temporary (Loc, 'S'),
5901 Component_Definition =>
5902 Make_Component_Definition (Loc,
5903 Aliased_Present => False,
5904 Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
5907 Make_Full_Type_Declaration (Loc,
5908 Defining_Identifier => E_T,
5910 Make_Record_Definition (Loc,
5912 Make_Component_List (Loc, Component_Items => Comps)));
5914 Insert_Before_And_Analyze (N, Decl2);
5915 Set_Equivalent_Type (T, E_T);
5916 end Expand_Access_Protected_Subprogram_Type;
5918 --------------------------
5919 -- Expand_Entry_Barrier --
5920 --------------------------
5922 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
5923 Cond : constant Node_Id :=
5924 Condition (Entry_Body_Formal_Part (N));
5925 Prot : constant Entity_Id := Scope (Ent);
5926 Spec_Decl : constant Node_Id := Parent (Prot);
5927 Func : Entity_Id := Empty;
5929 Body_Decl : Node_Id;
5931 function Is_Global_Entity (N : Node_Id) return Traverse_Result;
5932 -- Check whether entity in Barrier is external to protected type.
5933 -- If so, barrier may not be properly synchronized.
5935 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
5936 -- Check whether N follows the Pure_Barriers restriction. Return OK if
5939 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean;
5940 -- Check whether entity name N denotes a component of the protected
5941 -- object. This is used to check the Simple_Barrier restriction.
5943 ----------------------
5944 -- Is_Global_Entity --
5945 ----------------------
5947 function Is_Global_Entity (N : Node_Id) return Traverse_Result is
5952 if Is_Entity_Name (N) and then Present (Entity (N)) then
5956 if Ekind (E) = E_Variable then
5958 -- If the variable is local to the barrier function generated
5959 -- during expansion, it is ok. If expansion is not performed,
5960 -- then Func is Empty so this test cannot succeed.
5962 if Scope (E) = Func then
5965 -- A protected call from a barrier to another object is ok
5967 elsif Ekind (Etype (E)) = E_Protected_Type then
5970 -- If the variable is within the package body we consider
5971 -- this safe. This is a common (if dubious) idiom.
5973 elsif S = Scope (Prot)
5974 and then Ekind_In (S, E_Package, E_Generic_Package)
5975 and then Nkind (Parent (E)) = N_Object_Declaration
5976 and then Nkind (Parent (Parent (E))) = N_Package_Body
5981 Error_Msg_N ("potentially unsynchronized barrier??", N);
5982 Error_Msg_N ("\& should be private component of type??", N);
5988 end Is_Global_Entity;
5990 procedure Check_Unprotected_Barrier is
5991 new Traverse_Proc (Is_Global_Entity);
5993 ----------------------------
5994 -- Is_Simple_Barrier_Name --
5995 ----------------------------
5997 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
6001 -- Check for case of _object.all.field (note that the explicit
6002 -- dereference gets inserted by analyze/expand of _object.field).
6004 if Expander_Active then
6005 Renamed := Renamed_Object (Entity (N));
6009 and then Nkind (Renamed) = N_Selected_Component
6010 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
6012 return Scope (Entity (N)) = Current_Scope;
6014 end Is_Simple_Barrier_Name;
6016 ---------------------
6017 -- Is_Pure_Barrier --
6018 ---------------------
6020 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
6023 when N_Expanded_Name |
6025 if No (Entity (N)) then
6029 case Ekind (Entity (N)) is
6034 E_Enumeration_Literal =>
6040 -- A variable in the protected type is expanded as a
6043 if Is_Simple_Barrier_Name (N) then
6051 when N_Integer_Literal |
6053 N_Character_Literal =>
6058 if Ekind (Entity (N)) = E_Operator then
6062 when N_Short_Circuit =>
6070 end Is_Pure_Barrier;
6072 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier);
6074 -- Start of processing for Expand_Entry_Barrier
6077 if No_Run_Time_Mode then
6078 Error_Msg_CRT ("entry barrier", N);
6082 -- The body of the entry barrier must be analyzed in the context of the
6083 -- protected object, but its scope is external to it, just as any other
6084 -- unprotected version of a protected operation. The specification has
6085 -- been produced when the protected type declaration was elaborated. We
6086 -- build the body, insert it in the enclosing scope, but analyze it in
6087 -- the current context. A more uniform approach would be to treat the
6088 -- barrier just as a protected function, and discard the protected
6089 -- version of it because it is never called.
6091 if Expander_Active then
6092 B_F := Build_Barrier_Function (N, Ent, Prot);
6093 Func := Barrier_Function (Ent);
6094 Set_Corresponding_Spec (B_F, Func);
6096 Body_Decl := Parent (Corresponding_Body (Spec_Decl));
6098 if Nkind (Parent (Body_Decl)) = N_Subunit then
6099 Body_Decl := Corresponding_Stub (Parent (Body_Decl));
6102 Insert_Before_And_Analyze (Body_Decl, B_F);
6104 Set_Discriminals (Spec_Decl);
6105 Set_Scope (Func, Scope (Prot));
6108 Analyze_And_Resolve (Cond, Any_Boolean);
6111 -- Check Pure_Barriers restriction
6113 if Check_Pure_Barriers (Cond) = Abandon then
6114 Check_Restriction (Pure_Barriers, Cond);
6117 -- The Ravenscar profile restricts barriers to simple variables declared
6118 -- within the protected object. We also allow Boolean constants, since
6119 -- these appear in several published examples and are also allowed by
6122 -- Note that after analysis variables in this context will be replaced
6123 -- by the corresponding prival, that is to say a renaming of a selected
6124 -- component of the form _Object.Var. If expansion is disabled, as
6125 -- within a generic, we check that the entity appears in the current
6128 if Is_Entity_Name (Cond) then
6130 -- A small optimization of useless renamings. If the scope of the
6131 -- entity of the condition is not the barrier function, then the
6132 -- condition does not reference any of the generated renamings
6133 -- within the function.
6135 if Expander_Active and then Scope (Entity (Cond)) /= Func then
6136 Set_Declarations (B_F, Empty_List);
6139 if Entity (Cond) = Standard_False
6141 Entity (Cond) = Standard_True
6145 elsif Is_Simple_Barrier_Name (Cond) then
6150 -- It is not a boolean variable or literal, so check the restriction.
6151 -- Note that it is safe to be calling Check_Restriction from here, even
6152 -- though this is part of the expander, since Expand_Entry_Barrier is
6153 -- called from Sem_Ch9 even in -gnatc mode.
6155 Check_Restriction (Simple_Barriers, Cond);
6157 -- Emit warning if barrier contains global entities and is thus
6158 -- potentially unsynchronized.
6160 Check_Unprotected_Barrier (Cond);
6161 end Expand_Entry_Barrier;
6163 ------------------------------
6164 -- Expand_N_Abort_Statement --
6165 ------------------------------
6167 -- Expand abort T1, T2, .. Tn; into:
6168 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6170 procedure Expand_N_Abort_Statement (N : Node_Id) is
6171 Loc : constant Source_Ptr := Sloc (N);
6172 Tlist : constant List_Id := Names (N);
6178 Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
6181 Tasknm := First (Tlist);
6183 while Present (Tasknm) loop
6186 -- A task interface class-wide type object is being aborted. Retrieve
6187 -- its _task_id by calling a dispatching routine.
6189 if Ada_Version >= Ada_2005
6190 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
6191 and then Is_Interface (Etype (Tasknm))
6192 and then Is_Task_Interface (Etype (Tasknm))
6194 Append_To (Component_Associations (Aggr),
6195 Make_Component_Association (Loc,
6196 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6199 -- Task_Id (Tasknm._disp_get_task_id)
6201 Make_Unchecked_Type_Conversion (Loc,
6203 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6205 Make_Selected_Component (Loc,
6206 Prefix => New_Copy_Tree (Tasknm),
6208 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
6211 Append_To (Component_Associations (Aggr),
6212 Make_Component_Association (Loc,
6213 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6214 Expression => Concurrent_Ref (Tasknm)));
6221 Make_Procedure_Call_Statement (Loc,
6222 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc),
6223 Parameter_Associations => New_List (
6224 Make_Qualified_Expression (Loc,
6225 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc),
6226 Expression => Aggr))));
6229 end Expand_N_Abort_Statement;
6231 -------------------------------
6232 -- Expand_N_Accept_Statement --
6233 -------------------------------
6235 -- This procedure handles expansion of accept statements that stand alone,
6236 -- i.e. they are not part of an accept alternative. The expansion of
6237 -- accept statement in accept alternatives is handled by the routines
6238 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6239 -- following description applies only to stand alone accept statements.
6241 -- If there is no handled statement sequence, or only null statements, then
6242 -- this is called a trivial accept, and the expansion is:
6244 -- Accept_Trivial (entry-index)
6246 -- If there is a handled statement sequence, then the expansion is:
6253 -- Accept_Call (entry-index, Ann);
6254 -- Renaming_Declarations for formals
6255 -- <statement sequence from N_Accept_Statement node>
6256 -- Complete_Rendezvous;
6261 -- <exception handler from N_Accept_Statement node>
6262 -- Complete_Rendezvous;
6264 -- <exception handler from N_Accept_Statement node>
6265 -- Complete_Rendezvous;
6270 -- when all others =>
6271 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6274 -- The first three declarations were already inserted ahead of the accept
6275 -- statement by the Expand_Accept_Declarations procedure, which was called
6276 -- directly from the semantics during analysis of the accept statement,
6277 -- before analyzing its contained statements.
6279 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6280 -- from possible expansion activity (the original source of course does
6281 -- not have any declarations associated with the accept statement, since
6282 -- an accept statement has no declarative part). In particular, if the
6283 -- expander is active, the first such declaration is the declaration of
6284 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6286 -- The two blocks are merged into a single block if the inner block has
6287 -- no exception handlers, but otherwise two blocks are required, since
6288 -- exceptions might be raised in the exception handlers of the inner
6289 -- block, and Exceptional_Complete_Rendezvous must be called.
6291 procedure Expand_N_Accept_Statement (N : Node_Id) is
6292 Loc : constant Source_Ptr := Sloc (N);
6293 Stats : constant Node_Id := Handled_Statement_Sequence (N);
6294 Ename : constant Node_Id := Entry_Direct_Name (N);
6295 Eindx : constant Node_Id := Entry_Index (N);
6296 Eent : constant Entity_Id := Entity (Ename);
6297 Acstack : constant Elist_Id := Accept_Address (Eent);
6298 Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
6299 Ttyp : constant Entity_Id := Etype (Scope (Eent));
6305 -- If the accept statement is not part of a list, then its parent must
6306 -- be an accept alternative, and, as described above, we do not do any
6307 -- expansion for such accept statements at this level.
6309 if not Is_List_Member (N) then
6310 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
6313 -- Trivial accept case (no statement sequence, or null statements).
6314 -- If the accept statement has declarations, then just insert them
6315 -- before the procedure call.
6317 elsif Trivial_Accept_OK
6318 and then (No (Stats) or else Null_Statements (Statements (Stats)))
6320 -- Remove declarations for renamings, because the parameter block
6321 -- will not be assigned.
6328 D := First (Declarations (N));
6329 while Present (D) loop
6331 if Nkind (D) = N_Object_Renaming_Declaration then
6339 if Present (Declarations (N)) then
6340 Insert_Actions (N, Declarations (N));
6344 Make_Procedure_Call_Statement (Loc,
6345 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc),
6346 Parameter_Associations => New_List (
6347 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
6351 -- Discard Entry_Address that was created for it, so it will not be
6352 -- emitted if this accept statement is in the statement part of a
6353 -- delay alternative.
6355 if Present (Stats) then
6356 Remove_Last_Elmt (Acstack);
6359 -- Case of statement sequence present
6362 -- Construct the block, using the declarations from the accept
6363 -- statement if any to initialize the declarations of the block.
6365 Blkent := Make_Temporary (Loc, 'A');
6366 Set_Ekind (Blkent, E_Block);
6367 Set_Etype (Blkent, Standard_Void_Type);
6368 Set_Scope (Blkent, Current_Scope);
6371 Make_Block_Statement (Loc,
6372 Identifier => New_Occurrence_Of (Blkent, Loc),
6373 Declarations => Declarations (N),
6374 Handled_Statement_Sequence => Build_Accept_Body (N));
6376 -- For the analysis of the generated declarations, the parent node
6377 -- must be properly set.
6379 Set_Parent (Block, Parent (N));
6381 -- Prepend call to Accept_Call to main statement sequence If the
6382 -- accept has exception handlers, the statement sequence is wrapped
6383 -- in a block. Insert call and renaming declarations in the
6384 -- declarations of the block, so they are elaborated before the
6388 Make_Procedure_Call_Statement (Loc,
6389 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc),
6390 Parameter_Associations => New_List (
6391 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
6392 New_Occurrence_Of (Ann, Loc)));
6394 if Parent (Stats) = N then
6395 Prepend (Call, Statements (Stats));
6397 Set_Declarations (Parent (Stats), New_List (Call));
6402 Push_Scope (Blkent);
6410 D := First (Declarations (N));
6411 while Present (D) loop
6414 if Nkind (D) = N_Object_Renaming_Declaration then
6416 -- The renaming declarations for the formals were created
6417 -- during analysis of the accept statement, and attached to
6418 -- the list of declarations. Place them now in the context
6419 -- of the accept block or subprogram.
6422 Typ := Entity (Subtype_Mark (D));
6423 Insert_After (Call, D);
6426 -- If the formal is class_wide, it does not have an actual
6427 -- subtype. The analysis of the renaming declaration creates
6428 -- one, but we need to retain the class-wide nature of the
6431 if Is_Class_Wide_Type (Typ) then
6432 Set_Etype (Defining_Identifier (D), Typ);
6443 -- Replace the accept statement by the new block
6448 -- Last step is to unstack the Accept_Address value
6450 Remove_Last_Elmt (Acstack);
6452 end Expand_N_Accept_Statement;
6454 ----------------------------------
6455 -- Expand_N_Asynchronous_Select --
6456 ----------------------------------
6458 -- This procedure assumes that the trigger statement is an entry call or
6459 -- a dispatching procedure call. A delay alternative should already have
6460 -- been expanded into an entry call to the appropriate delay object Wait
6463 -- If the trigger is a task entry call, the select is implemented with
6464 -- a Task_Entry_Call:
6469 -- P : parms := (parm, parm, parm);
6471 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6473 -- procedure _clean is
6476 -- Cancel_Task_Entry_Call (C);
6483 -- (<acceptor-task>, -- Acceptor
6484 -- <entry-index>, -- E
6485 -- P'Address, -- Uninterpreted_Data
6486 -- Asynchronous_Call, -- Mode
6487 -- B); -- Rendezvous_Successful
6494 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6497 -- when Abort_Signal => Abort_Undefer;
6504 -- <triggered-statements>
6508 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6509 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6513 -- P : parms := (parm, parm, parm);
6515 -- Call_Simple (acceptor-task, entry-index, P'Address);
6521 -- so the task at hand is to convert the latter expansion into the former
6523 -- If the trigger is a protected entry call, the select is implemented
6524 -- with Protected_Entry_Call:
6527 -- P : E1_Params := (param, param, param);
6528 -- Bnn : Communications_Block;
6533 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6535 -- procedure _clean is
6538 -- if Enqueued (Bnn) then
6539 -- Cancel_Protected_Entry_Call (Bnn);
6546 -- Protected_Entry_Call
6547 -- (po._object'Access, -- Object
6548 -- <entry index>, -- E
6549 -- P'Address, -- Uninterpreted_Data
6550 -- Asynchronous_Call, -- Mode
6553 -- if Enqueued (Bnn) then
6557 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6560 -- when Abort_Signal => Abort_Undefer;
6563 -- if not Cancelled (Bnn) then
6564 -- <triggered-statements>
6568 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6572 -- P : E1_Params := (param, param, param);
6573 -- Bnn : Communications_Block;
6576 -- Protected_Entry_Call
6577 -- (po._object'Access, -- Object
6578 -- <entry index>, -- E
6579 -- P'Address, -- Uninterpreted_Data
6580 -- Simple_Call, -- Mode
6587 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6591 -- B : Boolean := False;
6592 -- Bnn : Communication_Block;
6593 -- C : Ada.Tags.Prim_Op_Kind;
6594 -- D : System.Storage_Elements.Dummy_Communication_Block;
6595 -- K : Ada.Tags.Tagged_Kind :=
6596 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6597 -- P : Parameters := (Param1 .. ParamN);
6602 -- if K = Ada.Tags.TK_Limited_Tagged
6603 -- or else K = Ada.Tags.TK_Tagged
6605 -- <dispatching-call>;
6606 -- <triggering-statements>;
6610 -- Ada.Tags.Get_Offset_Index
6611 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6613 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6615 -- if C = POK_Protected_Entry then
6617 -- procedure _clean is
6619 -- if Enqueued (Bnn) then
6620 -- Cancel_Protected_Entry_Call (Bnn);
6626 -- _Disp_Asynchronous_Select
6627 -- (<object>, S, P'Address, D, B);
6628 -- Bnn := Communication_Block (D);
6630 -- Param1 := P.Param1;
6632 -- ParamN := P.ParamN;
6634 -- if Enqueued (Bnn) then
6635 -- <abortable-statements>
6638 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6641 -- when Abort_Signal => Abort_Undefer;
6644 -- if not Cancelled (Bnn) then
6645 -- <triggering-statements>
6648 -- elsif C = POK_Task_Entry then
6650 -- procedure _clean is
6652 -- Cancel_Task_Entry_Call (U);
6658 -- _Disp_Asynchronous_Select
6659 -- (<object>, S, P'Address, D, B);
6660 -- Bnn := Communication_Bloc (D);
6662 -- Param1 := P.Param1;
6664 -- ParamN := P.ParamN;
6669 -- <abortable-statements>
6671 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6674 -- when Abort_Signal => Abort_Undefer;
6678 -- <triggering-statements>
6683 -- <dispatching-call>;
6684 -- <triggering-statements>
6689 -- The job is to convert this to the asynchronous form
6691 -- If the trigger is a delay statement, it will have been expanded into
6692 -- a call to one of the GNARL delay procedures. This routine will convert
6693 -- this into a protected entry call on a delay object and then continue
6694 -- processing as for a protected entry call trigger. This requires
6695 -- declaring a Delay_Block object and adding a pointer to this object to
6696 -- the parameter list of the delay procedure to form the parameter list of
6697 -- the entry call. This object is used by the runtime to queue the delay
6700 -- For a description of the use of P and the assignments after the call,
6701 -- see Expand_N_Entry_Call_Statement.
6703 procedure Expand_N_Asynchronous_Select (N : Node_Id) is
6704 Loc : constant Source_Ptr := Sloc (N);
6705 Abrt : constant Node_Id := Abortable_Part (N);
6706 Trig : constant Node_Id := Triggering_Alternative (N);
6708 Abort_Block_Ent : Entity_Id;
6709 Abortable_Block : Node_Id;
6712 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A');
6713 Blk_Typ : Entity_Id;
6715 Call_Ent : Entity_Id;
6716 Cancel_Param : Entity_Id;
6717 Cleanup_Block : Node_Id;
6718 Cleanup_Block_Ent : Entity_Id;
6719 Cleanup_Stmts : List_Id;
6720 Conc_Typ_Stmts : List_Id;
6722 Dblock_Ent : Entity_Id;
6727 Enqueue_Call : Node_Id;
6730 Handler_Stmt : Node_Id;
6732 Lim_Typ_Stmts : List_Id;
6738 ProtE_Stmts : List_Id;
6739 ProtP_Stmts : List_Id;
6742 TaskE_Stmts : List_Id;
6745 B : Entity_Id; -- Call status flag
6746 Bnn : Entity_Id; -- Communication block
6747 C : Entity_Id; -- Call kind
6748 K : Entity_Id; -- Tagged kind
6749 P : Entity_Id; -- Parameter block
6750 S : Entity_Id; -- Primitive operation slot
6751 T : Entity_Id; -- Additional status flag
6753 procedure Rewrite_Abortable_Part;
6754 -- If the trigger is a dispatching call, the expansion inserts multiple
6755 -- copies of the abortable part. This is both inefficient, and may lead
6756 -- to duplicate definitions that the back-end will reject, when the
6757 -- abortable part includes loops. This procedure rewrites the abortable
6758 -- part into a call to a generated procedure.
6760 ----------------------------
6761 -- Rewrite_Abortable_Part --
6762 ----------------------------
6764 procedure Rewrite_Abortable_Part is
6765 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
6770 Make_Subprogram_Body (Loc,
6772 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
6773 Declarations => New_List,
6774 Handled_Statement_Sequence =>
6775 Make_Handled_Sequence_Of_Statements (Loc, Astats));
6776 Insert_Before (N, Decl);
6779 -- Rewrite abortable part into a call to this procedure.
6783 Make_Procedure_Call_Statement (Loc,
6784 Name => New_Occurrence_Of (Proc, Loc)));
6785 end Rewrite_Abortable_Part;
6787 -- Start of processing for Expand_N_Asynchronous_Select
6790 -- Asynchronous select is not supported on restricted runtimes. Don't
6793 if Restricted_Profile then
6797 Process_Statements_For_Controlled_Objects (Trig);
6798 Process_Statements_For_Controlled_Objects (Abrt);
6800 Ecall := Triggering_Statement (Trig);
6802 Ensure_Statement_Present (Sloc (Ecall), Trig);
6804 -- Retrieve Astats and Tstats now because the finalization machinery may
6805 -- wrap them in blocks.
6807 Astats := Statements (Abrt);
6808 Tstats := Statements (Trig);
6810 -- The arguments in the call may require dynamic allocation, and the
6811 -- call statement may have been transformed into a block. The block
6812 -- may contain additional declarations for internal entities, and the
6813 -- original call is found by sequential search.
6815 if Nkind (Ecall) = N_Block_Statement then
6816 Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
6817 while not Nkind_In (Ecall, N_Procedure_Call_Statement,
6818 N_Entry_Call_Statement)
6824 -- This is either a dispatching call or a delay statement used as a
6825 -- trigger which was expanded into a procedure call.
6827 if Nkind (Ecall) = N_Procedure_Call_Statement then
6828 if Ada_Version >= Ada_2005
6830 (No (Original_Node (Ecall))
6831 or else not Nkind_In (Original_Node (Ecall),
6832 N_Delay_Relative_Statement,
6833 N_Delay_Until_Statement))
6835 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
6837 Rewrite_Abortable_Part;
6841 -- Call status flag processing, generate:
6842 -- B : Boolean := False;
6844 B := Build_B (Loc, Decls);
6846 -- Communication block processing, generate:
6847 -- Bnn : Communication_Block;
6849 Bnn := Make_Temporary (Loc, 'B');
6851 Make_Object_Declaration (Loc,
6852 Defining_Identifier => Bnn,
6853 Object_Definition =>
6854 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
6856 -- Call kind processing, generate:
6857 -- C : Ada.Tags.Prim_Op_Kind;
6859 C := Build_C (Loc, Decls);
6861 -- Tagged kind processing, generate:
6862 -- K : Ada.Tags.Tagged_Kind :=
6863 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6865 -- Dummy communication block, generate:
6866 -- D : Dummy_Communication_Block;
6869 Make_Object_Declaration (Loc,
6870 Defining_Identifier =>
6871 Make_Defining_Identifier (Loc, Name_uD),
6872 Object_Definition =>
6874 (RTE (RE_Dummy_Communication_Block), Loc)));
6876 K := Build_K (Loc, Decls, Obj);
6878 -- Parameter block processing
6880 Blk_Typ := Build_Parameter_Block
6881 (Loc, Actuals, Formals, Decls);
6882 P := Parameter_Block_Pack
6883 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
6885 -- Dispatch table slot processing, generate:
6888 S := Build_S (Loc, Decls);
6890 -- Additional status flag processing, generate:
6893 T := Make_Temporary (Loc, 'T');
6895 Make_Object_Declaration (Loc,
6896 Defining_Identifier => T,
6897 Object_Definition =>
6898 New_Occurrence_Of (Standard_Boolean, Loc)));
6900 ------------------------------
6901 -- Protected entry handling --
6902 ------------------------------
6905 -- Param1 := P.Param1;
6907 -- ParamN := P.ParamN;
6909 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
6912 -- Bnn := Communication_Block (D);
6914 Prepend_To (Cleanup_Stmts,
6915 Make_Assignment_Statement (Loc,
6916 Name => New_Occurrence_Of (Bnn, Loc),
6918 Make_Unchecked_Type_Conversion (Loc,
6920 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
6921 Expression => Make_Identifier (Loc, Name_uD))));
6924 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
6926 Prepend_To (Cleanup_Stmts,
6927 Make_Procedure_Call_Statement (Loc,
6931 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select),
6933 Parameter_Associations =>
6935 New_Copy_Tree (Obj), -- <object>
6936 New_Occurrence_Of (S, Loc), -- S
6937 Make_Attribute_Reference (Loc, -- P'Address
6938 Prefix => New_Occurrence_Of (P, Loc),
6939 Attribute_Name => Name_Address),
6940 Make_Identifier (Loc, Name_uD), -- D
6941 New_Occurrence_Of (B, Loc)))); -- B
6944 -- if Enqueued (Bnn) then
6945 -- <abortable-statements>
6948 Append_To (Cleanup_Stmts,
6949 Make_Implicit_If_Statement (N,
6951 Make_Function_Call (Loc,
6953 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
6954 Parameter_Associations =>
6955 New_List (New_Occurrence_Of (Bnn, Loc))),
6958 New_Copy_List_Tree (Astats)));
6960 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
6961 -- will then generate a _clean for the communication block Bnn.
6965 -- procedure _clean is
6967 -- if Enqueued (Bnn) then
6968 -- Cancel_Protected_Entry_Call (Bnn);
6977 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
6979 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
6981 -- Wrap the cleanup block in an exception handling block
6987 -- when Abort_Signal => Abort_Undefer;
6990 Abort_Block_Ent := Make_Temporary (Loc, 'A');
6993 Make_Implicit_Label_Declaration (Loc,
6994 Defining_Identifier => Abort_Block_Ent),
6997 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7000 -- if not Cancelled (Bnn) then
7001 -- <triggering-statements>
7004 Append_To (ProtE_Stmts,
7005 Make_Implicit_If_Statement (N,
7009 Make_Function_Call (Loc,
7011 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7012 Parameter_Associations =>
7013 New_List (New_Occurrence_Of (Bnn, Loc)))),
7016 New_Copy_List_Tree (Tstats)));
7018 -------------------------
7019 -- Task entry handling --
7020 -------------------------
7023 -- Param1 := P.Param1;
7025 -- ParamN := P.ParamN;
7027 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7030 -- Bnn := Communication_Block (D);
7032 Append_To (TaskE_Stmts,
7033 Make_Assignment_Statement (Loc,
7035 New_Occurrence_Of (Bnn, Loc),
7037 Make_Unchecked_Type_Conversion (Loc,
7039 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7040 Expression => Make_Identifier (Loc, Name_uD))));
7043 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7045 Prepend_To (TaskE_Stmts,
7046 Make_Procedure_Call_Statement (Loc,
7049 Find_Prim_Op (Etype (Etype (Obj)),
7050 Name_uDisp_Asynchronous_Select),
7053 Parameter_Associations => New_List (
7054 New_Copy_Tree (Obj), -- <object>
7055 New_Occurrence_Of (S, Loc), -- S
7056 Make_Attribute_Reference (Loc, -- P'Address
7057 Prefix => New_Occurrence_Of (P, Loc),
7058 Attribute_Name => Name_Address),
7059 Make_Identifier (Loc, Name_uD), -- D
7060 New_Occurrence_Of (B, Loc)))); -- B
7065 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7069 -- <abortable-statements>
7071 Cleanup_Stmts := New_Copy_List_Tree (Astats);
7074 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7076 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7077 -- will generate a _clean for the additional status flag.
7081 -- procedure _clean is
7083 -- Cancel_Task_Entry_Call (U);
7091 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7093 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
7095 -- Wrap the cleanup block in an exception handling block
7101 -- when Abort_Signal => Abort_Undefer;
7104 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7106 Append_To (TaskE_Stmts,
7107 Make_Implicit_Label_Declaration (Loc,
7108 Defining_Identifier => Abort_Block_Ent));
7110 Append_To (TaskE_Stmts,
7112 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7116 -- <triggering-statements>
7119 Append_To (TaskE_Stmts,
7120 Make_Implicit_If_Statement (N,
7122 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)),
7125 New_Copy_List_Tree (Tstats)));
7127 ----------------------------------
7128 -- Protected procedure handling --
7129 ----------------------------------
7132 -- <dispatching-call>;
7133 -- <triggering-statements>
7135 ProtP_Stmts := New_Copy_List_Tree (Tstats);
7136 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
7139 -- S := Ada.Tags.Get_Offset_Index
7140 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7143 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
7146 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7148 Append_To (Conc_Typ_Stmts,
7149 Make_Procedure_Call_Statement (Loc,
7152 (Find_Prim_Op (Etype (Etype (Obj)),
7153 Name_uDisp_Get_Prim_Op_Kind),
7155 Parameter_Associations =>
7157 New_Copy_Tree (Obj),
7158 New_Occurrence_Of (S, Loc),
7159 New_Occurrence_Of (C, Loc))));
7162 -- if C = POK_Procedure_Entry then
7164 -- elsif C = POK_Task_Entry then
7170 Append_To (Conc_Typ_Stmts,
7171 Make_Implicit_If_Statement (N,
7175 New_Occurrence_Of (C, Loc),
7177 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
7184 Make_Elsif_Part (Loc,
7188 New_Occurrence_Of (C, Loc),
7190 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)),
7199 -- <dispatching-call>;
7200 -- <triggering-statements>
7202 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
7203 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
7206 -- if K = Ada.Tags.TK_Limited_Tagged
7207 -- or else K = Ada.Tags.TK_Tagged
7215 Make_Implicit_If_Statement (N,
7216 Condition => Build_Dispatching_Tag_Check (K, N),
7217 Then_Statements => Lim_Typ_Stmts,
7218 Else_Statements => Conc_Typ_Stmts));
7221 Make_Block_Statement (Loc,
7224 Handled_Statement_Sequence =>
7225 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7230 -- Delay triggering statement processing
7233 -- Add a Delay_Block object to the parameter list of the delay
7234 -- procedure to form the parameter list of the Wait entry call.
7236 Dblock_Ent := Make_Temporary (Loc, 'D');
7238 Pdef := Entity (Name (Ecall));
7240 if Is_RTE (Pdef, RO_CA_Delay_For) then
7242 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc);
7244 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
7246 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc);
7248 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
7249 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc);
7252 Append_To (Parameter_Associations (Ecall),
7253 Make_Attribute_Reference (Loc,
7254 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7255 Attribute_Name => Name_Unchecked_Access));
7257 -- Create the inner block to protect the abortable part
7259 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7261 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7264 Make_Block_Statement (Loc,
7265 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7266 Handled_Statement_Sequence =>
7267 Make_Handled_Sequence_Of_Statements (Loc,
7268 Statements => Astats),
7269 Has_Created_Identifier => True,
7270 Is_Asynchronous_Call_Block => True);
7272 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7275 Make_Implicit_If_Statement (N,
7277 Make_Function_Call (Loc,
7278 Name => Enqueue_Call,
7279 Parameter_Associations => Parameter_Associations (Ecall)),
7281 New_List (Make_Block_Statement (Loc,
7282 Handled_Statement_Sequence =>
7283 Make_Handled_Sequence_Of_Statements (Loc,
7284 Statements => New_List (
7285 Make_Implicit_Label_Declaration (Loc,
7286 Defining_Identifier => Blk_Ent,
7287 Label_Construct => Abortable_Block),
7289 Exception_Handlers => Hdle)))));
7291 Stmts := New_List (Ecall);
7293 -- Construct statement sequence for new block
7296 Make_Implicit_If_Statement (N,
7298 Make_Function_Call (Loc,
7299 Name => New_Occurrence_Of (
7300 RTE (RE_Timed_Out), Loc),
7301 Parameter_Associations => New_List (
7302 Make_Attribute_Reference (Loc,
7303 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7304 Attribute_Name => Name_Unchecked_Access))),
7305 Then_Statements => Tstats));
7307 -- The result is the new block
7309 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
7312 Make_Block_Statement (Loc,
7313 Declarations => New_List (
7314 Make_Object_Declaration (Loc,
7315 Defining_Identifier => Dblock_Ent,
7316 Aliased_Present => True,
7317 Object_Definition =>
7318 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))),
7320 Handled_Statement_Sequence =>
7321 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7331 Extract_Entry (Ecall, Concval, Ename, Index);
7332 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
7334 Stmts := Statements (Handled_Statement_Sequence (Ecall));
7335 Decls := Declarations (Ecall);
7337 if Is_Protected_Type (Etype (Concval)) then
7339 -- Get the declarations of the block expanded from the entry call
7341 Decl := First (Decls);
7342 while Present (Decl)
7343 and then (Nkind (Decl) /= N_Object_Declaration
7344 or else not Is_RTE (Etype (Object_Definition (Decl)),
7345 RE_Communication_Block))
7350 pragma Assert (Present (Decl));
7351 Cancel_Param := Defining_Identifier (Decl);
7353 -- Change the mode of the Protected_Entry_Call call
7355 -- Protected_Entry_Call (
7356 -- Object => po._object'Access,
7357 -- E => <entry index>;
7358 -- Uninterpreted_Data => P'Address;
7359 -- Mode => Asynchronous_Call;
7362 -- Skip assignments to temporaries created for in-out parameters
7364 -- This makes unwarranted assumptions about the shape of the expanded
7365 -- tree for the call, and should be cleaned up ???
7367 Stmt := First (Stmts);
7368 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7374 Param := First (Parameter_Associations (Call));
7375 while Present (Param)
7376 and then not Is_RTE (Etype (Param), RE_Call_Modes)
7381 pragma Assert (Present (Param));
7382 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7385 -- Append an if statement to execute the abortable part
7388 -- if Enqueued (Bnn) then
7391 Make_Implicit_If_Statement (N,
7393 Make_Function_Call (Loc,
7394 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7395 Parameter_Associations => New_List (
7396 New_Occurrence_Of (Cancel_Param, Loc))),
7397 Then_Statements => Astats));
7400 Make_Block_Statement (Loc,
7401 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7402 Handled_Statement_Sequence =>
7403 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts),
7404 Has_Created_Identifier => True,
7405 Is_Asynchronous_Call_Block => True);
7407 -- Aborts are not deferred at beginning of exception handlers in
7410 if ZCX_Exceptions then
7411 Handler_Stmt := Make_Null_Statement (Loc);
7414 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer);
7418 Make_Block_Statement (Loc,
7419 Handled_Statement_Sequence =>
7420 Make_Handled_Sequence_Of_Statements (Loc,
7421 Statements => New_List (
7422 Make_Implicit_Label_Declaration (Loc,
7423 Defining_Identifier => Blk_Ent,
7424 Label_Construct => Abortable_Block),
7429 Exception_Handlers => New_List (
7430 Make_Implicit_Exception_Handler (Loc,
7432 -- when Abort_Signal =>
7433 -- Abort_Undefer.all;
7435 Exception_Choices =>
7436 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
7437 Statements => New_List (Handler_Stmt))))),
7439 -- if not Cancelled (Bnn) then
7440 -- triggered statements
7443 Make_Implicit_If_Statement (N,
7444 Condition => Make_Op_Not (Loc,
7446 Make_Function_Call (Loc,
7447 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7448 Parameter_Associations => New_List (
7449 New_Occurrence_Of (Cancel_Param, Loc)))),
7450 Then_Statements => Tstats));
7452 -- Asynchronous task entry call
7459 B := Make_Defining_Identifier (Loc, Name_uB);
7461 -- Insert declaration of B in declarations of existing block
7464 Make_Object_Declaration (Loc,
7465 Defining_Identifier => B,
7466 Object_Definition =>
7467 New_Occurrence_Of (Standard_Boolean, Loc)));
7469 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
7471 -- Insert declaration of C in declarations of existing block
7474 Make_Object_Declaration (Loc,
7475 Defining_Identifier => Cancel_Param,
7476 Object_Definition =>
7477 New_Occurrence_Of (Standard_Boolean, Loc)));
7479 -- Remove and save the call to Call_Simple
7481 Stmt := First (Stmts);
7483 -- Skip assignments to temporaries created for in-out parameters.
7484 -- This makes unwarranted assumptions about the shape of the expanded
7485 -- tree for the call, and should be cleaned up ???
7487 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7493 -- Create the inner block to protect the abortable part
7495 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7497 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7500 Make_Block_Statement (Loc,
7501 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7502 Handled_Statement_Sequence =>
7503 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats),
7504 Has_Created_Identifier => True,
7505 Is_Asynchronous_Call_Block => True);
7508 Make_Block_Statement (Loc,
7509 Handled_Statement_Sequence =>
7510 Make_Handled_Sequence_Of_Statements (Loc,
7511 Statements => New_List (
7512 Make_Implicit_Label_Declaration (Loc,
7513 Defining_Identifier => Blk_Ent,
7514 Label_Construct => Abortable_Block),
7516 Exception_Handlers => Hdle)));
7518 -- Create new call statement
7520 Params := Parameter_Associations (Call);
7523 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7524 Append_To (Params, New_Occurrence_Of (B, Loc));
7527 Make_Procedure_Call_Statement (Loc,
7528 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
7529 Parameter_Associations => Params));
7531 -- Construct statement sequence for new block
7534 Make_Implicit_If_Statement (N,
7536 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)),
7537 Then_Statements => Tstats));
7539 -- Protected the call against abort
7541 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7544 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
7546 -- The result is the new block
7549 Make_Block_Statement (Loc,
7550 Declarations => Decls,
7551 Handled_Statement_Sequence =>
7552 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7555 end Expand_N_Asynchronous_Select;
7557 -------------------------------------
7558 -- Expand_N_Conditional_Entry_Call --
7559 -------------------------------------
7561 -- The conditional task entry call is converted to a call to
7566 -- P : parms := (parm, parm, parm);
7570 -- (<acceptor-task>, -- Acceptor
7571 -- <entry-index>, -- E
7572 -- P'Address, -- Uninterpreted_Data
7573 -- Conditional_Call, -- Mode
7574 -- B); -- Rendezvous_Successful
7579 -- normal-statements
7585 -- For a description of the use of P and the assignments after the call,
7586 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7587 -- conditional entry call has already been expanded (by the Expand_N_Entry
7588 -- _Call_Statement procedure) as follows:
7591 -- P : parms := (parm, parm, parm);
7593 -- ... info for in-out parameters
7594 -- Call_Simple (acceptor-task, entry-index, P'Address);
7600 -- so the task at hand is to convert the latter expansion into the former
7602 -- The conditional protected entry call is converted to a call to
7603 -- Protected_Entry_Call:
7606 -- P : parms := (parm, parm, parm);
7607 -- Bnn : Communications_Block;
7610 -- Protected_Entry_Call
7611 -- (po._object'Access, -- Object
7612 -- <entry index>, -- E
7613 -- P'Address, -- Uninterpreted_Data
7614 -- Conditional_Call, -- Mode
7619 -- if Cancelled (Bnn) then
7622 -- normal-statements
7626 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7630 -- B : Boolean := False;
7631 -- C : Ada.Tags.Prim_Op_Kind;
7632 -- K : Ada.Tags.Tagged_Kind :=
7633 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7634 -- P : Parameters := (Param1 .. ParamN);
7638 -- if K = Ada.Tags.TK_Limited_Tagged
7639 -- or else K = Ada.Tags.TK_Tagged
7641 -- <dispatching-call>;
7642 -- <triggering-statements>
7646 -- Ada.Tags.Get_Offset_Index
7647 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7649 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7651 -- if C = POK_Protected_Entry
7652 -- or else C = POK_Task_Entry
7654 -- Param1 := P.Param1;
7656 -- ParamN := P.ParamN;
7660 -- if C = POK_Procedure
7661 -- or else C = POK_Protected_Procedure
7662 -- or else C = POK_Task_Procedure
7664 -- <dispatching-call>;
7667 -- <triggering-statements>
7669 -- <else-statements>
7674 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
7675 Loc : constant Source_Ptr := Sloc (N);
7676 Alt : constant Node_Id := Entry_Call_Alternative (N);
7677 Blk : Node_Id := Entry_Call_Statement (Alt);
7680 Blk_Typ : Entity_Id;
7682 Call_Ent : Entity_Id;
7683 Conc_Typ_Stmts : List_Id;
7687 Lim_Typ_Stmts : List_Id;
7694 Transient_Blk : Node_Id;
7697 B : Entity_Id; -- Call status flag
7698 C : Entity_Id; -- Call kind
7699 K : Entity_Id; -- Tagged kind
7700 P : Entity_Id; -- Parameter block
7701 S : Entity_Id; -- Primitive operation slot
7704 Process_Statements_For_Controlled_Objects (N);
7706 if Ada_Version >= Ada_2005
7707 and then Nkind (Blk) = N_Procedure_Call_Statement
7709 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
7714 -- Call status flag processing, generate:
7715 -- B : Boolean := False;
7717 B := Build_B (Loc, Decls);
7719 -- Call kind processing, generate:
7720 -- C : Ada.Tags.Prim_Op_Kind;
7722 C := Build_C (Loc, Decls);
7724 -- Tagged kind processing, generate:
7725 -- K : Ada.Tags.Tagged_Kind :=
7726 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7728 K := Build_K (Loc, Decls, Obj);
7730 -- Parameter block processing
7732 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
7733 P := Parameter_Block_Pack
7734 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
7736 -- Dispatch table slot processing, generate:
7739 S := Build_S (Loc, Decls);
7742 -- S := Ada.Tags.Get_Offset_Index
7743 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7746 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
7749 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7751 Append_To (Conc_Typ_Stmts,
7752 Make_Procedure_Call_Statement (Loc,
7755 Find_Prim_Op (Etype (Etype (Obj)),
7756 Name_uDisp_Conditional_Select),
7758 Parameter_Associations =>
7760 New_Copy_Tree (Obj), -- <object>
7761 New_Occurrence_Of (S, Loc), -- S
7762 Make_Attribute_Reference (Loc, -- P'Address
7763 Prefix => New_Occurrence_Of (P, Loc),
7764 Attribute_Name => Name_Address),
7765 New_Occurrence_Of (C, Loc), -- C
7766 New_Occurrence_Of (B, Loc)))); -- B
7769 -- if C = POK_Protected_Entry
7770 -- or else C = POK_Task_Entry
7772 -- Param1 := P.Param1;
7774 -- ParamN := P.ParamN;
7777 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7779 -- Generate the if statement only when the packed parameters need
7780 -- explicit assignments to their corresponding actuals.
7782 if Present (Unpack) then
7783 Append_To (Conc_Typ_Stmts,
7784 Make_Implicit_If_Statement (N,
7790 New_Occurrence_Of (C, Loc),
7792 New_Occurrence_Of (RTE (
7793 RE_POK_Protected_Entry), Loc)),
7798 New_Occurrence_Of (C, Loc),
7800 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
7802 Then_Statements => Unpack));
7807 -- if C = POK_Procedure
7808 -- or else C = POK_Protected_Procedure
7809 -- or else C = POK_Task_Procedure
7811 -- <dispatching-call>
7813 -- <normal-statements>
7815 -- <else-statements>
7818 N_Stats := New_Copy_List_Tree (Statements (Alt));
7820 Prepend_To (N_Stats,
7821 Make_Implicit_If_Statement (N,
7827 New_Occurrence_Of (C, Loc),
7829 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
7836 New_Occurrence_Of (C, Loc),
7838 New_Occurrence_Of (RTE (
7839 RE_POK_Protected_Procedure), Loc)),
7844 New_Occurrence_Of (C, Loc),
7846 New_Occurrence_Of (RTE (
7847 RE_POK_Task_Procedure), Loc)))),
7852 Append_To (Conc_Typ_Stmts,
7853 Make_Implicit_If_Statement (N,
7854 Condition => New_Occurrence_Of (B, Loc),
7855 Then_Statements => N_Stats,
7856 Else_Statements => Else_Statements (N)));
7859 -- <dispatching-call>;
7860 -- <triggering-statements>
7862 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
7863 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
7866 -- if K = Ada.Tags.TK_Limited_Tagged
7867 -- or else K = Ada.Tags.TK_Tagged
7875 Make_Implicit_If_Statement (N,
7876 Condition => Build_Dispatching_Tag_Check (K, N),
7877 Then_Statements => Lim_Typ_Stmts,
7878 Else_Statements => Conc_Typ_Stmts));
7881 Make_Block_Statement (Loc,
7884 Handled_Statement_Sequence =>
7885 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7887 -- As described above, the entry alternative is transformed into a
7888 -- block that contains the gnulli call, and possibly assignment
7889 -- statements for in-out parameters. The gnulli call may itself be
7890 -- rewritten into a transient block if some unconstrained parameters
7891 -- require it. We need to retrieve the call to complete its parameter
7896 First_Real_Statement (Handled_Statement_Sequence (Blk));
7898 if Present (Transient_Blk)
7899 and then Nkind (Transient_Blk) = N_Block_Statement
7901 Blk := Transient_Blk;
7904 Stmts := Statements (Handled_Statement_Sequence (Blk));
7905 Stmt := First (Stmts);
7906 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7911 Params := Parameter_Associations (Call);
7913 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
7915 -- Substitute Conditional_Entry_Call for Simple_Call parameter
7917 Param := First (Params);
7918 while Present (Param)
7919 and then not Is_RTE (Etype (Param), RE_Call_Modes)
7924 pragma Assert (Present (Param));
7926 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
7930 -- Find the Communication_Block parameter for the call to the
7931 -- Cancelled function.
7933 Decl := First (Declarations (Blk));
7934 while Present (Decl)
7935 and then not Is_RTE (Etype (Object_Definition (Decl)),
7936 RE_Communication_Block)
7941 -- Add an if statement to execute the else part if the call
7942 -- does not succeed (as indicated by the Cancelled predicate).
7945 Make_Implicit_If_Statement (N,
7946 Condition => Make_Function_Call (Loc,
7947 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7948 Parameter_Associations => New_List (
7949 New_Occurrence_Of (Defining_Identifier (Decl), Loc))),
7950 Then_Statements => Else_Statements (N),
7951 Else_Statements => Statements (Alt)));
7954 B := Make_Defining_Identifier (Loc, Name_uB);
7956 -- Insert declaration of B in declarations of existing block
7958 if No (Declarations (Blk)) then
7959 Set_Declarations (Blk, New_List);
7962 Prepend_To (Declarations (Blk),
7963 Make_Object_Declaration (Loc,
7964 Defining_Identifier => B,
7965 Object_Definition =>
7966 New_Occurrence_Of (Standard_Boolean, Loc)));
7968 -- Create new call statement
7971 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
7972 Append_To (Params, New_Occurrence_Of (B, Loc));
7975 Make_Procedure_Call_Statement (Loc,
7976 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
7977 Parameter_Associations => Params));
7979 -- Construct statement sequence for new block
7982 Make_Implicit_If_Statement (N,
7983 Condition => New_Occurrence_Of (B, Loc),
7984 Then_Statements => Statements (Alt),
7985 Else_Statements => Else_Statements (N)));
7988 -- The result is the new block
7991 Make_Block_Statement (Loc,
7992 Declarations => Declarations (Blk),
7993 Handled_Statement_Sequence =>
7994 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7998 end Expand_N_Conditional_Entry_Call;
8000 ---------------------------------------
8001 -- Expand_N_Delay_Relative_Statement --
8002 ---------------------------------------
8004 -- Delay statement is implemented as a procedure call to Delay_For
8005 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8006 -- simple delays imposed by the use of Protected Objects.
8008 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
8009 Loc : constant Source_Ptr := Sloc (N);
8013 -- Try to use System.Relative_Delays.Delay_For only if available. This
8014 -- is the implementation used on restricted platforms when Ada.Calendar
8015 -- is not available.
8017 if RTE_Available (RO_RD_Delay_For) then
8018 Proc := RTE (RO_RD_Delay_For);
8020 -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error
8021 -- message if not available.
8024 Proc := RTE (RO_CA_Delay_For);
8028 Make_Procedure_Call_Statement (Loc,
8029 Name => New_Occurrence_Of (Proc, Loc),
8030 Parameter_Associations => New_List (Expression (N))));
8032 end Expand_N_Delay_Relative_Statement;
8034 ------------------------------------
8035 -- Expand_N_Delay_Until_Statement --
8036 ------------------------------------
8038 -- Delay Until statement is implemented as a procedure call to
8039 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8041 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
8042 Loc : constant Source_Ptr := Sloc (N);
8046 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
8047 Typ := RTE (RO_CA_Delay_Until);
8049 Typ := RTE (RO_RT_Delay_Until);
8053 Make_Procedure_Call_Statement (Loc,
8054 Name => New_Occurrence_Of (Typ, Loc),
8055 Parameter_Associations => New_List (Expression (N))));
8058 end Expand_N_Delay_Until_Statement;
8060 -------------------------
8061 -- Expand_N_Entry_Body --
8062 -------------------------
8064 procedure Expand_N_Entry_Body (N : Node_Id) is
8066 -- Associate discriminals with the next protected operation body to be
8069 if Present (Next_Protected_Operation (N)) then
8070 Set_Discriminals (Parent (Current_Scope));
8072 end Expand_N_Entry_Body;
8074 -----------------------------------
8075 -- Expand_N_Entry_Call_Statement --
8076 -----------------------------------
8078 -- An entry call is expanded into GNARLI calls to implement a simple entry
8079 -- call (see Build_Simple_Entry_Call).
8081 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
8087 if No_Run_Time_Mode then
8088 Error_Msg_CRT ("entry call", N);
8092 -- If this entry call is part of an asynchronous select, don't expand it
8093 -- here; it will be expanded with the select statement. Don't expand
8094 -- timed entry calls either, as they are translated into asynchronous
8097 -- ??? This whole approach is questionable; it may be better to go back
8098 -- to allowing the expansion to take place and then attempting to fix it
8099 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8100 -- whether the expanded call is on a task or protected entry.
8102 if (Nkind (Parent (N)) /= N_Triggering_Alternative
8103 or else N /= Triggering_Statement (Parent (N)))
8104 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
8105 or else N /= Entry_Call_Statement (Parent (N))
8106 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
8108 Extract_Entry (N, Concval, Ename, Index);
8109 Build_Simple_Entry_Call (N, Concval, Ename, Index);
8111 end Expand_N_Entry_Call_Statement;
8113 --------------------------------
8114 -- Expand_N_Entry_Declaration --
8115 --------------------------------
8117 -- If there are parameters, then first, each of the formals is marked by
8118 -- setting Is_Entry_Formal. Next a record type is built which is used to
8119 -- hold the parameter values. The name of this record type is entryP where
8120 -- entry is the name of the entry, with an additional corresponding access
8121 -- type called entryPA. The record type has matching components for each
8122 -- formal (the component names are the same as the formal names). For
8123 -- elementary types, the component type matches the formal type. For
8124 -- composite types, an access type is declared (with the name formalA)
8125 -- which designates the formal type, and the type of the component is this
8126 -- access type. Finally the Entry_Component of each formal is set to
8127 -- reference the corresponding record component.
8129 procedure Expand_N_Entry_Declaration (N : Node_Id) is
8130 Loc : constant Source_Ptr := Sloc (N);
8131 Entry_Ent : constant Entity_Id := Defining_Identifier (N);
8132 Components : List_Id;
8135 Last_Decl : Node_Id;
8136 Component : Entity_Id;
8139 Rec_Ent : Entity_Id;
8140 Acc_Ent : Entity_Id;
8143 Formal := First_Formal (Entry_Ent);
8146 -- Most processing is done only if parameters are present
8148 if Present (Formal) then
8149 Components := New_List;
8151 -- Loop through formals
8153 while Present (Formal) loop
8154 Set_Is_Entry_Formal (Formal);
8156 Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
8157 Set_Entry_Component (Formal, Component);
8158 Set_Entry_Formal (Component, Formal);
8159 Ftype := Etype (Formal);
8161 -- Declare new access type and then append
8163 Ctype := Make_Temporary (Loc, 'A');
8164 Set_Is_Param_Block_Component_Type (Ctype);
8167 Make_Full_Type_Declaration (Loc,
8168 Defining_Identifier => Ctype,
8170 Make_Access_To_Object_Definition (Loc,
8171 All_Present => True,
8172 Constant_Present => Ekind (Formal) = E_In_Parameter,
8173 Subtype_Indication => New_Occurrence_Of (Ftype, Loc)));
8175 Insert_After (Last_Decl, Decl);
8178 Append_To (Components,
8179 Make_Component_Declaration (Loc,
8180 Defining_Identifier => Component,
8181 Component_Definition =>
8182 Make_Component_Definition (Loc,
8183 Aliased_Present => False,
8184 Subtype_Indication => New_Occurrence_Of (Ctype, Loc))));
8186 Next_Formal_With_Extras (Formal);
8189 -- Create the Entry_Parameter_Record declaration
8191 Rec_Ent := Make_Temporary (Loc, 'P');
8194 Make_Full_Type_Declaration (Loc,
8195 Defining_Identifier => Rec_Ent,
8197 Make_Record_Definition (Loc,
8199 Make_Component_List (Loc,
8200 Component_Items => Components)));
8202 Insert_After (Last_Decl, Decl);
8205 -- Construct and link in the corresponding access type
8207 Acc_Ent := Make_Temporary (Loc, 'A');
8209 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
8212 Make_Full_Type_Declaration (Loc,
8213 Defining_Identifier => Acc_Ent,
8215 Make_Access_To_Object_Definition (Loc,
8216 All_Present => True,
8217 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc)));
8219 Insert_After (Last_Decl, Decl);
8221 end Expand_N_Entry_Declaration;
8223 -----------------------------
8224 -- Expand_N_Protected_Body --
8225 -----------------------------
8227 -- Protected bodies are expanded to the completion of the subprograms
8228 -- created for the corresponding protected type. These are a protected and
8229 -- unprotected version of each protected subprogram in the object, a
8230 -- function to calculate each entry barrier, and a procedure to execute the
8231 -- sequence of statements of each protected entry body. For example, for
8232 -- protected type ptype:
8235 -- (O : System.Address;
8236 -- E : Protected_Entry_Index)
8239 -- <discriminant renamings>
8240 -- <private object renamings>
8242 -- return <barrier expression>;
8245 -- procedure pprocN (_object : in out poV;...) is
8246 -- <discriminant renamings>
8247 -- <private object renamings>
8249 -- <sequence of statements>
8252 -- procedure pprocP (_object : in out poV;...) is
8253 -- procedure _clean is
8256 -- ptypeS (_object, Pn);
8257 -- Unlock (_object._object'Access);
8258 -- Abort_Undefer.all;
8263 -- Lock (_object._object'Access);
8264 -- pprocN (_object;...);
8269 -- function pfuncN (_object : poV;...) return Return_Type is
8270 -- <discriminant renamings>
8271 -- <private object renamings>
8273 -- <sequence of statements>
8276 -- function pfuncP (_object : poV) return Return_Type is
8277 -- procedure _clean is
8279 -- Unlock (_object._object'Access);
8280 -- Abort_Undefer.all;
8285 -- Lock (_object._object'Access);
8286 -- return pfuncN (_object);
8293 -- (O : System.Address;
8294 -- P : System.Address;
8295 -- E : Protected_Entry_Index)
8297 -- <discriminant renamings>
8298 -- <private object renamings>
8299 -- type poVP is access poV;
8300 -- _Object : ptVP := ptVP!(O);
8304 -- <statement sequence>
8305 -- Complete_Entry_Body (_Object._Object);
8307 -- when all others =>
8308 -- Exceptional_Complete_Entry_Body (
8309 -- _Object._Object, Get_GNAT_Exception);
8313 -- The type poV is the record created for the protected type to hold
8314 -- the state of the protected object.
8316 procedure Expand_N_Protected_Body (N : Node_Id) is
8317 Loc : constant Source_Ptr := Sloc (N);
8318 Pid : constant Entity_Id := Corresponding_Spec (N);
8320 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid);
8321 -- This flag indicates whether the lock free implementation is active
8323 Current_Node : Node_Id;
8324 Disp_Op_Body : Node_Id;
8325 New_Op_Body : Node_Id;
8329 function Build_Dispatching_Subprogram_Body
8332 Prot_Bod : Node_Id) return Node_Id;
8333 -- Build a dispatching version of the protected subprogram body. The
8334 -- newly generated subprogram contains a call to the original protected
8335 -- body. The following code is generated:
8337 -- function <protected-function-name> (Param1 .. ParamN) return
8340 -- return <protected-function-name>P (Param1 .. ParamN);
8341 -- end <protected-function-name>;
8345 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8347 -- <protected-procedure-name>P (Param1 .. ParamN);
8348 -- end <protected-procedure-name>
8350 ---------------------------------------
8351 -- Build_Dispatching_Subprogram_Body --
8352 ---------------------------------------
8354 function Build_Dispatching_Subprogram_Body
8357 Prot_Bod : Node_Id) return Node_Id
8359 Loc : constant Source_Ptr := Sloc (N);
8366 -- Generate a specification without a letter suffix in order to
8367 -- override an interface function or procedure.
8369 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
8371 -- The formal parameters become the actuals of the protected function
8372 -- or procedure call.
8374 Actuals := New_List;
8375 Formal := First (Parameter_Specifications (Spec));
8376 while Present (Formal) loop
8378 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
8382 if Nkind (Spec) = N_Procedure_Specification then
8385 Make_Procedure_Call_Statement (Loc,
8387 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8388 Parameter_Associations => Actuals));
8391 pragma Assert (Nkind (Spec) = N_Function_Specification);
8395 Make_Simple_Return_Statement (Loc,
8397 Make_Function_Call (Loc,
8399 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8400 Parameter_Associations => Actuals)));
8404 Make_Subprogram_Body (Loc,
8405 Declarations => Empty_List,
8406 Specification => Spec,
8407 Handled_Statement_Sequence =>
8408 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8409 end Build_Dispatching_Subprogram_Body;
8411 -- Start of processing for Expand_N_Protected_Body
8414 if No_Run_Time_Mode then
8415 Error_Msg_CRT ("protected body", N);
8419 -- This is the proper body corresponding to a stub. The declarations
8420 -- must be inserted at the point of the stub, which in turn is in the
8421 -- declarative part of the parent unit.
8423 if Nkind (Parent (N)) = N_Subunit then
8424 Current_Node := Corresponding_Stub (Parent (N));
8429 Op_Body := First (Declarations (N));
8431 -- The protected body is replaced with the bodies of its
8432 -- protected operations, and the declarations for internal objects
8433 -- that may have been created for entry family bounds.
8435 Rewrite (N, Make_Null_Statement (Sloc (N)));
8438 while Present (Op_Body) loop
8439 case Nkind (Op_Body) is
8440 when N_Subprogram_Declaration =>
8443 when N_Subprogram_Body =>
8445 -- Do not create bodies for eliminated operations
8447 if not Is_Eliminated (Defining_Entity (Op_Body))
8448 and then not Is_Eliminated (Corresponding_Spec (Op_Body))
8450 if Lock_Free_Active then
8452 Build_Lock_Free_Unprotected_Subprogram_Body
8456 Build_Unprotected_Subprogram_Body (Op_Body, Pid);
8459 Insert_After (Current_Node, New_Op_Body);
8460 Current_Node := New_Op_Body;
8461 Analyze (New_Op_Body);
8463 -- Build the corresponding protected operation. It may
8464 -- appear that this is needed only if this is a visible
8465 -- operation of the type, or if it is an interrupt handler,
8466 -- and this was the strategy used previously in GNAT.
8468 -- However, the operation may be exported through a 'Access
8469 -- to an external caller. This is the common idiom in code
8470 -- that uses the Ada 2005 Timing_Events package. As a result
8471 -- we need to produce the protected body for both visible
8472 -- and private operations, as well as operations that only
8473 -- have a body in the source, and for which we create a
8474 -- declaration in the protected body itself.
8476 if Present (Corresponding_Spec (Op_Body)) then
8477 if Lock_Free_Active then
8479 Build_Lock_Free_Protected_Subprogram_Body
8480 (Op_Body, Pid, Specification (New_Op_Body));
8483 Build_Protected_Subprogram_Body
8484 (Op_Body, Pid, Specification (New_Op_Body));
8487 Insert_After (Current_Node, New_Op_Body);
8488 Analyze (New_Op_Body);
8490 Current_Node := New_Op_Body;
8492 -- Generate an overriding primitive operation body for
8493 -- this subprogram if the protected type implements an
8496 if Ada_Version >= Ada_2005
8498 Present (Interfaces (Corresponding_Record_Type (Pid)))
8501 Build_Dispatching_Subprogram_Body
8502 (Op_Body, Pid, New_Op_Body);
8504 Insert_After (Current_Node, Disp_Op_Body);
8505 Analyze (Disp_Op_Body);
8507 Current_Node := Disp_Op_Body;
8512 when N_Entry_Body =>
8513 Op_Id := Defining_Identifier (Op_Body);
8514 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
8516 Insert_After (Current_Node, New_Op_Body);
8517 Current_Node := New_Op_Body;
8518 Analyze (New_Op_Body);
8520 when N_Implicit_Label_Declaration =>
8523 when N_Itype_Reference =>
8524 Insert_After (Current_Node, New_Copy (Op_Body));
8526 when N_Freeze_Entity =>
8527 New_Op_Body := New_Copy (Op_Body);
8529 if Present (Entity (Op_Body))
8530 and then Freeze_Node (Entity (Op_Body)) = Op_Body
8532 Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
8535 Insert_After (Current_Node, New_Op_Body);
8536 Current_Node := New_Op_Body;
8537 Analyze (New_Op_Body);
8540 New_Op_Body := New_Copy (Op_Body);
8541 Insert_After (Current_Node, New_Op_Body);
8542 Current_Node := New_Op_Body;
8543 Analyze (New_Op_Body);
8545 when N_Object_Declaration =>
8546 pragma Assert (not Comes_From_Source (Op_Body));
8547 New_Op_Body := New_Copy (Op_Body);
8548 Insert_After (Current_Node, New_Op_Body);
8549 Current_Node := New_Op_Body;
8550 Analyze (New_Op_Body);
8553 raise Program_Error;
8560 -- Finally, create the body of the function that maps an entry index
8561 -- into the corresponding body index, except when there is no entry, or
8562 -- in a Ravenscar-like profile.
8564 if Corresponding_Runtime_Package (Pid) =
8565 System_Tasking_Protected_Objects_Entries
8567 New_Op_Body := Build_Find_Body_Index (Pid);
8568 Insert_After (Current_Node, New_Op_Body);
8569 Current_Node := New_Op_Body;
8570 Analyze (New_Op_Body);
8573 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8574 -- protected body. At this point all wrapper specs have been created,
8575 -- frozen and included in the dispatch table for the protected type.
8577 if Ada_Version >= Ada_2005 then
8578 Build_Wrapper_Bodies (Loc, Pid, Current_Node);
8580 end Expand_N_Protected_Body;
8582 -----------------------------------------
8583 -- Expand_N_Protected_Type_Declaration --
8584 -----------------------------------------
8586 -- First we create a corresponding record type declaration used to
8587 -- represent values of this protected type.
8588 -- The general form of this type declaration is
8590 -- type poV (discriminants) is record
8591 -- _Object : aliased <kind>Protection
8592 -- [(<entry count> [, <handler count>])];
8593 -- [entry_family : array (bounds) of Void;]
8594 -- <private data fields>
8597 -- The discriminants are present only if the corresponding protected type
8598 -- has discriminants, and they exactly mirror the protected type
8599 -- discriminants. The private data fields similarly mirror the private
8600 -- declarations of the protected type.
8602 -- The Object field is always present. It contains RTS specific data used
8603 -- to control the protected object. It is declared as Aliased so that it
8604 -- can be passed as a pointer to the RTS. This allows the protected record
8605 -- to be referenced within RTS data structures. An appropriate Protection
8606 -- type and discriminant are generated.
8608 -- The Service field is present for protected objects with entries. It
8609 -- contains sufficient information to allow the entry service procedure for
8610 -- this object to be called when the object is not known till runtime.
8612 -- One entry_family component is present for each entry family in the
8613 -- task definition (see Expand_N_Task_Type_Declaration).
8615 -- When a protected object is declared, an instance of the protected type
8616 -- value record is created. The elaboration of this declaration creates the
8617 -- correct bounds for the entry families, and also evaluates the priority
8618 -- expression if needed. The initialization routine for the protected type
8619 -- itself then calls Initialize_Protection with appropriate parameters to
8620 -- initialize the value of the Task_Id field. Install_Handlers may be also
8621 -- called if a pragma Attach_Handler applies.
8623 -- Note: this record is passed to the subprograms created by the expansion
8624 -- of protected subprograms and entries. It is an in parameter to protected
8625 -- functions and an in out parameter to procedures and entry bodies. The
8626 -- Entity_Id for this created record type is placed in the
8627 -- Corresponding_Record_Type field of the associated protected type entity.
8629 -- Next we create a procedure specifications for protected subprograms and
8630 -- entry bodies. For each protected subprograms two subprograms are
8631 -- created, an unprotected and a protected version. The unprotected version
8632 -- is called from within other operations of the same protected object.
8634 -- We also build the call to register the procedure if a pragma
8635 -- Interrupt_Handler applies.
8637 -- A single subprogram is created to service all entry bodies; it has an
8638 -- additional boolean out parameter indicating that the previous entry call
8639 -- made by the current task was serviced immediately, i.e. not by proxy.
8640 -- The O parameter contains a pointer to a record object of the type
8641 -- described above. An untyped interface is used here to allow this
8642 -- procedure to be called in places where the type of the object to be
8643 -- serviced is not known. This must be done, for example, when a call that
8644 -- may have been requeued is cancelled; the corresponding object must be
8645 -- serviced, but which object that is not known till runtime.
8648 -- (O : System.Address; P : out Boolean);
8649 -- procedure pprocN (_object : in out poV);
8650 -- procedure pproc (_object : in out poV);
8651 -- function pfuncN (_object : poV);
8652 -- function pfunc (_object : poV);
8655 -- Note that this must come after the record type declaration, since
8656 -- the specs refer to this type.
8658 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
8659 Discr_Map : constant Elist_Id := New_Elmt_List;
8660 Loc : constant Source_Ptr := Sloc (N);
8661 Prot_Typ : constant Entity_Id := Defining_Identifier (N);
8663 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ);
8664 -- This flag indicates whether the lock free implementation is active
8666 Pdef : constant Node_Id := Protected_Definition (N);
8667 -- This contains two lists; one for visible and one for private decls
8669 Current_Node : Node_Id := N;
8671 Entries_Aggr : Node_Id;
8673 procedure Check_Inlining (Subp : Entity_Id);
8674 -- If the original operation has a pragma Inline, propagate the flag
8675 -- to the internal body, for possible inlining later on. The source
8676 -- operation is invisible to the back-end and is never actually called.
8678 function Discriminated_Size (Comp : Entity_Id) return Boolean;
8679 -- If a component size is not static then a warning will be emitted
8680 -- in Ravenscar or other restricted contexts. When a component is non-
8681 -- static because of a discriminant constraint we can specialize the
8682 -- warning by mentioning discriminants explicitly.
8684 procedure Expand_Entry_Declaration (Decl : Node_Id);
8685 -- Create the entry barrier and the procedure body for entry declaration
8686 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
8688 function Static_Component_Size (Comp : Entity_Id) return Boolean;
8689 -- When compiling under the Ravenscar profile, private components must
8690 -- have a static size, or else a protected object will require heap
8691 -- allocation, violating the corresponding restriction. It is preferable
8692 -- to make this check here, because it provides a better error message
8693 -- than the back-end, which refers to the object as a whole.
8695 procedure Register_Handler;
8696 -- For a protected operation that is an interrupt handler, add the
8697 -- freeze action that will register it as such.
8699 --------------------
8700 -- Check_Inlining --
8701 --------------------
8703 procedure Check_Inlining (Subp : Entity_Id) is
8705 if Is_Inlined (Subp) then
8706 Set_Is_Inlined (Protected_Body_Subprogram (Subp));
8707 Set_Is_Inlined (Subp, False);
8711 ------------------------
8712 -- Discriminated_Size --
8713 ------------------------
8715 function Discriminated_Size (Comp : Entity_Id) return Boolean is
8716 Typ : constant Entity_Id := Etype (Comp);
8719 function Non_Static_Bound (Bound : Node_Id) return Boolean;
8720 -- Check whether the bound of an index is non-static and does denote
8721 -- a discriminant, in which case any protected object of the type
8722 -- will have a non-static size.
8724 ----------------------
8725 -- Non_Static_Bound --
8726 ----------------------
8728 function Non_Static_Bound (Bound : Node_Id) return Boolean is
8730 if Is_OK_Static_Expression (Bound) then
8733 elsif Is_Entity_Name (Bound)
8734 and then Present (Discriminal_Link (Entity (Bound)))
8741 end Non_Static_Bound;
8743 -- Start of processing for Discriminated_Size
8746 if not Is_Array_Type (Typ) then
8750 if Ekind (Typ) = E_Array_Subtype then
8751 Index := First_Index (Typ);
8752 while Present (Index) loop
8753 if Non_Static_Bound (Low_Bound (Index))
8754 or else Non_Static_Bound (High_Bound (Index))
8766 end Discriminated_Size;
8768 ---------------------------
8769 -- Static_Component_Size --
8770 ---------------------------
8772 function Static_Component_Size (Comp : Entity_Id) return Boolean is
8773 Typ : constant Entity_Id := Etype (Comp);
8777 if Is_Scalar_Type (Typ) then
8780 elsif Is_Array_Type (Typ) then
8781 return Compile_Time_Known_Bounds (Typ);
8783 elsif Is_Record_Type (Typ) then
8784 C := First_Component (Typ);
8785 while Present (C) loop
8786 if not Static_Component_Size (C) then
8795 -- Any other type will be checked by the back-end
8800 end Static_Component_Size;
8802 ------------------------------
8803 -- Expand_Entry_Declaration --
8804 ------------------------------
8806 procedure Expand_Entry_Declaration (Decl : Node_Id) is
8807 Ent_Id : constant Entity_Id := Defining_Entity (Decl);
8813 E_Count := E_Count + 1;
8815 -- Create the protected body subprogram
8818 Make_Defining_Identifier (Loc,
8819 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E'));
8820 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id);
8823 Make_Subprogram_Declaration (Loc,
8825 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id));
8827 Insert_After (Current_Node, Subp);
8828 Current_Node := Subp;
8832 -- Build a wrapper procedure to handle contract cases, preconditions,
8833 -- and postconditions.
8835 Build_Contract_Wrapper (Ent_Id, N);
8837 -- Create the barrier function
8840 Make_Defining_Identifier (Loc,
8841 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B'));
8842 Set_Barrier_Function (Ent_Id, Bar_Id);
8845 Make_Subprogram_Declaration (Loc,
8847 Build_Barrier_Function_Specification (Loc, Bar_Id));
8848 Set_Is_Entry_Barrier_Function (Subp);
8850 Insert_After (Current_Node, Subp);
8851 Current_Node := Subp;
8855 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id);
8856 Set_Scope (Bar_Id, Scope (Ent_Id));
8858 -- Collect pointers to the protected subprogram and the barrier
8859 -- of the current entry, for insertion into Entry_Bodies_Array.
8861 Append_To (Expressions (Entries_Aggr),
8862 Make_Aggregate (Loc,
8863 Expressions => New_List (
8864 Make_Attribute_Reference (Loc,
8865 Prefix => New_Occurrence_Of (Bar_Id, Loc),
8866 Attribute_Name => Name_Unrestricted_Access),
8867 Make_Attribute_Reference (Loc,
8868 Prefix => New_Occurrence_Of (Bod_Id, Loc),
8869 Attribute_Name => Name_Unrestricted_Access))));
8870 end Expand_Entry_Declaration;
8872 ----------------------
8873 -- Register_Handler --
8874 ----------------------
8876 procedure Register_Handler is
8878 -- All semantic checks already done in Sem_Prag
8880 Prot_Proc : constant Entity_Id :=
8881 Defining_Unit_Name (Specification (Current_Node));
8883 Proc_Address : constant Node_Id :=
8884 Make_Attribute_Reference (Loc,
8886 New_Occurrence_Of (Prot_Proc, Loc),
8887 Attribute_Name => Name_Address);
8889 RTS_Call : constant Entity_Id :=
8890 Make_Procedure_Call_Statement (Loc,
8893 (RTE (RE_Register_Interrupt_Handler), Loc),
8894 Parameter_Associations => New_List (Proc_Address));
8896 Append_Freeze_Action (Prot_Proc, RTS_Call);
8897 end Register_Handler;
8902 Body_Id : Entity_Id;
8908 Object_Comp : Node_Id;
8913 -- Start of processing for Expand_N_Protected_Type_Declaration
8916 if Present (Corresponding_Record_Type (Prot_Typ)) then
8919 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
8922 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
8924 Qualify_Entity_Names (N);
8926 -- If the type has discriminants, their occurrences in the declaration
8927 -- have been replaced by the corresponding discriminals. For components
8928 -- that are constrained by discriminants, their homologues in the
8929 -- corresponding record type must refer to the discriminants of that
8930 -- record, so we must apply a new renaming to subtypes_indications:
8932 -- protected discriminant => discriminal => record discriminant
8934 -- This replacement is not applied to default expressions, for which
8935 -- the discriminal is correct.
8937 if Has_Discriminants (Prot_Typ) then
8943 Disc := First_Discriminant (Prot_Typ);
8944 Decl := First (Discriminant_Specifications (Rec_Decl));
8945 while Present (Disc) loop
8946 Append_Elmt (Discriminal (Disc), Discr_Map);
8947 Append_Elmt (Defining_Identifier (Decl), Discr_Map);
8948 Next_Discriminant (Disc);
8954 -- Fill in the component declarations
8956 -- Add components for entry families. For each entry family, create an
8957 -- anonymous type declaration with the same size, and analyze the type.
8959 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
8961 pragma Assert (Present (Pdef));
8963 Insert_After (Current_Node, Rec_Decl);
8964 Current_Node := Rec_Decl;
8966 -- Add private field components
8968 if Present (Private_Declarations (Pdef)) then
8969 Priv := First (Private_Declarations (Pdef));
8970 while Present (Priv) loop
8971 if Nkind (Priv) = N_Component_Declaration then
8972 if not Static_Component_Size (Defining_Identifier (Priv)) then
8974 -- When compiling for a restricted profile, the private
8975 -- components must have a static size. If not, this is an
8976 -- error for a single protected declaration, and rates a
8977 -- warning on a protected type declaration.
8979 if not Comes_From_Source (Prot_Typ) then
8981 -- It's ok to be checking this restriction at expansion
8982 -- time, because this is only for the restricted profile,
8983 -- which is not subject to strict RM conformance, so it
8984 -- is OK to miss this check in -gnatc mode.
8986 Check_Restriction (No_Implicit_Heap_Allocations, Priv);
8988 (No_Implicit_Protected_Object_Allocations, Priv);
8990 elsif Restriction_Active (No_Implicit_Heap_Allocations) then
8991 if not Discriminated_Size (Defining_Identifier (Priv))
8993 -- Any object of the type will be non-static.
8995 Error_Msg_N ("component has non-static size??", Priv);
8997 ("\creation of protected object of type& will "
8998 & "violate restriction "
8999 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
9002 -- Object will be non-static if discriminants are.
9005 ("creation of protected object of type& with "
9006 & "non-static discriminants will violate"
9007 & " restriction No_Implicit_Heap_Allocations??",
9011 -- Likewise for No_Implicit_Protected_Object_Allocations
9013 elsif Restriction_Active
9014 (No_Implicit_Protected_Object_Allocations)
9016 if not Discriminated_Size (Defining_Identifier (Priv))
9018 -- Any object of the type will be non-static.
9020 Error_Msg_N ("component has non-static size??", Priv);
9022 ("\creation of protected object of type& will "
9023 & "violate restriction "
9024 & "No_Implicit_Protected_Object_Allocations??",
9027 -- Object will be non-static if discriminants are.
9030 ("creation of protected object of type& with "
9031 & "non-static discriminants will violate "
9033 & "No_Implicit_Protected_Object_Allocations??",
9039 -- The component definition consists of a subtype indication,
9040 -- or (in Ada 2005) an access definition. Make a copy of the
9041 -- proper definition.
9044 Old_Comp : constant Node_Id := Component_Definition (Priv);
9045 Oent : constant Entity_Id := Defining_Identifier (Priv);
9046 Nent : constant Entity_Id :=
9047 Make_Defining_Identifier (Sloc (Oent),
9048 Chars => Chars (Oent));
9052 if Present (Subtype_Indication (Old_Comp)) then
9054 Make_Component_Definition (Sloc (Oent),
9055 Aliased_Present => False,
9056 Subtype_Indication =>
9058 (Subtype_Indication (Old_Comp), Discr_Map));
9061 Make_Component_Definition (Sloc (Oent),
9062 Aliased_Present => False,
9063 Access_Definition =>
9065 (Access_Definition (Old_Comp), Discr_Map));
9069 Make_Component_Declaration (Loc,
9070 Defining_Identifier => Nent,
9071 Component_Definition => New_Comp,
9072 Expression => Expression (Priv));
9074 Set_Has_Per_Object_Constraint (Nent,
9075 Has_Per_Object_Constraint (Oent));
9077 Append_To (Cdecls, New_Priv);
9080 elsif Nkind (Priv) = N_Subprogram_Declaration then
9082 -- Make the unprotected version of the subprogram available
9083 -- for expansion of intra object calls. There is need for
9084 -- a protected version only if the subprogram is an interrupt
9085 -- handler, otherwise this operation can only be called from
9089 Make_Subprogram_Declaration (Loc,
9091 Build_Protected_Sub_Specification
9092 (Priv, Prot_Typ, Unprotected_Mode));
9094 Insert_After (Current_Node, Sub);
9097 Set_Protected_Body_Subprogram
9098 (Defining_Unit_Name (Specification (Priv)),
9099 Defining_Unit_Name (Specification (Sub)));
9100 Check_Inlining (Defining_Unit_Name (Specification (Priv)));
9101 Current_Node := Sub;
9104 Make_Subprogram_Declaration (Loc,
9106 Build_Protected_Sub_Specification
9107 (Priv, Prot_Typ, Protected_Mode));
9109 Insert_After (Current_Node, Sub);
9111 Current_Node := Sub;
9113 if Is_Interrupt_Handler
9114 (Defining_Unit_Name (Specification (Priv)))
9116 if not Restricted_Profile then
9126 -- Except for the lock-free implementation, append the _Object field
9127 -- with the right type to the component list. We need to compute the
9128 -- number of entries, and in some cases the number of Attach_Handler
9131 if not Lock_Free_Active then
9133 Entry_Count_Expr : constant Node_Id :=
9134 Build_Entry_Count_Expression
9135 (Prot_Typ, Cdecls, Loc);
9136 Num_Attach_Handler : Nat := 0;
9137 Protection_Subtype : Node_Id;
9141 if Has_Attach_Handler (Prot_Typ) then
9142 Ritem := First_Rep_Item (Prot_Typ);
9143 while Present (Ritem) loop
9144 if Nkind (Ritem) = N_Pragma
9145 and then Pragma_Name (Ritem) = Name_Attach_Handler
9147 Num_Attach_Handler := Num_Attach_Handler + 1;
9150 Next_Rep_Item (Ritem);
9154 -- Determine the proper protection type. There are two special
9155 -- cases: 1) when the protected type has dynamic interrupt
9156 -- handlers, and 2) when it has static handlers and we use a
9157 -- restricted profile.
9159 if Has_Attach_Handler (Prot_Typ)
9160 and then not Restricted_Profile
9162 Protection_Subtype :=
9163 Make_Subtype_Indication (Loc,
9166 (RTE (RE_Static_Interrupt_Protection), Loc),
9168 Make_Index_Or_Discriminant_Constraint (Loc,
9169 Constraints => New_List (
9171 Make_Integer_Literal (Loc, Num_Attach_Handler))));
9173 elsif Has_Interrupt_Handler (Prot_Typ)
9174 and then not Restriction_Active (No_Dynamic_Attachment)
9176 Protection_Subtype :=
9177 Make_Subtype_Indication (Loc,
9180 (RTE (RE_Dynamic_Interrupt_Protection), Loc),
9182 Make_Index_Or_Discriminant_Constraint (Loc,
9183 Constraints => New_List (Entry_Count_Expr)));
9186 case Corresponding_Runtime_Package (Prot_Typ) is
9187 when System_Tasking_Protected_Objects_Entries =>
9188 Protection_Subtype :=
9189 Make_Subtype_Indication (Loc,
9192 (RTE (RE_Protection_Entries), Loc),
9194 Make_Index_Or_Discriminant_Constraint (Loc,
9195 Constraints => New_List (Entry_Count_Expr)));
9197 when System_Tasking_Protected_Objects_Single_Entry =>
9198 Protection_Subtype :=
9199 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc);
9201 when System_Tasking_Protected_Objects =>
9202 Protection_Subtype :=
9203 New_Occurrence_Of (RTE (RE_Protection), Loc);
9206 raise Program_Error;
9211 Make_Component_Declaration (Loc,
9212 Defining_Identifier =>
9213 Make_Defining_Identifier (Loc, Name_uObject),
9214 Component_Definition =>
9215 Make_Component_Definition (Loc,
9216 Aliased_Present => True,
9217 Subtype_Indication => Protection_Subtype));
9220 -- Put the _Object component after the private component so that it
9221 -- be finalized early as required by 9.4 (20)
9223 Append_To (Cdecls, Object_Comp);
9226 -- Analyze the record declaration immediately after construction,
9227 -- because the initialization procedure is needed for single object
9228 -- declarations before the next entity is analyzed (the freeze call
9229 -- that generates this initialization procedure is found below).
9231 Analyze (Rec_Decl, Suppress => All_Checks);
9233 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9234 -- the corresponding record is frozen. If any wrappers are generated,
9235 -- Current_Node is updated accordingly.
9237 if Ada_Version >= Ada_2005 then
9238 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
9241 -- Collect pointers to entry bodies and their barriers, to be placed
9242 -- in the Entry_Bodies_Array for the type. For each entry/family we
9243 -- add an expression to the aggregate which is the initial value of
9244 -- this array. The array is declared after all protected subprograms.
9246 if Has_Entries (Prot_Typ) then
9247 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
9249 Entries_Aggr := Empty;
9252 -- Build two new procedure specifications for each protected subprogram;
9253 -- one to call from outside the object and one to call from inside.
9254 -- Build a barrier function and an entry body action procedure
9255 -- specification for each protected entry. Initialize the entry body
9256 -- array. If subprogram is flagged as eliminated, do not generate any
9257 -- internal operations.
9260 Comp := First (Visible_Declarations (Pdef));
9261 while Present (Comp) loop
9262 if Nkind (Comp) = N_Subprogram_Declaration then
9264 Make_Subprogram_Declaration (Loc,
9266 Build_Protected_Sub_Specification
9267 (Comp, Prot_Typ, Unprotected_Mode));
9269 Insert_After (Current_Node, Sub);
9272 Set_Protected_Body_Subprogram
9273 (Defining_Unit_Name (Specification (Comp)),
9274 Defining_Unit_Name (Specification (Sub)));
9275 Check_Inlining (Defining_Unit_Name (Specification (Comp)));
9277 -- Make the protected version of the subprogram available for
9278 -- expansion of external calls.
9280 Current_Node := Sub;
9283 Make_Subprogram_Declaration (Loc,
9285 Build_Protected_Sub_Specification
9286 (Comp, Prot_Typ, Protected_Mode));
9288 Insert_After (Current_Node, Sub);
9291 Current_Node := Sub;
9293 -- Generate an overriding primitive operation specification for
9294 -- this subprogram if the protected type implements an interface
9295 -- and Build_Wrapper_Spec did not generate its wrapper.
9297 if Ada_Version >= Ada_2005
9299 Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
9302 Found : Boolean := False;
9303 Prim_Elmt : Elmt_Id;
9309 (Primitive_Operations
9310 (Corresponding_Record_Type (Prot_Typ)));
9312 while Present (Prim_Elmt) loop
9313 Prim_Op := Node (Prim_Elmt);
9315 if Is_Primitive_Wrapper (Prim_Op)
9316 and then Wrapped_Entity (Prim_Op) =
9317 Defining_Entity (Specification (Comp))
9323 Next_Elmt (Prim_Elmt);
9328 Make_Subprogram_Declaration (Loc,
9330 Build_Protected_Sub_Specification
9331 (Comp, Prot_Typ, Dispatching_Mode));
9333 Insert_After (Current_Node, Sub);
9336 Current_Node := Sub;
9341 -- If a pragma Interrupt_Handler applies, build and add a call to
9342 -- Register_Interrupt_Handler to the freezing actions of the
9343 -- protected version (Current_Node) of the subprogram:
9345 -- system.interrupts.register_interrupt_handler
9346 -- (prot_procP'address);
9348 if not Restricted_Profile
9349 and then Is_Interrupt_Handler
9350 (Defining_Unit_Name (Specification (Comp)))
9355 elsif Nkind (Comp) = N_Entry_Declaration then
9356 Expand_Entry_Declaration (Comp);
9362 -- If there are some private entry declarations, expand it as if they
9363 -- were visible entries.
9365 if Present (Private_Declarations (Pdef)) then
9366 Comp := First (Private_Declarations (Pdef));
9367 while Present (Comp) loop
9368 if Nkind (Comp) = N_Entry_Declaration then
9369 Expand_Entry_Declaration (Comp);
9376 -- Create the declaration of an array object which contains the values
9377 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9378 -- type. This object is later passed to the appropriate protected object
9379 -- initialization routine.
9381 if Has_Entries (Prot_Typ)
9382 and then Corresponding_Runtime_Package (Prot_Typ) =
9383 System_Tasking_Protected_Objects_Entries
9390 Maxes_Id : Entity_Id;
9391 Need_Array : Boolean := False;
9394 -- First check if there is any Max_Queue_Length pragma
9396 Item := First_Entity (Prot_Typ);
9397 while Present (Item) loop
9398 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then
9406 -- Gather the Max_Queue_Length values of all entries in a list. A
9407 -- value of zero indicates that the entry has no limitation on its
9412 Item := First_Entity (Prot_Typ);
9414 while Present (Item) loop
9415 if Is_Entry (Item) then
9418 Make_Integer_Literal
9419 (Loc, Get_Max_Queue_Length (Item)));
9425 -- Create the declaration of the array object. Generate:
9427 -- Maxes_Id : aliased constant
9428 -- Protected_Entry_Queue_Max_Array
9429 -- (1 .. Count) := (..., ...);
9432 Make_Defining_Identifier (Loc,
9433 Chars => New_External_Name (Chars (Prot_Typ), 'B'));
9436 Make_Object_Declaration (Loc,
9437 Defining_Identifier => Maxes_Id,
9438 Aliased_Present => True,
9439 Constant_Present => True,
9440 Object_Definition =>
9441 Make_Subtype_Indication (Loc,
9444 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
9446 Make_Index_Or_Discriminant_Constraint (Loc,
9447 Constraints => New_List (
9449 Make_Integer_Literal (Loc, 1),
9450 Make_Integer_Literal (Loc, Count))))),
9451 Expression => Make_Aggregate (Loc, Maxes));
9453 -- A pointer to this array will be placed in the corresponding
9454 -- record by its initialization procedure so this needs to be
9457 Insert_After (Current_Node, Max_Vals);
9458 Current_Node := Max_Vals;
9461 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id);
9466 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9467 -- all protected subprograms have been collected.
9469 if Has_Entries (Prot_Typ) then
9471 Make_Defining_Identifier (Sloc (Prot_Typ),
9472 Chars => New_External_Name (Chars (Prot_Typ), 'A'));
9474 case Corresponding_Runtime_Package (Prot_Typ) is
9475 when System_Tasking_Protected_Objects_Entries =>
9476 Expr := Entries_Aggr;
9478 Make_Subtype_Indication (Loc,
9481 (RTE (RE_Protected_Entry_Body_Array), Loc),
9483 Make_Index_Or_Discriminant_Constraint (Loc,
9484 Constraints => New_List (
9486 Make_Integer_Literal (Loc, 1),
9487 Make_Integer_Literal (Loc, E_Count)))));
9489 when System_Tasking_Protected_Objects_Single_Entry =>
9490 Expr := Remove_Head (Expressions (Entries_Aggr));
9491 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc);
9494 raise Program_Error;
9498 Make_Object_Declaration (Loc,
9499 Defining_Identifier => Body_Id,
9500 Aliased_Present => True,
9501 Constant_Present => True,
9502 Object_Definition => Obj_Def,
9503 Expression => Expr);
9505 -- A pointer to this array will be placed in the corresponding record
9506 -- by its initialization procedure so this needs to be analyzed here.
9508 Insert_After (Current_Node, Body_Arr);
9509 Current_Node := Body_Arr;
9512 Set_Entry_Bodies_Array (Prot_Typ, Body_Id);
9514 -- Finally, build the function that maps an entry index into the
9515 -- corresponding body. A pointer to this function is placed in each
9516 -- object of the type. Except for a ravenscar-like profile (no abort,
9517 -- no entry queue, 1 entry)
9519 if Corresponding_Runtime_Package (Prot_Typ) =
9520 System_Tasking_Protected_Objects_Entries
9523 Make_Subprogram_Declaration (Loc,
9524 Specification => Build_Find_Body_Index_Spec (Prot_Typ));
9526 Insert_After (Current_Node, Sub);
9530 end Expand_N_Protected_Type_Declaration;
9532 --------------------------------
9533 -- Expand_N_Requeue_Statement --
9534 --------------------------------
9536 -- A nondispatching requeue statement is expanded into one of four GNARLI
9537 -- operations, depending on the source and destination (task or protected
9538 -- object). A dispatching requeue statement is expanded into a call to the
9539 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9540 -- jump around the remainder of processing for the original entry and, if
9541 -- the destination is (different) protected object, to attempt to service
9542 -- it. The following illustrates the various cases:
9545 -- (O : System.Address;
9546 -- P : System.Address;
9547 -- E : Protected_Entry_Index)
9549 -- <discriminant renamings>
9550 -- <private object renamings>
9551 -- type poVP is access poV;
9552 -- _object : ptVP := ptVP!(O);
9556 -- <start of statement sequence for entry>
9558 -- -- Requeue from one protected entry body to another protected
9561 -- Requeue_Protected_Entry (
9562 -- _object._object'Access,
9563 -- new._object'Access,
9568 -- <some more of the statement sequence for entry>
9570 -- -- Requeue from an entry body to a task entry
9572 -- Requeue_Protected_To_Task_Entry (
9578 -- <rest of statement sequence for entry>
9579 -- Complete_Entry_Body (_object._object);
9582 -- when all others =>
9583 -- Exceptional_Complete_Entry_Body (
9584 -- _object._object, Get_GNAT_Exception);
9588 -- Requeue of a task entry call to a task entry
9590 -- Accept_Call (E, Ann);
9591 -- <start of statement sequence for accept statement>
9592 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9594 -- <rest of statement sequence for accept statement>
9596 -- Complete_Rendezvous;
9599 -- when all others =>
9600 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9602 -- Requeue of a task entry call to a protected entry
9604 -- Accept_Call (E, Ann);
9605 -- <start of statement sequence for accept statement>
9606 -- Requeue_Task_To_Protected_Entry (
9607 -- new._object'Access,
9612 -- <rest of statement sequence for accept statement>
9614 -- Complete_Rendezvous;
9617 -- when all others =>
9618 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9620 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9621 -- marked by pragma Implemented (XXX, By_Entry).
9623 -- The requeue is inside a protected entry:
9626 -- (O : System.Address;
9627 -- P : System.Address;
9628 -- E : Protected_Entry_Index)
9630 -- <discriminant renamings>
9631 -- <private object renamings>
9632 -- type poVP is access poV;
9633 -- _object : ptVP := ptVP!(O);
9637 -- <start of statement sequence for entry>
9640 -- (<interface class-wide object>,
9643 -- Ada.Tags.Get_Offset_Index
9645 -- <interface dispatch table index of target entry>),
9649 -- <rest of statement sequence for entry>
9650 -- Complete_Entry_Body (_object._object);
9653 -- when all others =>
9654 -- Exceptional_Complete_Entry_Body (
9655 -- _object._object, Get_GNAT_Exception);
9659 -- The requeue is inside a task entry:
9661 -- Accept_Call (E, Ann);
9662 -- <start of statement sequence for accept statement>
9664 -- (<interface class-wide object>,
9667 -- Ada.Tags.Get_Offset_Index
9669 -- <interface dispatch table index of target entrt>),
9673 -- <rest of statement sequence for accept statement>
9675 -- Complete_Rendezvous;
9678 -- when all others =>
9679 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9681 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9682 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9683 -- statement is replaced by a dispatching call with actual parameters taken
9684 -- from the inner-most accept statement or entry body.
9686 -- Target.Primitive (Param1, ..., ParamN);
9688 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9689 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9693 -- S : constant Offset_Index :=
9694 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9695 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9698 -- if C = POK_Protected_Entry
9699 -- or else C = POK_Task_Entry
9701 -- <statements for dispatching requeue>
9703 -- elsif C = POK_Protected_Procedure then
9704 -- <dispatching call equivalent>
9707 -- raise Program_Error;
9711 procedure Expand_N_Requeue_Statement (N : Node_Id) is
9712 Loc : constant Source_Ptr := Sloc (N);
9713 Conc_Typ : Entity_Id;
9717 Old_Typ : Entity_Id;
9719 function Build_Dispatching_Call_Equivalent return Node_Id;
9720 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9721 -- the form Concval.Ename. It is statically known that Ename is allowed
9722 -- to be implemented by a protected procedure. Create a dispatching call
9723 -- equivalent of Concval.Ename taking the actual parameters from the
9724 -- inner-most accept statement or entry body.
9726 function Build_Dispatching_Requeue return Node_Id;
9727 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9728 -- the form Concval.Ename. It is statically known that Ename is allowed
9729 -- to be implemented by a protected or a task entry. Create a call to
9730 -- primitive _Disp_Requeue which handles the low-level actions.
9732 function Build_Dispatching_Requeue_To_Any return Node_Id;
9733 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9734 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9735 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9736 -- determines at runtime whether Ename denotes an entry or a procedure
9737 -- and perform the appropriate kind of dispatching select.
9739 function Build_Normal_Requeue return Node_Id;
9740 -- N denotes a nondispatching requeue statement to either a task or a
9741 -- protected entry. Build the appropriate runtime call to perform the
9744 function Build_Skip_Statement (Search : Node_Id) return Node_Id;
9745 -- For a protected entry, create a return statement to skip the rest of
9746 -- the entry body. Otherwise, create a goto statement to skip the rest
9747 -- of a task accept statement. The lookup for the enclosing entry body
9748 -- or accept statement starts from Search.
9750 ---------------------------------------
9751 -- Build_Dispatching_Call_Equivalent --
9752 ---------------------------------------
9754 function Build_Dispatching_Call_Equivalent return Node_Id is
9755 Call_Ent : constant Entity_Id := Entity (Ename);
9756 Obj : constant Node_Id := Original_Node (Concval);
9763 -- Climb the parent chain looking for the inner-most entry body or
9764 -- accept statement.
9767 while Present (Acc_Ent)
9768 and then not Nkind_In (Acc_Ent, N_Accept_Statement,
9771 Acc_Ent := Parent (Acc_Ent);
9774 -- A requeue statement should be housed inside an entry body or an
9775 -- accept statement at some level. If this is not the case, then the
9776 -- tree is malformed.
9778 pragma Assert (Present (Acc_Ent));
9780 -- Recover the list of formal parameters
9782 if Nkind (Acc_Ent) = N_Entry_Body then
9783 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
9786 Formals := Parameter_Specifications (Acc_Ent);
9788 -- Create the actual parameters for the dispatching call. These are
9789 -- simply copies of the entry body or accept statement formals in the
9790 -- same order as they appear.
9794 if Present (Formals) then
9795 Actuals := New_List;
9796 Formal := First (Formals);
9797 while Present (Formal) loop
9799 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
9805 -- Obj.Call_Ent (Actuals);
9808 Make_Procedure_Call_Statement (Loc,
9810 Make_Selected_Component (Loc,
9811 Prefix => Make_Identifier (Loc, Chars (Obj)),
9812 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))),
9814 Parameter_Associations => Actuals);
9815 end Build_Dispatching_Call_Equivalent;
9817 -------------------------------
9818 -- Build_Dispatching_Requeue --
9819 -------------------------------
9821 function Build_Dispatching_Requeue return Node_Id is
9822 Params : constant List_Id := New_List;
9825 -- Process the "with abort" parameter
9828 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
9830 -- Process the entry wrapper's position in the primary dispatch
9831 -- table parameter. Generate:
9833 -- Ada.Tags.Get_Entry_Index
9834 -- (T => To_Tag_Ptr (Obj'Address).all,
9836 -- Ada.Tags.Get_Offset_Index
9837 -- (Ada.Tags.Tag (Concval),
9838 -- <interface dispatch table position of Ename>));
9840 -- Note that Obj'Address is recursively expanded into a call to
9841 -- Base_Address (Obj).
9843 if Tagged_Type_Expansion then
9845 Make_Function_Call (Loc,
9846 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
9847 Parameter_Associations => New_List (
9849 Make_Explicit_Dereference (Loc,
9850 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
9851 Make_Attribute_Reference (Loc,
9852 Prefix => New_Copy_Tree (Concval),
9853 Attribute_Name => Name_Address))),
9855 Make_Function_Call (Loc,
9856 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
9857 Parameter_Associations => New_List (
9858 Unchecked_Convert_To (RTE (RE_Tag), Concval),
9859 Make_Integer_Literal (Loc,
9860 DT_Position (Entity (Ename))))))));
9866 Make_Function_Call (Loc,
9867 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
9868 Parameter_Associations => New_List (
9870 Make_Attribute_Reference (Loc,
9872 Attribute_Name => Name_Tag),
9874 Make_Function_Call (Loc,
9875 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
9877 Parameter_Associations => New_List (
9881 Make_Attribute_Reference (Loc,
9883 Attribute_Name => Name_Tag),
9887 Make_Attribute_Reference (Loc,
9888 Prefix => New_Occurrence_Of (Etype (Concval), Loc),
9889 Attribute_Name => Name_Tag),
9893 Make_Integer_Literal (Loc,
9894 DT_Position (Entity (Ename))))))));
9897 -- Specific actuals for protected to XXX requeue
9899 if Is_Protected_Type (Old_Typ) then
9901 Make_Attribute_Reference (Loc, -- _object'Address
9903 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
9904 Attribute_Name => Name_Address));
9906 Prepend_To (Params, -- True
9907 New_Occurrence_Of (Standard_True, Loc));
9909 -- Specific actuals for task to XXX requeue
9912 pragma Assert (Is_Task_Type (Old_Typ));
9914 Prepend_To (Params, -- null
9915 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
9917 Prepend_To (Params, -- False
9918 New_Occurrence_Of (Standard_False, Loc));
9921 -- Add the object parameter
9923 Prepend_To (Params, New_Copy_Tree (Concval));
9926 -- _Disp_Requeue (<Params>);
9928 -- Find entity for Disp_Requeue operation, which belongs to
9929 -- the type and may not be directly visible.
9936 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
9937 while Present (Elmt) loop
9939 exit when Chars (Op) = Name_uDisp_Requeue;
9944 Make_Procedure_Call_Statement (Loc,
9945 Name => New_Occurrence_Of (Op, Loc),
9946 Parameter_Associations => Params);
9948 end Build_Dispatching_Requeue;
9950 --------------------------------------
9951 -- Build_Dispatching_Requeue_To_Any --
9952 --------------------------------------
9954 function Build_Dispatching_Requeue_To_Any return Node_Id is
9955 Call_Ent : constant Entity_Id := Entity (Ename);
9956 Obj : constant Node_Id := Original_Node (Concval);
9957 Skip : constant Node_Id := Build_Skip_Statement (N);
9967 -- Dispatch table slot processing, generate:
9970 S := Build_S (Loc, Decls);
9972 -- Call kind processing, generate:
9973 -- C : Ada.Tags.Prim_Op_Kind;
9975 C := Build_C (Loc, Decls);
9978 -- S := Ada.Tags.Get_Offset_Index
9979 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
9981 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
9984 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
9987 Make_Procedure_Call_Statement (Loc,
9990 Find_Prim_Op (Etype (Etype (Obj)),
9991 Name_uDisp_Get_Prim_Op_Kind),
9993 Parameter_Associations => New_List (
9994 New_Copy_Tree (Obj),
9995 New_Occurrence_Of (S, Loc),
9996 New_Occurrence_Of (C, Loc))));
10000 -- if C = POK_Protected_Entry
10001 -- or else C = POK_Task_Entry
10004 Make_Implicit_If_Statement (N,
10010 New_Occurrence_Of (C, Loc),
10012 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
10017 New_Occurrence_Of (C, Loc),
10019 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
10021 -- Dispatching requeue equivalent
10023 Then_Statements => New_List (
10024 Build_Dispatching_Requeue,
10027 -- elsif C = POK_Protected_Procedure then
10029 Elsif_Parts => New_List (
10030 Make_Elsif_Part (Loc,
10034 New_Occurrence_Of (C, Loc),
10036 New_Occurrence_Of (
10037 RTE (RE_POK_Protected_Procedure), Loc)),
10039 -- Dispatching call equivalent
10041 Then_Statements => New_List (
10042 Build_Dispatching_Call_Equivalent))),
10045 -- raise Program_Error;
10048 Else_Statements => New_List (
10049 Make_Raise_Program_Error (Loc,
10050 Reason => PE_Explicit_Raise))));
10052 -- Wrap everything into a block
10055 Make_Block_Statement (Loc,
10056 Declarations => Decls,
10057 Handled_Statement_Sequence =>
10058 Make_Handled_Sequence_Of_Statements (Loc,
10059 Statements => Stmts));
10060 end Build_Dispatching_Requeue_To_Any;
10062 --------------------------
10063 -- Build_Normal_Requeue --
10064 --------------------------
10066 function Build_Normal_Requeue return Node_Id is
10067 Params : constant List_Id := New_List;
10072 -- Process the "with abort" parameter
10074 Prepend_To (Params,
10075 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10077 -- Add the index expression to the parameters. It is common among all
10080 Prepend_To (Params,
10081 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
10083 if Is_Protected_Type (Old_Typ) then
10085 Self_Param : Node_Id;
10089 Make_Attribute_Reference (Loc,
10091 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10093 Name_Unchecked_Access);
10095 -- Protected to protected requeue
10097 if Is_Protected_Type (Conc_Typ) then
10099 New_Occurrence_Of (
10100 RTE (RE_Requeue_Protected_Entry), Loc);
10103 Make_Attribute_Reference (Loc,
10105 Concurrent_Ref (Concval),
10107 Name_Unchecked_Access);
10109 -- Protected to task requeue
10111 else pragma Assert (Is_Task_Type (Conc_Typ));
10113 New_Occurrence_Of (
10114 RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
10116 Param := Concurrent_Ref (Concval);
10119 Prepend_To (Params, Param);
10120 Prepend_To (Params, Self_Param);
10123 else pragma Assert (Is_Task_Type (Old_Typ));
10125 -- Task to protected requeue
10127 if Is_Protected_Type (Conc_Typ) then
10129 New_Occurrence_Of (
10130 RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
10133 Make_Attribute_Reference (Loc,
10135 Concurrent_Ref (Concval),
10137 Name_Unchecked_Access);
10139 -- Task to task requeue
10141 else pragma Assert (Is_Task_Type (Conc_Typ));
10143 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc);
10145 Param := Concurrent_Ref (Concval);
10148 Prepend_To (Params, Param);
10152 Make_Procedure_Call_Statement (Loc,
10154 Parameter_Associations => Params);
10155 end Build_Normal_Requeue;
10157 --------------------------
10158 -- Build_Skip_Statement --
10159 --------------------------
10161 function Build_Skip_Statement (Search : Node_Id) return Node_Id is
10162 Skip_Stmt : Node_Id;
10165 -- Build a return statement to skip the rest of the entire body
10167 if Is_Protected_Type (Old_Typ) then
10168 Skip_Stmt := Make_Simple_Return_Statement (Loc);
10170 -- If the requeue is within a task, find the end label of the
10171 -- enclosing accept statement and create a goto statement to it.
10179 -- Climb the parent chain looking for the enclosing accept
10182 Acc := Parent (Search);
10183 while Present (Acc)
10184 and then Nkind (Acc) /= N_Accept_Statement
10186 Acc := Parent (Acc);
10189 -- The last statement is the second label used for completing
10190 -- the rendezvous the usual way. The label we are looking for
10191 -- is right before it.
10194 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
10196 pragma Assert (Nkind (Label) = N_Label);
10198 -- Generate a goto statement to skip the rest of the accept
10201 Make_Goto_Statement (Loc,
10203 New_Occurrence_Of (Entity (Identifier (Label)), Loc));
10207 Set_Analyzed (Skip_Stmt);
10210 end Build_Skip_Statement;
10212 -- Start of processing for Expand_N_Requeue_Statement
10215 -- Extract the components of the entry call
10217 Extract_Entry (N, Concval, Ename, Index);
10218 Conc_Typ := Etype (Concval);
10220 -- If the prefix is an access to class-wide type, dereference to get
10221 -- object and entry type.
10223 if Is_Access_Type (Conc_Typ) then
10224 Conc_Typ := Designated_Type (Conc_Typ);
10226 Make_Explicit_Dereference (Loc, Relocate_Node (Concval)));
10227 Analyze_And_Resolve (Concval, Conc_Typ);
10230 -- Examine the scope stack in order to find nearest enclosing protected
10231 -- or task type. This will constitute our invocation source.
10233 Old_Typ := Current_Scope;
10234 while Present (Old_Typ)
10235 and then not Is_Protected_Type (Old_Typ)
10236 and then not Is_Task_Type (Old_Typ)
10238 Old_Typ := Scope (Old_Typ);
10241 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10242 -- Concval.Ename where the type of Concval is class-wide concurrent
10245 if Ada_Version >= Ada_2012
10246 and then Present (Concval)
10247 and then Is_Class_Wide_Type (Conc_Typ)
10248 and then Is_Concurrent_Interface (Conc_Typ)
10251 Has_Impl : Boolean := False;
10252 Impl_Kind : Name_Id := No_Name;
10255 -- Check whether the Ename is flagged by pragma Implemented
10257 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
10259 Impl_Kind := Implementation_Kind (Entity (Ename));
10262 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10263 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10265 if Has_Impl and then Impl_Kind = Name_By_Entry then
10266 Rewrite (N, Build_Dispatching_Requeue);
10268 Insert_After (N, Build_Skip_Statement (N));
10270 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10271 -- a protected procedure. In this case the requeue is transformed
10272 -- into a dispatching call.
10275 and then Impl_Kind = Name_By_Protected_Procedure
10277 Rewrite (N, Build_Dispatching_Call_Equivalent);
10280 -- The procedure_or_entry_NAME's implementation kind is either
10281 -- By_Any, Optional, or pragma Implemented was not applied at all.
10282 -- In this case a runtime test determines whether Ename denotes an
10283 -- entry or a protected procedure and performs the appropriate
10287 Rewrite (N, Build_Dispatching_Requeue_To_Any);
10292 -- Processing for regular (nondispatching) requeues
10295 Rewrite (N, Build_Normal_Requeue);
10297 Insert_After (N, Build_Skip_Statement (N));
10299 end Expand_N_Requeue_Statement;
10301 -------------------------------
10302 -- Expand_N_Selective_Accept --
10303 -------------------------------
10305 procedure Expand_N_Selective_Accept (N : Node_Id) is
10306 Loc : constant Source_Ptr := Sloc (N);
10307 Alts : constant List_Id := Select_Alternatives (N);
10309 -- Note: in the below declarations a lot of new lists are allocated
10310 -- unconditionally which may well not end up being used. That's not
10311 -- a good idea since it wastes space gratuitously ???
10313 Accept_Case : List_Id;
10314 Accept_List : constant List_Id := New_List;
10317 Alt_List : constant List_Id := New_List;
10318 Alt_Stats : List_Id;
10319 Ann : Entity_Id := Empty;
10321 Check_Guard : Boolean := True;
10323 Decls : constant List_Id := New_List;
10324 Stats : constant List_Id := New_List;
10325 Body_List : constant List_Id := New_List;
10326 Trailing_List : constant List_Id := New_List;
10329 Else_Present : Boolean := False;
10330 Terminate_Alt : Node_Id := Empty;
10331 Select_Mode : Node_Id;
10333 Delay_Case : List_Id;
10334 Delay_Count : Integer := 0;
10335 Delay_Val : Entity_Id;
10336 Delay_Index : Entity_Id;
10337 Delay_Min : Entity_Id;
10338 Delay_Num : Pos := 1;
10339 Delay_Alt_List : List_Id := New_List;
10340 Delay_List : constant List_Id := New_List;
10344 First_Delay : Boolean := True;
10345 Guard_Open : Entity_Id;
10351 Num_Accept : Nat := 0;
10353 Time_Type : Entity_Id;
10354 Select_Call : Node_Id;
10356 Qnam : constant Entity_Id :=
10357 Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
10359 Xnam : constant Entity_Id :=
10360 Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
10362 -----------------------
10363 -- Local subprograms --
10364 -----------------------
10366 function Accept_Or_Raise return List_Id;
10367 -- For the rare case where delay alternatives all have guards, and
10368 -- all of them are closed, it is still possible that there were open
10369 -- accept alternatives with no callers. We must reexamine the
10370 -- Accept_List, and execute a selective wait with no else if some
10371 -- accept is open. If none, we raise program_error.
10373 procedure Add_Accept (Alt : Node_Id);
10374 -- Process a single accept statement in a select alternative. Build
10375 -- procedure for body of accept, and add entry to dispatch table with
10376 -- expression for guard, in preparation for call to run time select.
10378 function Make_And_Declare_Label (Num : Int) return Node_Id;
10379 -- Manufacture a label using Num as a serial number and declare it.
10380 -- The declaration is appended to Decls. The label marks the trailing
10381 -- statements of an accept or delay alternative.
10383 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
10384 -- Build call to Selective_Wait runtime routine
10386 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
10387 -- Add code to compare value of delay with previous values, and
10388 -- generate case entry for trailing statements.
10390 procedure Process_Accept_Alternative
10394 -- Add code to call corresponding procedure, and branch to
10395 -- trailing statements, if any.
10397 ---------------------
10398 -- Accept_Or_Raise --
10399 ---------------------
10401 function Accept_Or_Raise return List_Id is
10404 J : constant Entity_Id := Make_Temporary (Loc, 'J');
10407 -- We generate the following:
10409 -- for J in q'range loop
10410 -- if q(J).S /=null_task_entry then
10411 -- selective_wait (simple_mode,...);
10417 -- if no rendez_vous then
10418 -- raise program_error;
10421 -- Note that the code needs to know that the selector name
10422 -- in an Accept_Alternative is named S.
10424 Cond := Make_Op_Ne (Loc,
10426 Make_Selected_Component (Loc,
10428 Make_Indexed_Component (Loc,
10429 Prefix => New_Occurrence_Of (Qnam, Loc),
10430 Expressions => New_List (New_Occurrence_Of (J, Loc))),
10431 Selector_Name => Make_Identifier (Loc, Name_S)),
10433 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc));
10435 Stats := New_List (
10436 Make_Implicit_Loop_Statement (N,
10437 Iteration_Scheme =>
10438 Make_Iteration_Scheme (Loc,
10439 Loop_Parameter_Specification =>
10440 Make_Loop_Parameter_Specification (Loc,
10441 Defining_Identifier => J,
10442 Discrete_Subtype_Definition =>
10443 Make_Attribute_Reference (Loc,
10444 Prefix => New_Occurrence_Of (Qnam, Loc),
10445 Attribute_Name => Name_Range,
10446 Expressions => New_List (
10447 Make_Integer_Literal (Loc, 1))))),
10449 Statements => New_List (
10450 Make_Implicit_If_Statement (N,
10452 Then_Statements => New_List (
10454 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)),
10455 Make_Exit_Statement (Loc))))));
10458 Make_Raise_Program_Error (Loc,
10459 Condition => Make_Op_Eq (Loc,
10460 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
10462 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
10463 Reason => PE_All_Guards_Closed));
10466 end Accept_Or_Raise;
10472 procedure Add_Accept (Alt : Node_Id) is
10473 Acc_Stm : constant Node_Id := Accept_Statement (Alt);
10474 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm);
10475 Eloc : constant Source_Ptr := Sloc (Ename);
10476 Eent : constant Entity_Id := Entity (Ename);
10477 Index : constant Node_Id := Entry_Index (Acc_Stm);
10478 Null_Body : Node_Id;
10479 Proc_Body : Node_Id;
10480 PB_Ent : Entity_Id;
10486 Ann := Node (Last_Elmt (Accept_Address (Eent)));
10489 if Present (Condition (Alt)) then
10491 Make_If_Expression (Eloc, New_List (
10493 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
10494 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc)));
10497 Entry_Index_Expression
10498 (Eloc, Eent, Index, Scope (Eent));
10501 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
10502 Null_Body := New_Occurrence_Of (Standard_False, Eloc);
10504 -- Always add call to Abort_Undefer when generating code, since
10505 -- this is what the runtime expects (abort deferred in
10506 -- Selective_Wait). In CodePeer mode this only confuses the
10507 -- analysis with unknown calls, so don't do it.
10509 if not CodePeer_Mode then
10510 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
10512 (First (Statements (Handled_Statement_Sequence
10513 (Accept_Statement (Alt)))),
10519 Make_Defining_Identifier (Eloc,
10520 New_External_Name (Chars (Ename), 'A', Num_Accept));
10522 if Comes_From_Source (Alt) then
10523 Set_Debug_Info_Needed (PB_Ent);
10527 Make_Subprogram_Body (Eloc,
10529 Make_Procedure_Specification (Eloc,
10530 Defining_Unit_Name => PB_Ent),
10531 Declarations => Declarations (Acc_Stm),
10532 Handled_Statement_Sequence =>
10533 Build_Accept_Body (Accept_Statement (Alt)));
10535 -- During the analysis of the body of the accept statement, any
10536 -- zero cost exception handler records were collected in the
10537 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10538 -- This is where we move them to where they belong, namely the
10539 -- newly created procedure.
10541 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
10542 Append (Proc_Body, Body_List);
10545 Null_Body := New_Occurrence_Of (Standard_True, Eloc);
10547 -- if accept statement has declarations, insert above, given that
10548 -- we are not creating a body for the accept.
10550 if Present (Declarations (Acc_Stm)) then
10551 Insert_Actions (N, Declarations (Acc_Stm));
10555 Append_To (Accept_List,
10556 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr)));
10558 Num_Accept := Num_Accept + 1;
10561 ----------------------------
10562 -- Make_And_Declare_Label --
10563 ----------------------------
10565 function Make_And_Declare_Label (Num : Int) return Node_Id is
10569 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
10571 Make_Label (Loc, Lab_Id);
10574 Make_Implicit_Label_Declaration (Loc,
10575 Defining_Identifier =>
10576 Make_Defining_Identifier (Loc, Chars (Lab_Id)),
10577 Label_Construct => Lab));
10580 end Make_And_Declare_Label;
10582 ----------------------
10583 -- Make_Select_Call --
10584 ----------------------
10586 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
10587 Params : constant List_Id := New_List;
10591 Make_Attribute_Reference (Loc,
10592 Prefix => New_Occurrence_Of (Qnam, Loc),
10593 Attribute_Name => Name_Unchecked_Access));
10594 Append_To (Params, Select_Mode);
10595 Append_To (Params, New_Occurrence_Of (Ann, Loc));
10596 Append_To (Params, New_Occurrence_Of (Xnam, Loc));
10599 Make_Procedure_Call_Statement (Loc,
10600 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc),
10601 Parameter_Associations => Params);
10602 end Make_Select_Call;
10604 --------------------------------
10605 -- Process_Accept_Alternative --
10606 --------------------------------
10608 procedure Process_Accept_Alternative
10613 Astmt : constant Node_Id := Accept_Statement (Alt);
10614 Alt_Stats : List_Id;
10617 Adjust_Condition (Condition (Alt));
10619 -- Accept with body
10621 if Present (Handled_Statement_Sequence (Astmt)) then
10624 Make_Procedure_Call_Statement (Sloc (Proc),
10627 (Defining_Unit_Name (Specification (Proc)),
10630 -- Accept with no body (followed by trailing statements)
10633 Alt_Stats := Empty_List;
10636 Ensure_Statement_Present (Sloc (Astmt), Alt);
10638 -- After the call, if any, branch to trailing statements, if any.
10639 -- We create a label for each, as well as the corresponding label
10642 if not Is_Empty_List (Statements (Alt)) then
10643 Lab := Make_And_Declare_Label (Index);
10644 Append (Lab, Trailing_List);
10645 Append_List (Statements (Alt), Trailing_List);
10646 Append_To (Trailing_List,
10647 Make_Goto_Statement (Loc,
10648 Name => New_Copy (Identifier (End_Lab))));
10654 Append_To (Alt_Stats,
10655 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab))));
10657 Append_To (Alt_List,
10658 Make_Case_Statement_Alternative (Loc,
10659 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)),
10660 Statements => Alt_Stats));
10661 end Process_Accept_Alternative;
10663 -------------------------------
10664 -- Process_Delay_Alternative --
10665 -------------------------------
10667 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
10668 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt));
10670 Delay_Alt : List_Id;
10673 -- Deal with C/Fortran boolean as delay condition
10675 Adjust_Condition (Condition (Alt));
10677 -- Determine the smallest specified delay
10679 -- for each delay alternative generate:
10681 -- if guard-expression then
10682 -- Delay_Val := delay-expression;
10683 -- Guard_Open := True;
10684 -- if Delay_Val < Delay_Min then
10685 -- Delay_Min := Delay_Val;
10686 -- Delay_Index := Index;
10690 -- The enclosing if-statement is omitted if there is no guard
10692 if Delay_Count = 1 or else First_Delay then
10693 First_Delay := False;
10695 Delay_Alt := New_List (
10696 Make_Assignment_Statement (Loc,
10697 Name => New_Occurrence_Of (Delay_Min, Loc),
10698 Expression => Expression (Delay_Statement (Alt))));
10700 if Delay_Count > 1 then
10701 Append_To (Delay_Alt,
10702 Make_Assignment_Statement (Loc,
10703 Name => New_Occurrence_Of (Delay_Index, Loc),
10704 Expression => Make_Integer_Literal (Loc, Index)));
10708 Delay_Alt := New_List (
10709 Make_Assignment_Statement (Loc,
10710 Name => New_Occurrence_Of (Delay_Val, Loc),
10711 Expression => Expression (Delay_Statement (Alt))));
10713 if Time_Type = Standard_Duration then
10716 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc),
10717 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc));
10720 -- The scope of the time type must define a comparison
10721 -- operator. The scope itself may not be visible, so we
10722 -- construct a node with entity information to insure that
10723 -- semantic analysis can find the proper operator.
10726 Make_Function_Call (Loc,
10727 Name => Make_Selected_Component (Loc,
10729 New_Occurrence_Of (Scope (Time_Type), Loc),
10731 Make_Operator_Symbol (Loc,
10732 Chars => Name_Op_Lt,
10733 Strval => No_String)),
10734 Parameter_Associations =>
10736 New_Occurrence_Of (Delay_Val, Loc),
10737 New_Occurrence_Of (Delay_Min, Loc)));
10739 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
10742 Append_To (Delay_Alt,
10743 Make_Implicit_If_Statement (N,
10745 Then_Statements => New_List (
10746 Make_Assignment_Statement (Loc,
10747 Name => New_Occurrence_Of (Delay_Min, Loc),
10748 Expression => New_Occurrence_Of (Delay_Val, Loc)),
10750 Make_Assignment_Statement (Loc,
10751 Name => New_Occurrence_Of (Delay_Index, Loc),
10752 Expression => Make_Integer_Literal (Loc, Index)))));
10755 if Check_Guard then
10756 Append_To (Delay_Alt,
10757 Make_Assignment_Statement (Loc,
10758 Name => New_Occurrence_Of (Guard_Open, Loc),
10759 Expression => New_Occurrence_Of (Standard_True, Loc)));
10762 if Present (Condition (Alt)) then
10763 Delay_Alt := New_List (
10764 Make_Implicit_If_Statement (N,
10765 Condition => Condition (Alt),
10766 Then_Statements => Delay_Alt));
10769 Append_List (Delay_Alt, Delay_List);
10771 Ensure_Statement_Present (Dloc, Alt);
10773 -- If the delay alternative has a statement part, add choice to the
10774 -- case statements for delays.
10776 if not Is_Empty_List (Statements (Alt)) then
10778 if Delay_Count = 1 then
10779 Append_List (Statements (Alt), Delay_Alt_List);
10782 Append_To (Delay_Alt_List,
10783 Make_Case_Statement_Alternative (Loc,
10784 Discrete_Choices => New_List (
10785 Make_Integer_Literal (Loc, Index)),
10786 Statements => Statements (Alt)));
10789 elsif Delay_Count = 1 then
10791 -- If the single delay has no trailing statements, add a branch
10792 -- to the exit label to the selective wait.
10794 Delay_Alt_List := New_List (
10795 Make_Goto_Statement (Loc,
10796 Name => New_Copy (Identifier (End_Lab))));
10799 end Process_Delay_Alternative;
10801 -- Start of processing for Expand_N_Selective_Accept
10804 Process_Statements_For_Controlled_Objects (N);
10806 -- First insert some declarations before the select. The first is:
10810 -- This variable holds the parameters passed to the accept body. This
10811 -- declaration has already been inserted by the time we get here by
10812 -- a call to Expand_Accept_Declarations made from the semantics when
10813 -- processing the first accept statement contained in the select. We
10814 -- can find this entity as Accept_Address (E), where E is any of the
10815 -- entries references by contained accept statements.
10817 -- The first step is to scan the list of Selective_Accept_Statements
10818 -- to find this entity, and also count the number of accepts, and
10819 -- determine if terminated, delay or else is present:
10823 Alt := First (Alts);
10824 while Present (Alt) loop
10825 Process_Statements_For_Controlled_Objects (Alt);
10827 if Nkind (Alt) = N_Accept_Alternative then
10830 elsif Nkind (Alt) = N_Delay_Alternative then
10831 Delay_Count := Delay_Count + 1;
10833 -- If the delays are relative delays, the delay expressions have
10834 -- type Standard_Duration. Otherwise they must have some time type
10835 -- recognized by GNAT.
10837 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
10838 Time_Type := Standard_Duration;
10840 Time_Type := Etype (Expression (Delay_Statement (Alt)));
10842 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
10843 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
10848 "& is not a time type (RM 9.6(6))",
10849 Expression (Delay_Statement (Alt)), Time_Type);
10850 Time_Type := Standard_Duration;
10851 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
10855 if No (Condition (Alt)) then
10857 -- This guard will always be open
10859 Check_Guard := False;
10862 elsif Nkind (Alt) = N_Terminate_Alternative then
10863 Adjust_Condition (Condition (Alt));
10864 Terminate_Alt := Alt;
10867 Num_Alts := Num_Alts + 1;
10871 Else_Present := Present (Else_Statements (N));
10873 -- At the same time (see procedure Add_Accept) we build the accept list:
10875 -- Qnn : Accept_List (1 .. num-select) := (
10876 -- (null-body, entry-index),
10877 -- (null-body, entry-index),
10879 -- (null_body, entry-index));
10881 -- In the above declaration, null-body is True if the corresponding
10882 -- accept has no body, and false otherwise. The entry is either the
10883 -- entry index expression if there is no guard, or if a guard is
10884 -- present, then an if expression of the form:
10886 -- (if guard then entry-index else Null_Task_Entry)
10888 -- If a guard is statically known to be false, the entry can simply
10889 -- be omitted from the accept list.
10892 Make_Object_Declaration (Loc,
10893 Defining_Identifier => Qnam,
10894 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc),
10895 Aliased_Present => True,
10897 Make_Qualified_Expression (Loc,
10899 New_Occurrence_Of (RTE (RE_Accept_List), Loc),
10901 Make_Aggregate (Loc, Expressions => Accept_List))));
10903 -- Then we declare the variable that holds the index for the accept
10904 -- that will be selected for service:
10906 -- Xnn : Select_Index;
10909 Make_Object_Declaration (Loc,
10910 Defining_Identifier => Xnam,
10911 Object_Definition =>
10912 New_Occurrence_Of (RTE (RE_Select_Index), Loc),
10914 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)));
10916 -- After this follow procedure declarations for each accept body
10918 -- procedure Pnn is
10923 -- where the ... are statements from the corresponding procedure body.
10924 -- No parameters are involved, since the parameters are passed via Ann
10925 -- and the parameter references have already been expanded to be direct
10926 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
10927 -- any embedded tasking statements (which would normally be illegal in
10928 -- procedures), have been converted to calls to the tasking runtime so
10929 -- there is no problem in putting them into procedures.
10931 -- The original accept statement has been expanded into a block in
10932 -- the same fashion as for simple accepts (see Build_Accept_Body).
10934 -- Note: we don't really need to build these procedures for the case
10935 -- where no delay statement is present, but it is just as easy to
10936 -- build them unconditionally, and not significantly inefficient,
10937 -- since if they are short they will be inlined anyway.
10939 -- The procedure declarations have been assembled in Body_List
10941 -- If delays are present, we must compute the required delay.
10942 -- We first generate the declarations:
10944 -- Delay_Index : Boolean := 0;
10945 -- Delay_Min : Some_Time_Type.Time;
10946 -- Delay_Val : Some_Time_Type.Time;
10948 -- Delay_Index will be set to the index of the minimum delay, i.e. the
10949 -- active delay that is actually chosen as the basis for the possible
10950 -- delay if an immediate rendez-vous is not possible.
10952 -- In the most common case there is a single delay statement, and this
10953 -- is handled specially.
10955 if Delay_Count > 0 then
10957 -- Generate the required declarations
10960 Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
10962 Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
10964 Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
10967 Make_Object_Declaration (Loc,
10968 Defining_Identifier => Delay_Val,
10969 Object_Definition => New_Occurrence_Of (Time_Type, Loc)));
10972 Make_Object_Declaration (Loc,
10973 Defining_Identifier => Delay_Index,
10974 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
10975 Expression => Make_Integer_Literal (Loc, 0)));
10978 Make_Object_Declaration (Loc,
10979 Defining_Identifier => Delay_Min,
10980 Object_Definition => New_Occurrence_Of (Time_Type, Loc),
10982 Unchecked_Convert_To (Time_Type,
10983 Make_Attribute_Reference (Loc,
10985 New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
10986 Attribute_Name => Name_Last))));
10988 -- Create Duration and Delay_Mode objects used for passing a delay
10991 D := Make_Temporary (Loc, 'D');
10992 M := Make_Temporary (Loc, 'M');
10998 -- Note that these values are defined in s-osprim.ads and must
10999 -- be kept in sync:
11001 -- Relative : constant := 0;
11002 -- Absolute_Calendar : constant := 1;
11003 -- Absolute_RT : constant := 2;
11005 if Time_Type = Standard_Duration then
11006 Discr := Make_Integer_Literal (Loc, 0);
11008 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11009 Discr := Make_Integer_Literal (Loc, 1);
11013 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11014 Discr := Make_Integer_Literal (Loc, 2);
11018 Make_Object_Declaration (Loc,
11019 Defining_Identifier => D,
11020 Object_Definition =>
11021 New_Occurrence_Of (Standard_Duration, Loc)));
11024 Make_Object_Declaration (Loc,
11025 Defining_Identifier => M,
11026 Object_Definition =>
11027 New_Occurrence_Of (Standard_Integer, Loc),
11028 Expression => Discr));
11031 if Check_Guard then
11033 Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
11036 Make_Object_Declaration (Loc,
11037 Defining_Identifier => Guard_Open,
11038 Object_Definition =>
11039 New_Occurrence_Of (Standard_Boolean, Loc),
11041 New_Occurrence_Of (Standard_False, Loc)));
11044 -- Delay_Count is zero, don't need M and D set (suppress warning)
11051 if Present (Terminate_Alt) then
11053 -- If the terminate alternative guard is False, use
11054 -- Simple_Mode; otherwise use Terminate_Mode.
11056 if Present (Condition (Terminate_Alt)) then
11057 Select_Mode := Make_If_Expression (Loc,
11058 New_List (Condition (Terminate_Alt),
11059 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc),
11060 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)));
11062 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc);
11065 elsif Else_Present or Delay_Count > 0 then
11066 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc);
11069 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc);
11072 Select_Call := Make_Select_Call (Select_Mode);
11073 Append (Select_Call, Stats);
11075 -- Now generate code to act on the result. There is an entry
11076 -- in this case for each accept statement with a non-null body,
11077 -- followed by a branch to the statements that follow the Accept.
11078 -- In the absence of delay alternatives, we generate:
11081 -- when No_Rendezvous => -- omitted if simple mode
11096 -- Lab0: Else_Statements;
11099 -- Lab1: Trailing_Statements1;
11102 -- Lab2: Trailing_Statements2;
11107 -- Generate label for common exit
11109 End_Lab := Make_And_Declare_Label (Num_Alts + 1);
11111 -- First entry is the default case, when no rendezvous is possible
11113 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc));
11115 if Else_Present then
11117 -- If no rendezvous is possible, the else part is executed
11119 Lab := Make_And_Declare_Label (0);
11120 Alt_Stats := New_List (
11121 Make_Goto_Statement (Loc,
11122 Name => New_Copy (Identifier (Lab))));
11124 Append (Lab, Trailing_List);
11125 Append_List (Else_Statements (N), Trailing_List);
11126 Append_To (Trailing_List,
11127 Make_Goto_Statement (Loc,
11128 Name => New_Copy (Identifier (End_Lab))));
11130 Alt_Stats := New_List (
11131 Make_Goto_Statement (Loc,
11132 Name => New_Copy (Identifier (End_Lab))));
11135 Append_To (Alt_List,
11136 Make_Case_Statement_Alternative (Loc,
11137 Discrete_Choices => Choices,
11138 Statements => Alt_Stats));
11140 -- We make use of the fact that Accept_Index is an integer type, and
11141 -- generate successive literals for entries for each accept. Only those
11142 -- for which there is a body or trailing statements get a case entry.
11144 Alt := First (Select_Alternatives (N));
11145 Proc := First (Body_List);
11146 while Present (Alt) loop
11148 if Nkind (Alt) = N_Accept_Alternative then
11149 Process_Accept_Alternative (Alt, Index, Proc);
11150 Index := Index + 1;
11153 (Handled_Statement_Sequence (Accept_Statement (Alt)))
11158 elsif Nkind (Alt) = N_Delay_Alternative then
11159 Process_Delay_Alternative (Alt, Delay_Num);
11160 Delay_Num := Delay_Num + 1;
11166 -- An others choice is always added to the main case, as well
11167 -- as the delay case (to satisfy the compiler).
11169 Append_To (Alt_List,
11170 Make_Case_Statement_Alternative (Loc,
11171 Discrete_Choices =>
11172 New_List (Make_Others_Choice (Loc)),
11174 New_List (Make_Goto_Statement (Loc,
11175 Name => New_Copy (Identifier (End_Lab))))));
11177 Accept_Case := New_List (
11178 Make_Case_Statement (Loc,
11179 Expression => New_Occurrence_Of (Xnam, Loc),
11180 Alternatives => Alt_List));
11182 Append_List (Trailing_List, Accept_Case);
11183 Append_List (Body_List, Decls);
11185 -- Construct case statement for trailing statements of delay
11186 -- alternatives, if there are several of them.
11188 if Delay_Count > 1 then
11189 Append_To (Delay_Alt_List,
11190 Make_Case_Statement_Alternative (Loc,
11191 Discrete_Choices =>
11192 New_List (Make_Others_Choice (Loc)),
11194 New_List (Make_Null_Statement (Loc))));
11196 Delay_Case := New_List (
11197 Make_Case_Statement (Loc,
11198 Expression => New_Occurrence_Of (Delay_Index, Loc),
11199 Alternatives => Delay_Alt_List));
11201 Delay_Case := Delay_Alt_List;
11204 -- If there are no delay alternatives, we append the case statement
11205 -- to the statement list.
11207 if Delay_Count = 0 then
11208 Append_List (Accept_Case, Stats);
11210 -- Delay alternatives present
11213 -- If delay alternatives are present we generate:
11215 -- find minimum delay.
11216 -- DX := minimum delay;
11217 -- M := <delay mode>;
11218 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11221 -- if X = No_Rendezvous then
11222 -- case statement for delay statements.
11224 -- case statement for accept alternatives.
11235 -- The type of the delay expression is known to be legal
11237 if Time_Type = Standard_Duration then
11238 Conv := New_Occurrence_Of (Delay_Min, Loc);
11240 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11241 Conv := Make_Function_Call (Loc,
11242 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
11243 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11247 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11249 Conv := Make_Function_Call (Loc,
11250 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
11251 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11254 Stmt := Make_Assignment_Statement (Loc,
11255 Name => New_Occurrence_Of (D, Loc),
11256 Expression => Conv);
11258 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11260 Parms := Parameter_Associations (Select_Call);
11262 Parm := First (Parms);
11263 while Present (Parm) and then Parm /= Select_Mode loop
11267 pragma Assert (Present (Parm));
11268 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc));
11271 -- Prepare two new parameters of Duration and Delay_Mode type
11272 -- which represent the value and the mode of the minimum delay.
11275 Insert_After (Parm, New_Occurrence_Of (M, Loc));
11276 Insert_After (Parm, New_Occurrence_Of (D, Loc));
11278 -- Create a call to RTS
11280 Rewrite (Select_Call,
11281 Make_Procedure_Call_Statement (Loc,
11282 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc),
11283 Parameter_Associations => Parms));
11285 -- This new call should follow the calculation of the minimum
11288 Insert_List_Before (Select_Call, Delay_List);
11290 if Check_Guard then
11292 Make_Implicit_If_Statement (N,
11293 Condition => New_Occurrence_Of (Guard_Open, Loc),
11294 Then_Statements => New_List (
11295 New_Copy_Tree (Stmt),
11296 New_Copy_Tree (Select_Call)),
11297 Else_Statements => Accept_Or_Raise);
11298 Rewrite (Select_Call, Stmt);
11300 Insert_Before (Select_Call, Stmt);
11304 Make_Implicit_If_Statement (N,
11305 Condition => Make_Op_Eq (Loc,
11306 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
11308 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
11310 Then_Statements => Delay_Case,
11311 Else_Statements => Accept_Case);
11313 Append (Cases, Stats);
11317 Append (End_Lab, Stats);
11319 -- Replace accept statement with appropriate block
11322 Make_Block_Statement (Loc,
11323 Declarations => Decls,
11324 Handled_Statement_Sequence =>
11325 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)));
11328 -- Note: have to worry more about abort deferral in above code ???
11330 -- Final step is to unstack the Accept_Address entries for all accept
11331 -- statements appearing in accept alternatives in the select statement
11333 Alt := First (Alts);
11334 while Present (Alt) loop
11335 if Nkind (Alt) = N_Accept_Alternative then
11336 Remove_Last_Elmt (Accept_Address
11337 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
11342 end Expand_N_Selective_Accept;
11344 -------------------------------------------
11345 -- Expand_N_Single_Protected_Declaration --
11346 -------------------------------------------
11348 -- A single protected declaration should never be present after semantic
11349 -- analysis because it is transformed into a protected type declaration
11350 -- and an accompanying anonymous object. This routine ensures that the
11351 -- transformation takes place.
11353 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is
11355 raise Program_Error;
11356 end Expand_N_Single_Protected_Declaration;
11358 --------------------------------------
11359 -- Expand_N_Single_Task_Declaration --
11360 --------------------------------------
11362 -- A single task declaration should never be present after semantic
11363 -- analysis because it is transformed into a task type declaration and
11364 -- an accompanying anonymous object. This routine ensures that the
11365 -- transformation takes place.
11367 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
11369 raise Program_Error;
11370 end Expand_N_Single_Task_Declaration;
11372 ------------------------
11373 -- Expand_N_Task_Body --
11374 ------------------------
11376 -- Given a task body
11378 -- task body tname is
11384 -- This expansion routine converts it into a procedure and sets the
11385 -- elaboration flag for the procedure to true, to represent the fact
11386 -- that the task body is now elaborated:
11388 -- procedure tnameB (_Task : access tnameV) is
11389 -- discriminal : dtype renames _Task.discriminant;
11391 -- procedure _clean is
11393 -- Abort_Defer.all;
11395 -- Abort_Undefer.all;
11400 -- Abort_Undefer.all;
11402 -- System.Task_Stages.Complete_Activation;
11410 -- In addition, if the task body is an activator, then a call to activate
11411 -- tasks is added at the start of the statements, before the call to
11412 -- Complete_Activation, and if in addition the task is a master then it
11413 -- must be established as a master. These calls are inserted and analyzed
11414 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11417 -- There is one discriminal declaration line generated for each
11418 -- discriminant that is present to provide an easy reference point for
11419 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11421 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11422 -- task body procedures have a profile (Arg : System.Address). That is
11423 -- needed because GNARLI has to use the same access-to-subprogram type
11424 -- for all task types. We depend here on knowing that in GNAT, passing
11425 -- an address argument by value is identical to passing a record value
11426 -- by access (in either case a single pointer is passed), so even though
11427 -- this procedure has the wrong profile. In fact it's all OK, since the
11428 -- callings sequence is identical.
11430 procedure Expand_N_Task_Body (N : Node_Id) is
11431 Loc : constant Source_Ptr := Sloc (N);
11432 Ttyp : constant Entity_Id := Corresponding_Spec (N);
11436 Insert_Nod : Node_Id;
11437 -- Used to determine the proper location of wrapper body insertions
11440 -- if no task body procedure, means we had an error in configurable
11441 -- run-time mode, and there is no point in proceeding further.
11443 if No (Task_Body_Procedure (Ttyp)) then
11447 -- Add renaming declarations for discriminals and a declaration for the
11448 -- entry family index (if applicable).
11450 Install_Private_Data_Declarations
11451 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N));
11453 -- Add a call to Abort_Undefer at the very beginning of the task
11454 -- body since this body is called with abort still deferred.
11456 if Abort_Allowed then
11457 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
11459 (First (Statements (Handled_Statement_Sequence (N))), Call);
11463 -- The statement part has already been protected with an at_end and
11464 -- cleanup actions. The call to Complete_Activation must be placed
11465 -- at the head of the sequence of statements of that block. The
11466 -- declarations have been merged in this sequence of statements but
11467 -- the first real statement is accessible from the First_Real_Statement
11468 -- field (which was set for exactly this purpose).
11470 if Restricted_Profile then
11471 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
11473 Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
11477 (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
11481 Make_Subprogram_Body (Loc,
11482 Specification => Build_Task_Proc_Specification (Ttyp),
11483 Declarations => Declarations (N),
11484 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
11485 Set_Is_Task_Body_Procedure (New_N);
11487 -- If the task contains generic instantiations, cleanup actions are
11488 -- delayed until after instantiation. Transfer the activation chain to
11489 -- the subprogram, to insure that the activation call is properly
11490 -- generated. It the task body contains inner tasks, indicate that the
11491 -- subprogram is a task master.
11493 if Delay_Cleanups (Ttyp) then
11494 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
11495 Set_Is_Task_Master (New_N, Is_Task_Master (N));
11498 Rewrite (N, New_N);
11501 -- Set elaboration flag immediately after task body. If the body is a
11502 -- subunit, the flag is set in the declarative part containing the stub.
11504 if Nkind (Parent (N)) /= N_Subunit then
11506 Make_Assignment_Statement (Loc,
11508 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
11509 Expression => New_Occurrence_Of (Standard_True, Loc)));
11512 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11513 -- the task body. At this point all wrapper specs have been created,
11514 -- frozen and included in the dispatch table for the task type.
11516 if Ada_Version >= Ada_2005 then
11517 if Nkind (Parent (N)) = N_Subunit then
11518 Insert_Nod := Corresponding_Stub (Parent (N));
11523 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
11525 end Expand_N_Task_Body;
11527 ------------------------------------
11528 -- Expand_N_Task_Type_Declaration --
11529 ------------------------------------
11531 -- We have several things to do. First we must create a Boolean flag used
11532 -- to mark if the body is elaborated yet. This variable gets set to True
11533 -- when the body of the task is elaborated (we can't rely on the normal
11534 -- ABE mechanism for the task body, since we need to pass an access to
11535 -- this elaboration boolean to the runtime routines).
11537 -- taskE : aliased Boolean := False;
11539 -- Next a variable is declared to hold the task stack size (either the
11540 -- default : Unspecified_Size, or a value that is set by a pragma
11541 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11542 -- the variable is initialized with this value:
11544 -- taskZ : Size_Type := Unspecified_Size;
11546 -- taskZ : Size_Type := Size_Type (size_expression);
11548 -- Note: No variable is needed to hold the task relative deadline since
11549 -- its value would never be static because the parameter is of a private
11550 -- type (Ada.Real_Time.Time_Span).
11552 -- Next we create a corresponding record type declaration used to represent
11553 -- values of this task. The general form of this type declaration is
11555 -- type taskV (discriminants) is record
11556 -- _Task_Id : Task_Id;
11557 -- entry_family : array (bounds) of Void;
11558 -- _Priority : Integer := priority_expression;
11559 -- _Size : Size_Type := size_expression;
11560 -- _Secondary_Stack_Size : Size_Type := size_expression;
11561 -- _Task_Info : Task_Info_Type := task_info_expression;
11562 -- _CPU : Integer := cpu_range_expression;
11563 -- _Relative_Deadline : Time_Span := time_span_expression;
11564 -- _Domain : Dispatching_Domain := dd_expression;
11567 -- The discriminants are present only if the corresponding task type has
11568 -- discriminants, and they exactly mirror the task type discriminants.
11570 -- The Id field is always present. It contains the Task_Id value, as set by
11571 -- the call to Create_Task. Note that although the task is limited, the
11572 -- task value record type is not limited, so there is no problem in passing
11573 -- this field as an out parameter to Create_Task.
11575 -- One entry_family component is present for each entry family in the task
11576 -- definition. The bounds correspond to the bounds of the entry family
11577 -- (which may depend on discriminants). The element type is void, since we
11578 -- only need the bounds information for determining the entry index. Note
11579 -- that the use of an anonymous array would normally be illegal in this
11580 -- context, but this is a parser check, and the semantics is quite prepared
11581 -- to handle such a case.
11583 -- The _Size field is present only if a Storage_Size pragma appears in the
11584 -- task definition. The expression captures the argument that was present
11585 -- in the pragma, and is used to override the task stack size otherwise
11586 -- associated with the task type.
11588 -- The _Secondary_Stack_Size field is present only the task entity has a
11589 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11590 -- when the record init proc is built, to capture the expression of the
11591 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11592 -- be filled here since aspect evaluations are delayed till the freeze
11595 -- The _Priority field is present only if the task entity has a Priority or
11596 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11597 -- definition clause). It will be filled at the freeze point, when the
11598 -- record init proc is built, to capture the expression of the rep item
11599 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11600 -- here since aspect evaluations are delayed till the freeze point.
11602 -- The _Task_Info field is present only if a Task_Info pragma appears in
11603 -- the task definition. The expression captures the argument that was
11604 -- present in the pragma, and is used to provide the Task_Image parameter
11605 -- to the call to Create_Task.
11607 -- The _CPU field is present only if the task entity has a CPU rep item
11608 -- (pragma, aspect specification or attribute definition clause). It will
11609 -- be filled at the freeze point, when the record init proc is built, to
11610 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11611 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11612 -- are delayed till the freeze point.
11614 -- The _Relative_Deadline field is present only if a Relative_Deadline
11615 -- pragma appears in the task definition. The expression captures the
11616 -- argument that was present in the pragma, and is used to provide the
11617 -- Relative_Deadline parameter to the call to Create_Task.
11619 -- The _Domain field is present only if the task entity has a
11620 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11621 -- definition clause). It will be filled at the freeze point, when the
11622 -- record init proc is built, to capture the expression of the rep item
11623 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11624 -- here since aspect evaluations are delayed till the freeze point.
11626 -- When a task is declared, an instance of the task value record is
11627 -- created. The elaboration of this declaration creates the correct bounds
11628 -- for the entry families, and also evaluates the size, priority, and
11629 -- task_Info expressions if needed. The initialization routine for the task
11630 -- type itself then calls Create_Task with appropriate parameters to
11631 -- initialize the value of the Task_Id field.
11633 -- Note: the address of this record is passed as the "Discriminants"
11634 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11635 -- body procedure, it does not matter that it does not quite match the
11636 -- GNARLI model of what is being passed (the record contains more than just
11637 -- the discriminants, but the discriminants can be found from the record
11640 -- The Entity_Id for this created record type is placed in the
11641 -- Corresponding_Record_Type field of the associated task type entity.
11643 -- Next we create a procedure specification for the task body procedure:
11645 -- procedure taskB (_Task : access taskV);
11647 -- Note that this must come after the record type declaration, since
11648 -- the spec refers to this type. It turns out that the initialization
11649 -- procedure for the value type references the task body spec, but that's
11650 -- fine, since it won't be generated till the freeze point for the type,
11651 -- which is certainly after the task body spec declaration.
11653 -- Finally, we set the task index value field of the entry attribute in
11654 -- the case of a simple entry.
11656 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
11657 Loc : constant Source_Ptr := Sloc (N);
11658 TaskId : constant Entity_Id := Defining_Identifier (N);
11659 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
11660 Tasknm : constant Name_Id := Chars (Tasktyp);
11661 Taskdef : constant Node_Id := Task_Definition (N);
11663 Body_Decl : Node_Id;
11665 Decl_Stack : Node_Id;
11666 Elab_Decl : Node_Id;
11667 Ent_Stack : Entity_Id;
11668 Proc_Spec : Node_Id;
11669 Rec_Decl : Node_Id;
11670 Rec_Ent : Entity_Id;
11671 Size_Decl : Entity_Id;
11672 Task_Size : Node_Id;
11674 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id;
11675 -- Searches the task definition T for the first occurrence of the pragma
11676 -- Relative Deadline. The caller has ensured that the pragma is present
11677 -- in the task definition. Note that this routine cannot be implemented
11678 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11679 -- not chained because their expansion into a procedure call statement
11680 -- would cause a break in the chain.
11682 ----------------------------------
11683 -- Get_Relative_Deadline_Pragma --
11684 ----------------------------------
11686 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is
11690 N := First (Visible_Declarations (T));
11691 while Present (N) loop
11692 if Nkind (N) = N_Pragma
11693 and then Pragma_Name (N) = Name_Relative_Deadline
11701 N := First (Private_Declarations (T));
11702 while Present (N) loop
11703 if Nkind (N) = N_Pragma
11704 and then Pragma_Name (N) = Name_Relative_Deadline
11712 raise Program_Error;
11713 end Get_Relative_Deadline_Pragma;
11715 -- Start of processing for Expand_N_Task_Type_Declaration
11718 -- If already expanded, nothing to do
11720 if Present (Corresponding_Record_Type (Tasktyp)) then
11724 -- Here we will do the expansion
11726 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
11728 Rec_Ent := Defining_Identifier (Rec_Decl);
11729 Cdecls := Component_Items (Component_List
11730 (Type_Definition (Rec_Decl)));
11732 Qualify_Entity_Names (N);
11734 -- First create the elaboration variable
11737 Make_Object_Declaration (Loc,
11738 Defining_Identifier =>
11739 Make_Defining_Identifier (Sloc (Tasktyp),
11740 Chars => New_External_Name (Tasknm, 'E')),
11741 Aliased_Present => True,
11742 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
11743 Expression => New_Occurrence_Of (Standard_False, Loc));
11745 Insert_After (N, Elab_Decl);
11747 -- Next create the declaration of the size variable (tasknmZ)
11749 Set_Storage_Size_Variable (Tasktyp,
11750 Make_Defining_Identifier (Sloc (Tasktyp),
11751 Chars => New_External_Name (Tasknm, 'Z')));
11753 if Present (Taskdef)
11754 and then Has_Storage_Size_Pragma (Taskdef)
11756 Is_OK_Static_Expression
11758 (First (Pragma_Argument_Associations
11759 (Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
11762 Make_Object_Declaration (Loc,
11763 Defining_Identifier => Storage_Size_Variable (Tasktyp),
11764 Object_Definition =>
11765 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
11767 Convert_To (RTE (RE_Size_Type),
11769 (Expression (First (Pragma_Argument_Associations
11771 (TaskId, Name_Storage_Size)))))));
11775 Make_Object_Declaration (Loc,
11776 Defining_Identifier => Storage_Size_Variable (Tasktyp),
11777 Object_Definition =>
11778 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
11780 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
11783 Insert_After (Elab_Decl, Size_Decl);
11785 -- Next build the rest of the corresponding record declaration. This is
11786 -- done last, since the corresponding record initialization procedure
11787 -- will reference the previously created entities.
11789 -- Fill in the component declarations -- first the _Task_Id field
11792 Make_Component_Declaration (Loc,
11793 Defining_Identifier =>
11794 Make_Defining_Identifier (Loc, Name_uTask_Id),
11795 Component_Definition =>
11796 Make_Component_Definition (Loc,
11797 Aliased_Present => False,
11798 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id),
11801 -- Declare static ATCB (that is, created by the expander) if we are
11802 -- using the Restricted run time.
11804 if Restricted_Profile then
11806 Make_Component_Declaration (Loc,
11807 Defining_Identifier =>
11808 Make_Defining_Identifier (Loc, Name_uATCB),
11810 Component_Definition =>
11811 Make_Component_Definition (Loc,
11812 Aliased_Present => True,
11813 Subtype_Indication => Make_Subtype_Indication (Loc,
11815 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc),
11818 Make_Index_Or_Discriminant_Constraint (Loc,
11820 New_List (Make_Integer_Literal (Loc, 0)))))));
11824 -- Declare static stack (that is, created by the expander) if we are
11825 -- using the Restricted run time on a bare board configuration.
11827 if Restricted_Profile and then Preallocated_Stacks_On_Target then
11829 -- First we need to extract the appropriate stack size
11831 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
11833 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
11835 Expr_N : constant Node_Id :=
11836 Expression (First (
11837 Pragma_Argument_Associations (
11838 Get_Rep_Pragma (TaskId, Name_Storage_Size))));
11839 Etyp : constant Entity_Id := Etype (Expr_N);
11840 P : constant Node_Id := Parent (Expr_N);
11843 -- The stack is defined inside the corresponding record.
11844 -- Therefore if the size of the stack is set by means of
11845 -- a discriminant, we must reference the discriminant of the
11846 -- corresponding record type.
11848 if Nkind (Expr_N) in N_Has_Entity
11849 and then Present (Discriminal_Link (Entity (Expr_N)))
11853 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
11855 Set_Parent (Task_Size, P);
11856 Set_Etype (Task_Size, Etyp);
11857 Set_Analyzed (Task_Size);
11860 Task_Size := Relocate_Node (Expr_N);
11866 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc);
11869 Decl_Stack := Make_Component_Declaration (Loc,
11870 Defining_Identifier => Ent_Stack,
11872 Component_Definition =>
11873 Make_Component_Definition (Loc,
11874 Aliased_Present => True,
11875 Subtype_Indication => Make_Subtype_Indication (Loc,
11877 New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
11880 Make_Index_Or_Discriminant_Constraint (Loc,
11881 Constraints => New_List (Make_Range (Loc,
11882 Low_Bound => Make_Integer_Literal (Loc, 1),
11883 High_Bound => Convert_To (RTE (RE_Storage_Offset),
11886 Append_To (Cdecls, Decl_Stack);
11888 -- The appropriate alignment for the stack is ensured by the run-time
11889 -- code in charge of task creation.
11893 -- Add components for entry families
11895 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
11897 -- Add the _Priority component if a Interrupt_Priority or Priority rep
11898 -- item is present.
11900 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then
11902 Make_Component_Declaration (Loc,
11903 Defining_Identifier =>
11904 Make_Defining_Identifier (Loc, Name_uPriority),
11905 Component_Definition =>
11906 Make_Component_Definition (Loc,
11907 Aliased_Present => False,
11908 Subtype_Indication =>
11909 New_Occurrence_Of (Standard_Integer, Loc))));
11912 -- Add the _Size component if a Storage_Size pragma is present
11914 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
11916 Make_Component_Declaration (Loc,
11917 Defining_Identifier =>
11918 Make_Defining_Identifier (Loc, Name_uSize),
11920 Component_Definition =>
11921 Make_Component_Definition (Loc,
11922 Aliased_Present => False,
11923 Subtype_Indication =>
11924 New_Occurrence_Of (RTE (RE_Size_Type), Loc)),
11927 Convert_To (RTE (RE_Size_Type),
11929 Expression (First (
11930 Pragma_Argument_Associations (
11931 Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
11934 -- Add the _Secondary_Stack_Size component if a
11935 -- Secondary_Stack_Size rep item is present.
11937 if Has_Rep_Item (TaskId, Name_Secondary_Stack_Size,
11938 Check_Parents => False)
11941 Make_Component_Declaration (Loc,
11942 Defining_Identifier =>
11943 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size),
11945 Component_Definition =>
11946 Make_Component_Definition (Loc,
11947 Aliased_Present => False,
11948 Subtype_Indication =>
11949 New_Occurrence_Of (RTE (RE_Size_Type), Loc))));
11952 -- Add the _Task_Info component if a Task_Info pragma is present
11954 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then
11956 Make_Component_Declaration (Loc,
11957 Defining_Identifier =>
11958 Make_Defining_Identifier (Loc, Name_uTask_Info),
11960 Component_Definition =>
11961 Make_Component_Definition (Loc,
11962 Aliased_Present => False,
11963 Subtype_Indication =>
11964 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)),
11966 Expression => New_Copy (
11967 Expression (First (
11968 Pragma_Argument_Associations (
11970 (TaskId, Name_Task_Info, Check_Parents => False)))))));
11973 -- Add the _CPU component if a CPU rep item is present
11975 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then
11977 Make_Component_Declaration (Loc,
11978 Defining_Identifier =>
11979 Make_Defining_Identifier (Loc, Name_uCPU),
11981 Component_Definition =>
11982 Make_Component_Definition (Loc,
11983 Aliased_Present => False,
11984 Subtype_Indication =>
11985 New_Occurrence_Of (RTE (RE_CPU_Range), Loc))));
11988 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
11989 -- present. If we are using a restricted run time this component will
11990 -- not be added (deadlines are not allowed by the Ravenscar profile).
11992 if not Restricted_Profile
11993 and then Present (Taskdef)
11994 and then Has_Relative_Deadline_Pragma (Taskdef)
11997 Make_Component_Declaration (Loc,
11998 Defining_Identifier =>
11999 Make_Defining_Identifier (Loc, Name_uRelative_Deadline),
12001 Component_Definition =>
12002 Make_Component_Definition (Loc,
12003 Aliased_Present => False,
12004 Subtype_Indication =>
12005 New_Occurrence_Of (RTE (RE_Time_Span), Loc)),
12008 Convert_To (RTE (RE_Time_Span),
12010 Expression (First (
12011 Pragma_Argument_Associations (
12012 Get_Relative_Deadline_Pragma (Taskdef))))))));
12015 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12016 -- item is present. If we are using a restricted run time this component
12017 -- will not be added (dispatching domains are not allowed by the
12018 -- Ravenscar profile).
12020 if not Restricted_Profile
12023 (TaskId, Name_Dispatching_Domain, Check_Parents => False)
12026 Make_Component_Declaration (Loc,
12027 Defining_Identifier =>
12028 Make_Defining_Identifier (Loc, Name_uDispatching_Domain),
12030 Component_Definition =>
12031 Make_Component_Definition (Loc,
12032 Aliased_Present => False,
12033 Subtype_Indication =>
12035 (RTE (RE_Dispatching_Domain_Access), Loc))));
12038 Insert_After (Size_Decl, Rec_Decl);
12040 -- Analyze the record declaration immediately after construction,
12041 -- because the initialization procedure is needed for single task
12042 -- declarations before the next entity is analyzed.
12044 Analyze (Rec_Decl);
12046 -- Create the declaration of the task body procedure
12048 Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
12050 Make_Subprogram_Declaration (Loc,
12051 Specification => Proc_Spec);
12052 Set_Is_Task_Body_Procedure (Body_Decl);
12054 Insert_After (Rec_Decl, Body_Decl);
12056 -- The subprogram does not comes from source, so we have to indicate the
12057 -- need for debugging information explicitly.
12059 if Comes_From_Source (Original_Node (N)) then
12060 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec));
12063 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12064 -- the corresponding record has been frozen.
12066 if Ada_Version >= Ada_2005 then
12067 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
12070 -- Ada 2005 (AI-345): We must defer freezing to allow further
12071 -- declaration of primitive subprograms covering task interfaces
12073 if Ada_Version <= Ada_95 then
12075 -- Now we can freeze the corresponding record. This needs manually
12076 -- freezing, since it is really part of the task type, and the task
12077 -- type is frozen at this stage. We of course need the initialization
12078 -- procedure for this corresponding record type and we won't get it
12079 -- in time if we don't freeze now.
12082 L : constant List_Id := Freeze_Entity (Rec_Ent, N);
12084 if Is_Non_Empty_List (L) then
12085 Insert_List_After (Body_Decl, L);
12090 -- Complete the expansion of access types to the current task type, if
12091 -- any were declared.
12093 Expand_Previous_Access_Type (Tasktyp);
12095 -- Create wrappers for entries that have contract cases, preconditions
12096 -- and postconditions.
12102 Ent := First_Entity (Tasktyp);
12103 while Present (Ent) loop
12104 if Ekind_In (Ent, E_Entry, E_Entry_Family) then
12105 Build_Contract_Wrapper (Ent, N);
12111 end Expand_N_Task_Type_Declaration;
12113 -------------------------------
12114 -- Expand_N_Timed_Entry_Call --
12115 -------------------------------
12117 -- A timed entry call in normal case is not implemented using ATC mechanism
12118 -- anymore for efficiency reason.
12128 -- is expanded as follows:
12130 -- 1) When T.E is a task entry_call;
12134 -- X : Task_Entry_Index := <entry index>;
12135 -- DX : Duration := To_Duration (D);
12136 -- M : Delay_Mode := <discriminant>;
12137 -- P : parms := (parm, parm, parm);
12140 -- Timed_Protected_Entry_Call
12141 -- (<acceptor-task>, X, P'Address, DX, M, B);
12149 -- 2) When T.E is a protected entry_call;
12153 -- X : Protected_Entry_Index := <entry index>;
12154 -- DX : Duration := To_Duration (D);
12155 -- M : Delay_Mode := <discriminant>;
12156 -- P : parms := (parm, parm, parm);
12159 -- Timed_Protected_Entry_Call
12160 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12168 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12169 -- is no delay and the triggering statements are executed. We first
12170 -- determine the kind of the triggering call and then execute a
12171 -- synchronized operation or a direct call.
12174 -- B : Boolean := False;
12175 -- C : Ada.Tags.Prim_Op_Kind;
12176 -- DX : Duration := To_Duration (D)
12177 -- K : Ada.Tags.Tagged_Kind :=
12178 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12179 -- M : Integer :=...;
12180 -- P : Parameters := (Param1 .. ParamN);
12184 -- if K = Ada.Tags.TK_Limited_Tagged
12185 -- or else K = Ada.Tags.TK_Tagged
12187 -- <dispatching-call>;
12192 -- Ada.Tags.Get_Offset_Index
12193 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12195 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12197 -- if C = POK_Protected_Entry
12198 -- or else C = POK_Task_Entry
12200 -- Param1 := P.Param1;
12202 -- ParamN := P.ParamN;
12206 -- if C = POK_Procedure
12207 -- or else C = POK_Protected_Procedure
12208 -- or else C = POK_Task_Procedure
12210 -- <dispatching-call>;
12216 -- <triggering-statements>
12218 -- <timed-statements>
12222 -- The triggering statement and the sequence of timed statements have not
12223 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12224 -- global references if within an instantiation.
12226 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
12227 Loc : constant Source_Ptr := Sloc (N);
12230 Blk_Typ : Entity_Id;
12232 Call_Ent : Entity_Id;
12233 Conc_Typ_Stmts : List_Id;
12235 D_Alt : constant Node_Id := Delay_Alternative (N);
12238 D_Stat : Node_Id := Delay_Statement (D_Alt);
12240 D_Type : Entity_Id;
12243 E_Alt : constant Node_Id := Entry_Call_Alternative (N);
12244 E_Call : Node_Id := Entry_Call_Statement (E_Alt);
12249 Is_Disp_Select : Boolean;
12250 Lim_Typ_Stmts : List_Id;
12259 B : Entity_Id; -- Call status flag
12260 C : Entity_Id; -- Call kind
12261 D : Entity_Id; -- Delay
12262 K : Entity_Id; -- Tagged kind
12263 M : Entity_Id; -- Delay mode
12264 P : Entity_Id; -- Parameter block
12265 S : Entity_Id; -- Primitive operation slot
12267 -- Start of processing for Expand_N_Timed_Entry_Call
12270 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12271 -- was already reported on spec, so do not attempt to expand the call.
12273 if Restriction_Active (No_Select_Statements) then
12277 Process_Statements_For_Controlled_Objects (E_Alt);
12278 Process_Statements_For_Controlled_Objects (D_Alt);
12280 Ensure_Statement_Present (Sloc (D_Stat), D_Alt);
12282 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12283 -- may wrap them in blocks.
12285 E_Stats := Statements (E_Alt);
12286 D_Stats := Statements (D_Alt);
12288 -- The arguments in the call may require dynamic allocation, and the
12289 -- call statement may have been transformed into a block. The block
12290 -- may contain additional declarations for internal entities, and the
12291 -- original call is found by sequential search.
12293 if Nkind (E_Call) = N_Block_Statement then
12294 E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
12295 while not Nkind_In (E_Call, N_Procedure_Call_Statement,
12296 N_Entry_Call_Statement)
12303 Ada_Version >= Ada_2005
12304 and then Nkind (E_Call) = N_Procedure_Call_Statement;
12306 if Is_Disp_Select then
12307 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
12313 -- B : Boolean := False;
12315 B := Build_B (Loc, Decls);
12318 -- C : Ada.Tags.Prim_Op_Kind;
12320 C := Build_C (Loc, Decls);
12322 -- Because the analysis of all statements was disabled, manually
12323 -- analyze the delay statement.
12326 D_Stat := Original_Node (D_Stat);
12329 -- Build an entry call using Simple_Entry_Call
12331 Extract_Entry (E_Call, Concval, Ename, Index);
12332 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
12334 Decls := Declarations (E_Call);
12335 Stmts := Statements (Handled_Statement_Sequence (E_Call));
12344 B := Make_Defining_Identifier (Loc, Name_uB);
12347 Make_Object_Declaration (Loc,
12348 Defining_Identifier => B,
12349 Object_Definition =>
12350 New_Occurrence_Of (Standard_Boolean, Loc)));
12353 -- Duration and mode processing
12355 D_Type := Base_Type (Etype (Expression (D_Stat)));
12357 -- Use the type of the delay expression (Calendar or Real_Time) to
12358 -- generate the appropriate conversion.
12360 if Nkind (D_Stat) = N_Delay_Relative_Statement then
12361 D_Disc := Make_Integer_Literal (Loc, 0);
12362 D_Conv := Relocate_Node (Expression (D_Stat));
12364 elsif Is_RTE (D_Type, RO_CA_Time) then
12365 D_Disc := Make_Integer_Literal (Loc, 1);
12367 Make_Function_Call (Loc,
12368 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
12369 Parameter_Associations =>
12370 New_List (New_Copy (Expression (D_Stat))));
12372 else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
12373 D_Disc := Make_Integer_Literal (Loc, 2);
12375 Make_Function_Call (Loc,
12376 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
12377 Parameter_Associations =>
12378 New_List (New_Copy (Expression (D_Stat))));
12381 D := Make_Temporary (Loc, 'D');
12387 Make_Object_Declaration (Loc,
12388 Defining_Identifier => D,
12389 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc)));
12391 M := Make_Temporary (Loc, 'M');
12394 -- M : Integer := (0 | 1 | 2);
12397 Make_Object_Declaration (Loc,
12398 Defining_Identifier => M,
12399 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
12400 Expression => D_Disc));
12402 -- Do the assignment at this stage only because the evaluation of the
12403 -- expression must not occur before (see ACVC C97302A).
12406 Make_Assignment_Statement (Loc,
12407 Name => New_Occurrence_Of (D, Loc),
12408 Expression => D_Conv));
12410 -- Parameter block processing
12412 -- Manually create the parameter block for dispatching calls. In the
12413 -- case of entries, the block has already been created during the call
12414 -- to Build_Simple_Entry_Call.
12416 if Is_Disp_Select then
12418 -- Tagged kind processing, generate:
12419 -- K : Ada.Tags.Tagged_Kind :=
12420 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12422 K := Build_K (Loc, Decls, Obj);
12424 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
12426 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
12428 -- Dispatch table slot processing, generate:
12431 S := Build_S (Loc, Decls);
12434 -- S := Ada.Tags.Get_Offset_Index
12435 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12438 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
12441 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12443 -- where Obj is the controlling formal parameter, S is the dispatch
12444 -- table slot number of the dispatching operation, P is the wrapped
12445 -- parameter block, D is the duration, M is the duration mode, C is
12446 -- the call kind and B is the call status.
12448 Params := New_List;
12450 Append_To (Params, New_Copy_Tree (Obj));
12451 Append_To (Params, New_Occurrence_Of (S, Loc));
12453 Make_Attribute_Reference (Loc,
12454 Prefix => New_Occurrence_Of (P, Loc),
12455 Attribute_Name => Name_Address));
12456 Append_To (Params, New_Occurrence_Of (D, Loc));
12457 Append_To (Params, New_Occurrence_Of (M, Loc));
12458 Append_To (Params, New_Occurrence_Of (C, Loc));
12459 Append_To (Params, New_Occurrence_Of (B, Loc));
12461 Append_To (Conc_Typ_Stmts,
12462 Make_Procedure_Call_Statement (Loc,
12466 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc),
12467 Parameter_Associations => Params));
12470 -- if C = POK_Protected_Entry
12471 -- or else C = POK_Task_Entry
12473 -- Param1 := P.Param1;
12475 -- ParamN := P.ParamN;
12478 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
12480 -- Generate the if statement only when the packed parameters need
12481 -- explicit assignments to their corresponding actuals.
12483 if Present (Unpack) then
12484 Append_To (Conc_Typ_Stmts,
12485 Make_Implicit_If_Statement (N,
12491 Left_Opnd => New_Occurrence_Of (C, Loc),
12494 (RTE (RE_POK_Protected_Entry), Loc)),
12498 Left_Opnd => New_Occurrence_Of (C, Loc),
12500 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
12502 Then_Statements => Unpack));
12508 -- if C = POK_Procedure
12509 -- or else C = POK_Protected_Procedure
12510 -- or else C = POK_Task_Procedure
12512 -- <dispatching-call>
12516 N_Stats := New_List (
12517 Make_Implicit_If_Statement (N,
12522 Left_Opnd => New_Occurrence_Of (C, Loc),
12524 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
12530 Left_Opnd => New_Occurrence_Of (C, Loc),
12532 New_Occurrence_Of (RTE (
12533 RE_POK_Protected_Procedure), Loc)),
12536 Left_Opnd => New_Occurrence_Of (C, Loc),
12539 (RTE (RE_POK_Task_Procedure), Loc)))),
12541 Then_Statements => New_List (E_Call)));
12543 Append_To (Conc_Typ_Stmts,
12544 Make_Implicit_If_Statement (N,
12545 Condition => New_Occurrence_Of (B, Loc),
12546 Then_Statements => N_Stats));
12549 -- <dispatching-call>;
12553 New_List (New_Copy_Tree (E_Call),
12554 Make_Assignment_Statement (Loc,
12555 Name => New_Occurrence_Of (B, Loc),
12556 Expression => New_Occurrence_Of (Standard_True, Loc)));
12559 -- if K = Ada.Tags.TK_Limited_Tagged
12560 -- or else K = Ada.Tags.TK_Tagged
12568 Make_Implicit_If_Statement (N,
12569 Condition => Build_Dispatching_Tag_Check (K, N),
12570 Then_Statements => Lim_Typ_Stmts,
12571 Else_Statements => Conc_Typ_Stmts));
12576 -- <triggering-statements>
12578 -- <timed-statements>
12582 Make_Implicit_If_Statement (N,
12583 Condition => New_Occurrence_Of (B, Loc),
12584 Then_Statements => E_Stats,
12585 Else_Statements => D_Stats));
12588 -- Simple case of a nondispatching trigger. Skip assignments to
12589 -- temporaries created for in-out parameters.
12591 -- This makes unwarranted assumptions about the shape of the expanded
12592 -- tree for the call, and should be cleaned up ???
12594 Stmt := First (Stmts);
12595 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
12599 -- Do the assignment at this stage only because the evaluation
12600 -- of the expression must not occur before (see ACVC C97302A).
12602 Insert_Before (Stmt,
12603 Make_Assignment_Statement (Loc,
12604 Name => New_Occurrence_Of (D, Loc),
12605 Expression => D_Conv));
12608 Params := Parameter_Associations (Call);
12610 -- For a protected type, we build a Timed_Protected_Entry_Call
12612 if Is_Protected_Type (Etype (Concval)) then
12614 -- Create a new call statement
12616 Param := First (Params);
12617 while Present (Param)
12618 and then not Is_RTE (Etype (Param), RE_Call_Modes)
12623 Dummy := Remove_Next (Next (Param));
12625 -- Remove garbage is following the Cancel_Param if present
12627 Dummy := Next (Param);
12629 -- Remove the mode of the Protected_Entry_Call call, then remove
12630 -- the Communication_Block of the Protected_Entry_Call call, and
12631 -- finally add Duration and a Delay_Mode parameter
12633 pragma Assert (Present (Param));
12634 Rewrite (Param, New_Occurrence_Of (D, Loc));
12636 Rewrite (Dummy, New_Occurrence_Of (M, Loc));
12638 -- Add a Boolean flag for successful entry call
12640 Append_To (Params, New_Occurrence_Of (B, Loc));
12642 case Corresponding_Runtime_Package (Etype (Concval)) is
12643 when System_Tasking_Protected_Objects_Entries =>
12645 Make_Procedure_Call_Statement (Loc,
12648 (RTE (RE_Timed_Protected_Entry_Call), Loc),
12649 Parameter_Associations => Params));
12652 raise Program_Error;
12655 -- For the task case, build a Timed_Task_Entry_Call
12658 -- Create a new call statement
12660 Append_To (Params, New_Occurrence_Of (D, Loc));
12661 Append_To (Params, New_Occurrence_Of (M, Loc));
12662 Append_To (Params, New_Occurrence_Of (B, Loc));
12665 Make_Procedure_Call_Statement (Loc,
12667 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
12668 Parameter_Associations => Params));
12672 Make_Implicit_If_Statement (N,
12673 Condition => New_Occurrence_Of (B, Loc),
12674 Then_Statements => E_Stats,
12675 Else_Statements => D_Stats));
12679 Make_Block_Statement (Loc,
12680 Declarations => Decls,
12681 Handled_Statement_Sequence =>
12682 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
12685 end Expand_N_Timed_Entry_Call;
12687 ----------------------------------------
12688 -- Expand_Protected_Body_Declarations --
12689 ----------------------------------------
12691 procedure Expand_Protected_Body_Declarations
12693 Spec_Id : Entity_Id)
12696 if No_Run_Time_Mode then
12697 Error_Msg_CRT ("protected body", N);
12700 elsif Expander_Active then
12702 -- Associate discriminals with the first subprogram or entry body to
12705 if Present (First_Protected_Operation (Declarations (N))) then
12706 Set_Discriminals (Parent (Spec_Id));
12709 end Expand_Protected_Body_Declarations;
12711 -------------------------
12712 -- External_Subprogram --
12713 -------------------------
12715 function External_Subprogram (E : Entity_Id) return Entity_Id is
12716 Subp : constant Entity_Id := Protected_Body_Subprogram (E);
12719 -- The internal and external subprograms follow each other on the entity
12720 -- chain. Note that previously private operations had no separate
12721 -- external subprogram. We now create one in all cases, because a
12722 -- private operation may actually appear in an external call, through
12723 -- a 'Access reference used for a callback.
12725 -- If the operation is a function that returns an anonymous access type,
12726 -- the corresponding itype appears before the operation, and must be
12729 -- This mechanism is fragile, there should be a real link between the
12730 -- two versions of the operation, but there is no place to put it ???
12732 if Is_Access_Type (Next_Entity (Subp)) then
12733 return Next_Entity (Next_Entity (Subp));
12735 return Next_Entity (Subp);
12737 end External_Subprogram;
12739 ------------------------------
12740 -- Extract_Dispatching_Call --
12741 ------------------------------
12743 procedure Extract_Dispatching_Call
12745 Call_Ent : out Entity_Id;
12746 Object : out Entity_Id;
12747 Actuals : out List_Id;
12748 Formals : out List_Id)
12750 Call_Nam : Node_Id;
12753 pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
12755 if Present (Original_Node (N)) then
12756 Call_Nam := Name (Original_Node (N));
12758 Call_Nam := Name (N);
12761 -- Retrieve the name of the dispatching procedure. It contains the
12762 -- dispatch table slot number.
12765 case Nkind (Call_Nam) is
12766 when N_Identifier =>
12769 when N_Selected_Component =>
12770 Call_Nam := Selector_Name (Call_Nam);
12773 raise Program_Error;
12778 Actuals := Parameter_Associations (N);
12779 Call_Ent := Entity (Call_Nam);
12780 Formals := Parameter_Specifications (Parent (Call_Ent));
12781 Object := First (Actuals);
12783 if Present (Original_Node (Object)) then
12784 Object := Original_Node (Object);
12787 -- If the type of the dispatching object is an access type then return
12788 -- an explicit dereference.
12790 if Is_Access_Type (Etype (Object)) then
12791 Object := Make_Explicit_Dereference (Sloc (N), Object);
12794 end Extract_Dispatching_Call;
12796 -------------------
12797 -- Extract_Entry --
12798 -------------------
12800 procedure Extract_Entry
12802 Concval : out Node_Id;
12803 Ename : out Node_Id;
12804 Index : out Node_Id)
12806 Nam : constant Node_Id := Name (N);
12809 -- For a simple entry, the name is a selected component, with the
12810 -- prefix being the task value, and the selector being the entry.
12812 if Nkind (Nam) = N_Selected_Component then
12813 Concval := Prefix (Nam);
12814 Ename := Selector_Name (Nam);
12817 -- For a member of an entry family, the name is an indexed component
12818 -- where the prefix is a selected component, whose prefix in turn is
12819 -- the task value, and whose selector is the entry family. The single
12820 -- expression in the expressions list of the indexed component is the
12821 -- subscript for the family.
12823 else pragma Assert (Nkind (Nam) = N_Indexed_Component);
12824 Concval := Prefix (Prefix (Nam));
12825 Ename := Selector_Name (Prefix (Nam));
12826 Index := First (Expressions (Nam));
12829 -- Through indirection, the type may actually be a limited view of a
12830 -- concurrent type. When compiling a call, the non-limited view of the
12831 -- type is visible.
12833 if From_Limited_With (Etype (Concval)) then
12834 Set_Etype (Concval, Non_Limited_View (Etype (Concval)));
12838 -------------------
12839 -- Family_Offset --
12840 -------------------
12842 function Family_Offset
12847 Cap : Boolean) return Node_Id
12853 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
12854 -- If one of the bounds is a reference to a discriminant, replace with
12855 -- corresponding discriminal of type. Within the body of a task retrieve
12856 -- the renamed discriminant by simple visibility, using its generated
12857 -- name. Within a protected object, find the original discriminant and
12858 -- replace it with the discriminal of the current protected operation.
12860 ------------------------------
12861 -- Convert_Discriminant_Ref --
12862 ------------------------------
12864 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
12865 Loc : constant Source_Ptr := Sloc (Bound);
12870 if Is_Entity_Name (Bound)
12871 and then Ekind (Entity (Bound)) = E_Discriminant
12873 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then
12874 B := Make_Identifier (Loc, Chars (Entity (Bound)));
12875 Find_Direct_Name (B);
12877 elsif Is_Protected_Type (Ttyp) then
12878 D := First_Discriminant (Ttyp);
12879 while Chars (D) /= Chars (Entity (Bound)) loop
12880 Next_Discriminant (D);
12883 B := New_Occurrence_Of (Discriminal (D), Loc);
12886 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
12889 elsif Nkind (Bound) = N_Attribute_Reference then
12893 B := New_Copy_Tree (Bound);
12897 Make_Attribute_Reference (Loc,
12898 Attribute_Name => Name_Pos,
12899 Prefix => New_Occurrence_Of (Etype (Bound), Loc),
12900 Expressions => New_List (B));
12901 end Convert_Discriminant_Ref;
12903 -- Start of processing for Family_Offset
12906 Real_Hi := Convert_Discriminant_Ref (Hi);
12907 Real_Lo := Convert_Discriminant_Ref (Lo);
12910 if Is_Task_Type (Ttyp) then
12911 Ityp := RTE (RE_Task_Entry_Index);
12913 Ityp := RTE (RE_Protected_Entry_Index);
12917 Make_Attribute_Reference (Loc,
12918 Prefix => New_Occurrence_Of (Ityp, Loc),
12919 Attribute_Name => Name_Min,
12920 Expressions => New_List (
12922 Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
12925 Make_Attribute_Reference (Loc,
12926 Prefix => New_Occurrence_Of (Ityp, Loc),
12927 Attribute_Name => Name_Max,
12928 Expressions => New_List (
12930 Make_Integer_Literal (Loc, -Entry_Family_Bound)));
12933 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
12940 function Family_Size
12945 Cap : Boolean) return Node_Id
12950 if Is_Task_Type (Ttyp) then
12951 Ityp := RTE (RE_Task_Entry_Index);
12953 Ityp := RTE (RE_Protected_Entry_Index);
12957 Make_Attribute_Reference (Loc,
12958 Prefix => New_Occurrence_Of (Ityp, Loc),
12959 Attribute_Name => Name_Max,
12960 Expressions => New_List (
12962 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
12963 Right_Opnd => Make_Integer_Literal (Loc, 1)),
12964 Make_Integer_Literal (Loc, 0)));
12967 ----------------------------
12968 -- Find_Enclosing_Context --
12969 ----------------------------
12971 procedure Find_Enclosing_Context
12973 Context : out Node_Id;
12974 Context_Id : out Entity_Id;
12975 Context_Decls : out List_Id)
12978 -- Traverse the parent chain looking for an enclosing body, block,
12979 -- package or return statement.
12981 Context := Parent (N);
12982 while Present (Context) loop
12983 if Nkind_In (Context, N_Entry_Body,
12984 N_Extended_Return_Statement,
12986 N_Package_Declaration,
12992 -- Do not consider block created to protect a list of statements with
12993 -- an Abort_Defer / Abort_Undefer_Direct pair.
12995 elsif Nkind (Context) = N_Block_Statement
12996 and then not Is_Abort_Block (Context)
13001 Context := Parent (Context);
13004 pragma Assert (Present (Context));
13006 -- Extract the constituents of the context
13008 if Nkind (Context) = N_Extended_Return_Statement then
13009 Context_Decls := Return_Object_Declarations (Context);
13010 Context_Id := Return_Statement_Entity (Context);
13012 -- Package declarations and bodies use a common library-level activation
13013 -- chain or task master, therefore return the package declaration as the
13014 -- proper carrier for the appropriate flag.
13016 elsif Nkind (Context) = N_Package_Body then
13017 Context_Decls := Declarations (Context);
13018 Context_Id := Corresponding_Spec (Context);
13019 Context := Parent (Context_Id);
13021 if Nkind (Context) = N_Defining_Program_Unit_Name then
13022 Context := Parent (Parent (Context));
13024 Context := Parent (Context);
13027 elsif Nkind (Context) = N_Package_Declaration then
13028 Context_Decls := Visible_Declarations (Specification (Context));
13029 Context_Id := Defining_Unit_Name (Specification (Context));
13031 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13032 Context_Id := Defining_Identifier (Context_Id);
13036 if Nkind (Context) = N_Block_Statement then
13037 Context_Id := Entity (Identifier (Context));
13039 elsif Nkind (Context) = N_Entry_Body then
13040 Context_Id := Defining_Identifier (Context);
13042 elsif Nkind (Context) = N_Subprogram_Body then
13043 if Present (Corresponding_Spec (Context)) then
13044 Context_Id := Corresponding_Spec (Context);
13046 Context_Id := Defining_Unit_Name (Specification (Context));
13048 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13049 Context_Id := Defining_Identifier (Context_Id);
13053 elsif Nkind (Context) = N_Task_Body then
13054 Context_Id := Corresponding_Spec (Context);
13057 raise Program_Error;
13060 Context_Decls := Declarations (Context);
13063 pragma Assert (Present (Context_Id));
13064 pragma Assert (Present (Context_Decls));
13065 end Find_Enclosing_Context;
13067 -----------------------
13068 -- Find_Master_Scope --
13069 -----------------------
13071 function Find_Master_Scope (E : Entity_Id) return Entity_Id is
13075 -- In Ada 2005, the master is the innermost enclosing scope that is not
13076 -- transient. If the enclosing block is the rewriting of a call or the
13077 -- scope is an extended return statement this is valid master. The
13078 -- master in an extended return is only used within the return, and is
13079 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13080 -- now before that overwriting occurs.
13084 if Ada_Version >= Ada_2005 then
13085 while Is_Internal (S) loop
13086 if Nkind (Parent (S)) = N_Block_Statement
13088 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
13092 elsif Ekind (S) = E_Return_Statement then
13102 end Find_Master_Scope;
13104 -------------------------------
13105 -- First_Protected_Operation --
13106 -------------------------------
13108 function First_Protected_Operation (D : List_Id) return Node_Id is
13109 First_Op : Node_Id;
13112 First_Op := First (D);
13113 while Present (First_Op)
13114 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body)
13120 end First_Protected_Operation;
13122 ---------------------------------------
13123 -- Install_Private_Data_Declarations --
13124 ---------------------------------------
13126 procedure Install_Private_Data_Declarations
13128 Spec_Id : Entity_Id;
13129 Conc_Typ : Entity_Id;
13130 Body_Nod : Node_Id;
13132 Barrier : Boolean := False;
13133 Family : Boolean := False)
13135 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ);
13138 Insert_Node : Node_Id := Empty;
13139 Obj_Ent : Entity_Id;
13141 procedure Add (Decl : Node_Id);
13142 -- Add a single declaration after Insert_Node. If this is the first
13143 -- addition, Decl is added to the front of Decls and it becomes the
13146 function Replace_Bound (Bound : Node_Id) return Node_Id;
13147 -- The bounds of an entry index may depend on discriminants, create a
13148 -- reference to the corresponding prival. Otherwise return a duplicate
13149 -- of the original bound.
13155 procedure Add (Decl : Node_Id) is
13157 if No (Insert_Node) then
13158 Prepend_To (Decls, Decl);
13160 Insert_After (Insert_Node, Decl);
13163 Insert_Node := Decl;
13166 --------------------------
13167 -- Replace_Discriminant --
13168 --------------------------
13170 function Replace_Bound (Bound : Node_Id) return Node_Id is
13172 if Nkind (Bound) = N_Identifier
13173 and then Is_Discriminal (Entity (Bound))
13175 return Make_Identifier (Loc, Chars (Entity (Bound)));
13177 return Duplicate_Subexpr (Bound);
13181 -- Start of processing for Install_Private_Data_Declarations
13184 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13185 -- formal parameter _O, _object or _task depending on the context.
13187 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ);
13189 -- Special processing of _O for barrier functions, protected entries
13196 (Ekind (Spec_Id) = E_Entry
13197 or else Ekind (Spec_Id) = E_Entry_Family))
13200 Conc_Rec : constant Entity_Id :=
13201 Corresponding_Record_Type (Conc_Typ);
13202 Typ_Id : constant Entity_Id :=
13203 Make_Defining_Identifier (Loc,
13204 New_External_Name (Chars (Conc_Rec), 'P'));
13207 -- type prot_typVP is access prot_typV;
13210 Make_Full_Type_Declaration (Loc,
13211 Defining_Identifier => Typ_Id,
13213 Make_Access_To_Object_Definition (Loc,
13214 Subtype_Indication =>
13215 New_Occurrence_Of (Conc_Rec, Loc)));
13219 -- _object : prot_typVP := prot_typV (_O);
13222 Make_Object_Declaration (Loc,
13223 Defining_Identifier =>
13224 Make_Defining_Identifier (Loc, Name_uObject),
13225 Object_Definition => New_Occurrence_Of (Typ_Id, Loc),
13227 Unchecked_Convert_To (Typ_Id,
13228 New_Occurrence_Of (Obj_Ent, Loc)));
13231 -- Set the reference to the concurrent object
13233 Obj_Ent := Defining_Identifier (Decl);
13237 -- Step 2: Create the Protection object and build its declaration for
13238 -- any protected entry (family) of subprogram. Note for the lock-free
13239 -- implementation, the Protection object is not needed anymore.
13241 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then
13243 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
13247 Set_Protection_Object (Spec_Id, Prot_Ent);
13249 -- Determine the proper protection type
13251 if Has_Attach_Handler (Conc_Typ)
13252 and then not Restricted_Profile
13254 Prot_Typ := RE_Static_Interrupt_Protection;
13256 elsif Has_Interrupt_Handler (Conc_Typ)
13257 and then not Restriction_Active (No_Dynamic_Attachment)
13259 Prot_Typ := RE_Dynamic_Interrupt_Protection;
13262 case Corresponding_Runtime_Package (Conc_Typ) is
13263 when System_Tasking_Protected_Objects_Entries =>
13264 Prot_Typ := RE_Protection_Entries;
13266 when System_Tasking_Protected_Objects_Single_Entry =>
13267 Prot_Typ := RE_Protection_Entry;
13269 when System_Tasking_Protected_Objects =>
13270 Prot_Typ := RE_Protection;
13273 raise Program_Error;
13278 -- conc_typR : protection_typ renames _object._object;
13281 Make_Object_Renaming_Declaration (Loc,
13282 Defining_Identifier => Prot_Ent,
13284 New_Occurrence_Of (RTE (Prot_Typ), Loc),
13286 Make_Selected_Component (Loc,
13287 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13288 Selector_Name => Make_Identifier (Loc, Name_uObject)));
13293 -- Step 3: Add discriminant renamings (if any)
13295 if Has_Discriminants (Conc_Typ) then
13300 D := First_Discriminant (Conc_Typ);
13301 while Present (D) loop
13303 -- Adjust the source location
13305 Set_Sloc (Discriminal (D), Loc);
13308 -- discr_name : discr_typ renames _object.discr_name;
13310 -- discr_name : discr_typ renames _task.discr_name;
13313 Make_Object_Renaming_Declaration (Loc,
13314 Defining_Identifier => Discriminal (D),
13315 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
13317 Make_Selected_Component (Loc,
13318 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13319 Selector_Name => Make_Identifier (Loc, Chars (D))));
13322 Next_Discriminant (D);
13327 -- Step 4: Add private component renamings (if any)
13329 if Is_Protected then
13330 Def := Protected_Definition (Parent (Conc_Typ));
13332 if Present (Private_Declarations (Def)) then
13335 Comp_Id : Entity_Id;
13336 Decl_Id : Entity_Id;
13339 Comp := First (Private_Declarations (Def));
13340 while Present (Comp) loop
13341 if Nkind (Comp) = N_Component_Declaration then
13342 Comp_Id := Defining_Identifier (Comp);
13344 Make_Defining_Identifier (Loc, Chars (Comp_Id));
13346 -- Minimal decoration
13348 if Ekind (Spec_Id) = E_Function then
13349 Set_Ekind (Decl_Id, E_Constant);
13351 Set_Ekind (Decl_Id, E_Variable);
13354 Set_Prival (Comp_Id, Decl_Id);
13355 Set_Prival_Link (Decl_Id, Comp_Id);
13356 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
13359 -- comp_name : comp_typ renames _object.comp_name;
13362 Make_Object_Renaming_Declaration (Loc,
13363 Defining_Identifier => Decl_Id,
13365 New_Occurrence_Of (Etype (Comp_Id), Loc),
13367 Make_Selected_Component (Loc,
13369 New_Occurrence_Of (Obj_Ent, Loc),
13371 Make_Identifier (Loc, Chars (Comp_Id))));
13381 -- Step 5: Add the declaration of the entry index and the associated
13382 -- type for barrier functions and entry families.
13384 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then
13386 E : constant Entity_Id := Index_Object (Spec_Id);
13387 Index : constant Entity_Id :=
13388 Defining_Identifier
13389 (Entry_Index_Specification
13390 (Entry_Body_Formal_Part (Body_Nod)));
13391 Index_Con : constant Entity_Id :=
13392 Make_Defining_Identifier (Loc, Chars (Index));
13394 Index_Typ : Entity_Id;
13398 -- Minimal decoration
13400 Set_Ekind (Index_Con, E_Constant);
13401 Set_Entry_Index_Constant (Index, Index_Con);
13402 Set_Discriminal_Link (Index_Con, Index);
13404 -- Retrieve the bounds of the entry family
13406 High := Type_High_Bound (Etype (Index));
13407 Low := Type_Low_Bound (Etype (Index));
13409 -- In the simple case the entry family is given by a subtype
13410 -- mark and the index constant has the same type.
13412 if Is_Entity_Name (Original_Node (
13413 Discrete_Subtype_Definition (Parent (Index))))
13415 Index_Typ := Etype (Index);
13417 -- Otherwise a new subtype declaration is required
13420 High := Replace_Bound (High);
13421 Low := Replace_Bound (Low);
13423 Index_Typ := Make_Temporary (Loc, 'J');
13426 -- subtype Jnn is <Etype of Index> range Low .. High;
13429 Make_Subtype_Declaration (Loc,
13430 Defining_Identifier => Index_Typ,
13431 Subtype_Indication =>
13432 Make_Subtype_Indication (Loc,
13434 New_Occurrence_Of (Base_Type (Etype (Index)), Loc),
13436 Make_Range_Constraint (Loc,
13437 Range_Expression =>
13438 Make_Range (Loc, Low, High))));
13442 Set_Etype (Index_Con, Index_Typ);
13444 -- Create the object which designates the index:
13445 -- J : constant Jnn :=
13446 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13448 -- where Jnn is the subtype created above or the original type of
13449 -- the index, _E is a formal of the protected body subprogram and
13450 -- <index expr> is the index of the first family member.
13453 Make_Object_Declaration (Loc,
13454 Defining_Identifier => Index_Con,
13455 Constant_Present => True,
13456 Object_Definition =>
13457 New_Occurrence_Of (Index_Typ, Loc),
13460 Make_Attribute_Reference (Loc,
13462 New_Occurrence_Of (Index_Typ, Loc),
13463 Attribute_Name => Name_Val,
13465 Expressions => New_List (
13469 Make_Op_Subtract (Loc,
13470 Left_Opnd => New_Occurrence_Of (E, Loc),
13472 Entry_Index_Expression (Loc,
13473 Defining_Identifier (Body_Nod),
13477 Make_Attribute_Reference (Loc,
13479 New_Occurrence_Of (Index_Typ, Loc),
13480 Attribute_Name => Name_Pos,
13481 Expressions => New_List (
13482 Make_Attribute_Reference (Loc,
13484 New_Occurrence_Of (Index_Typ, Loc),
13485 Attribute_Name => Name_First)))))));
13489 end Install_Private_Data_Declarations;
13491 -----------------------
13492 -- Is_Exception_Safe --
13493 -----------------------
13495 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
13497 function Has_Side_Effect (N : Node_Id) return Boolean;
13498 -- Return True whenever encountering a subprogram call or raise
13499 -- statement of any kind in the sequence of statements
13501 ---------------------
13502 -- Has_Side_Effect --
13503 ---------------------
13505 -- What is this doing buried two levels down in exp_ch9. It seems like a
13506 -- generally useful function, and indeed there may be code duplication
13507 -- going on here ???
13509 function Has_Side_Effect (N : Node_Id) return Boolean is
13513 function Is_Call_Or_Raise (N : Node_Id) return Boolean;
13514 -- Indicate whether N is a subprogram call or a raise statement
13516 ----------------------
13517 -- Is_Call_Or_Raise --
13518 ----------------------
13520 function Is_Call_Or_Raise (N : Node_Id) return Boolean is
13522 return Nkind_In (N, N_Procedure_Call_Statement,
13525 N_Raise_Constraint_Error,
13526 N_Raise_Program_Error,
13527 N_Raise_Storage_Error);
13528 end Is_Call_Or_Raise;
13530 -- Start of processing for Has_Side_Effect
13534 while Present (Stmt) loop
13535 if Is_Call_Or_Raise (Stmt) then
13539 -- An object declaration can also contain a function call or a
13540 -- raise statement.
13542 if Nkind (Stmt) = N_Object_Declaration then
13543 Expr := Expression (Stmt);
13545 if Present (Expr) and then Is_Call_Or_Raise (Expr) then
13554 end Has_Side_Effect;
13556 -- Start of processing for Is_Exception_Safe
13559 -- When exceptions can't be propagated, the subprogram returns normally
13561 if No_Exception_Handlers_Set then
13565 -- If the checks handled by the back end are not disabled, we cannot
13566 -- ensure that no exception will be raised.
13568 if not Access_Checks_Suppressed (Empty)
13569 or else not Discriminant_Checks_Suppressed (Empty)
13570 or else not Range_Checks_Suppressed (Empty)
13571 or else not Index_Checks_Suppressed (Empty)
13572 or else Opt.Stack_Checking_Enabled
13577 if Has_Side_Effect (First (Declarations (Subprogram)))
13580 (First (Statements (Handled_Statement_Sequence (Subprogram))))
13586 end Is_Exception_Safe;
13588 ---------------------------------
13589 -- Is_Potentially_Large_Family --
13590 ---------------------------------
13592 function Is_Potentially_Large_Family
13593 (Base_Index : Entity_Id;
13594 Conctyp : Entity_Id;
13596 Hi : Node_Id) return Boolean
13599 return Scope (Base_Index) = Standard_Standard
13600 and then Base_Index = Base_Type (Standard_Integer)
13601 and then Has_Discriminants (Conctyp)
13603 Present (Discriminant_Default_Value (First_Discriminant (Conctyp)))
13605 (Denotes_Discriminant (Lo, True)
13607 Denotes_Discriminant (Hi, True));
13608 end Is_Potentially_Large_Family;
13610 -------------------------------------
13611 -- Is_Private_Primitive_Subprogram --
13612 -------------------------------------
13614 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
13617 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
13618 and then Is_Private_Primitive (Id);
13619 end Is_Private_Primitive_Subprogram;
13625 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is
13626 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id);
13627 Formal : Entity_Id;
13630 Formal := First_Formal (Bod_Subp);
13631 while Present (Formal) loop
13633 -- Look for formal parameter _E
13635 if Chars (Formal) = Name_uE then
13639 Next_Formal (Formal);
13642 -- A protected body subprogram should always have the parameter in
13645 raise Program_Error;
13648 --------------------------------
13649 -- Make_Initialize_Protection --
13650 --------------------------------
13652 function Make_Initialize_Protection
13653 (Protect_Rec : Entity_Id) return List_Id
13655 Loc : constant Source_Ptr := Sloc (Protect_Rec);
13658 Ptyp : constant Node_Id :=
13659 Corresponding_Concurrent_Type (Protect_Rec);
13661 L : constant List_Id := New_List;
13662 Has_Entry : constant Boolean := Has_Entries (Ptyp);
13663 Prio_Type : Entity_Id;
13664 Prio_Var : Entity_Id := Empty;
13665 Restricted : constant Boolean := Restricted_Profile;
13668 -- We may need two calls to properly initialize the object, one to
13669 -- Initialize_Protection, and possibly one to Install_Handlers if we
13670 -- have a pragma Attach_Handler.
13672 -- Get protected declaration. In the case of a task type declaration,
13673 -- this is simply the parent of the protected type entity. In the single
13674 -- protected object declaration, this parent will be the implicit type,
13675 -- and we can find the corresponding single protected object declaration
13676 -- by searching forward in the declaration list in the tree.
13678 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13679 -- of this type should have been removed during semantic analysis.
13681 Pdec := Parent (Ptyp);
13682 while not Nkind_In (Pdec, N_Protected_Type_Declaration,
13683 N_Single_Protected_Declaration)
13688 -- Build the parameter list for the call. Note that _Init is the name
13689 -- of the formal for the object to be initialized, which is the task
13690 -- value record itself.
13694 -- For lock-free implementation, skip initializations of the Protection
13697 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
13699 -- Object parameter. This is a pointer to the object of type
13700 -- Protection used by the GNARL to control the protected object.
13703 Make_Attribute_Reference (Loc,
13705 Make_Selected_Component (Loc,
13706 Prefix => Make_Identifier (Loc, Name_uInit),
13707 Selector_Name => Make_Identifier (Loc, Name_uObject)),
13708 Attribute_Name => Name_Unchecked_Access));
13710 -- Priority parameter. Set to Unspecified_Priority unless there is a
13711 -- Priority rep item, in which case we take the value from the pragma
13712 -- or attribute definition clause, or there is an Interrupt_Priority
13713 -- rep item and no Priority rep item, and we set the ceiling to
13714 -- Interrupt_Priority'Last, an implementation-defined value, see
13717 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then
13719 Prio_Clause : constant Node_Id :=
13721 (Ptyp, Name_Priority, Check_Parents => False);
13728 if Nkind (Prio_Clause) = N_Pragma then
13731 (First (Pragma_Argument_Associations (Prio_Clause)));
13733 -- Get_Rep_Item returns either priority pragma.
13735 if Pragma_Name (Prio_Clause) = Name_Priority then
13736 Prio_Type := RTE (RE_Any_Priority);
13738 Prio_Type := RTE (RE_Interrupt_Priority);
13741 -- Attribute definition clause Priority
13744 if Chars (Prio_Clause) = Name_Priority then
13745 Prio_Type := RTE (RE_Any_Priority);
13747 Prio_Type := RTE (RE_Interrupt_Priority);
13750 Prio := Expression (Prio_Clause);
13753 -- Always create a locale variable to capture the priority.
13754 -- The priority is also passed to Install_Restriced_Handlers.
13755 -- Note that it is really necessary to create this variable
13756 -- explicitly. It might be thought that removing side effects
13757 -- would the appropriate approach, but that could generate
13758 -- declarations improperly placed in the enclosing scope.
13760 Prio_Var := Make_Temporary (Loc, 'R', Prio);
13762 Make_Object_Declaration (Loc,
13763 Defining_Identifier => Prio_Var,
13764 Object_Definition => New_Occurrence_Of (Prio_Type, Loc),
13765 Expression => Relocate_Node (Prio)));
13767 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
13770 -- When no priority is specified but an xx_Handler pragma is, we
13771 -- default to System.Interrupts.Default_Interrupt_Priority, see
13774 elsif Has_Attach_Handler (Ptyp)
13775 or else Has_Interrupt_Handler (Ptyp)
13778 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc));
13780 -- Normal case, no priority or xx_Handler specified, default priority
13784 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
13787 -- Test for Compiler_Info parameter. This parameter allows entry body
13788 -- procedures and barrier functions to be called from the runtime. It
13789 -- is a pointer to the record generated by the compiler to represent
13790 -- the protected object.
13792 -- A protected type without entries that covers an interface and
13793 -- overrides the abstract routines with protected procedures is
13794 -- considered equivalent to a protected type with entries in the
13795 -- context of dispatching select statements.
13797 -- Protected types with interrupt handlers (when not using a
13798 -- restricted profile) are also considered equivalent to protected
13799 -- types with entries.
13801 -- The types which are used (Static_Interrupt_Protection and
13802 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
13805 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
13807 Called_Subp : RE_Id;
13811 when System_Tasking_Protected_Objects_Entries =>
13812 Called_Subp := RE_Initialize_Protection_Entries;
13814 -- Argument Compiler_Info
13817 Make_Attribute_Reference (Loc,
13818 Prefix => Make_Identifier (Loc, Name_uInit),
13819 Attribute_Name => Name_Address));
13821 when System_Tasking_Protected_Objects_Single_Entry =>
13822 Called_Subp := RE_Initialize_Protection_Entry;
13824 -- Argument Compiler_Info
13827 Make_Attribute_Reference (Loc,
13828 Prefix => Make_Identifier (Loc, Name_uInit),
13829 Attribute_Name => Name_Address));
13831 when System_Tasking_Protected_Objects =>
13832 Called_Subp := RE_Initialize_Protection;
13835 raise Program_Error;
13838 -- Entry_Queue_Maxes parameter. This is an access to an array of
13839 -- naturals representing the entry queue maximums for each entry
13840 -- in the protected type. Zero represents no max. The access is
13841 -- null if there is no limit for all entries (usual case).
13844 and then Pkg_Id = System_Tasking_Protected_Objects_Entries
13846 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then
13848 Make_Attribute_Reference (Loc,
13851 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
13852 Attribute_Name => Name_Unrestricted_Access));
13854 Append_To (Args, Make_Null (Loc));
13857 -- Edge cases exist where entry initialization functions are
13858 -- called, but no entries exist, so null is appended.
13860 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
13861 Append_To (Args, Make_Null (Loc));
13864 -- Entry_Bodies parameter. This is a pointer to an array of
13865 -- pointers to the entry body procedures and barrier functions of
13866 -- the object. If the protected type has no entries this object
13867 -- will not exist, in this case, pass a null (it can happen when
13868 -- there are protected interrupt handlers or interfaces).
13871 P_Arr := Entry_Bodies_Array (Ptyp);
13873 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
13874 -- multiple entries).
13877 Make_Attribute_Reference (Loc,
13878 Prefix => New_Occurrence_Of (P_Arr, Loc),
13879 Attribute_Name => Name_Unrestricted_Access));
13881 if Pkg_Id = System_Tasking_Protected_Objects_Entries then
13883 -- Find index mapping function (clumsy but ok for now)
13885 while Ekind (P_Arr) /= E_Function loop
13886 Next_Entity (P_Arr);
13890 Make_Attribute_Reference (Loc,
13891 Prefix => New_Occurrence_Of (P_Arr, Loc),
13892 Attribute_Name => Name_Unrestricted_Access));
13895 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
13897 -- This is the case where we have a protected object with
13898 -- interfaces and no entries, and the single entry restriction
13899 -- is in effect. We pass a null pointer for the entry
13900 -- parameter because there is no actual entry.
13902 Append_To (Args, Make_Null (Loc));
13904 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
13906 -- This is the case where we have a protected object with no
13908 -- - either interrupt handlers with non restricted profile,
13910 -- Note that the types which are used for interrupt handlers
13911 -- (Static/Dynamic_Interrupt_Protection) are derived from
13912 -- Protection_Entries. We pass two null pointers because there
13913 -- is no actual entry, and the initialization procedure needs
13914 -- both Entry_Bodies and Find_Body_Index.
13916 Append_To (Args, Make_Null (Loc));
13917 Append_To (Args, Make_Null (Loc));
13921 Make_Procedure_Call_Statement (Loc,
13923 New_Occurrence_Of (RTE (Called_Subp), Loc),
13924 Parameter_Associations => Args));
13928 if Has_Attach_Handler (Ptyp) then
13930 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
13931 -- make the following call:
13933 -- Install_Handlers (_object,
13934 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
13936 -- or, in the case of Ravenscar:
13938 -- Install_Restricted_Handlers
13939 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
13942 Args : constant List_Id := New_List;
13943 Table : constant List_Id := New_List;
13944 Ritem : Node_Id := First_Rep_Item (Ptyp);
13947 -- Build the Priority parameter (only for ravenscar)
13951 -- Priority comes from a pragma
13953 if Present (Prio_Var) then
13954 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
13956 -- Priority is the default one
13961 (RTE (RE_Default_Interrupt_Priority), Loc));
13965 -- Build the Attach_Handler table argument
13967 while Present (Ritem) loop
13968 if Nkind (Ritem) = N_Pragma
13969 and then Pragma_Name (Ritem) = Name_Attach_Handler
13972 Handler : constant Node_Id :=
13973 First (Pragma_Argument_Associations (Ritem));
13975 Interrupt : constant Node_Id := Next (Handler);
13976 Expr : constant Node_Id := Expression (Interrupt);
13980 Make_Aggregate (Loc, Expressions => New_List (
13981 Unchecked_Convert_To
13982 (RTE (RE_System_Interrupt_Id), Expr),
13983 Make_Attribute_Reference (Loc,
13985 Make_Selected_Component (Loc,
13987 Make_Identifier (Loc, Name_uInit),
13989 Duplicate_Subexpr_No_Checks
13990 (Expression (Handler))),
13991 Attribute_Name => Name_Access))));
13995 Next_Rep_Item (Ritem);
13998 -- Append the table argument we just built
14000 Append_To (Args, Make_Aggregate (Loc, Table));
14002 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14003 -- call to the statements.
14006 -- Call a simplified version of Install_Handlers to be used
14007 -- when the Ravenscar restrictions are in effect
14008 -- (Install_Restricted_Handlers).
14011 Make_Procedure_Call_Statement (Loc,
14014 (RTE (RE_Install_Restricted_Handlers), Loc),
14015 Parameter_Associations => Args));
14018 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
14020 -- First, prepends the _object argument
14023 Make_Attribute_Reference (Loc,
14025 Make_Selected_Component (Loc,
14026 Prefix => Make_Identifier (Loc, Name_uInit),
14028 Make_Identifier (Loc, Name_uObject)),
14029 Attribute_Name => Name_Unchecked_Access));
14032 -- Then, insert call to Install_Handlers
14035 Make_Procedure_Call_Statement (Loc,
14037 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc),
14038 Parameter_Associations => Args));
14044 end Make_Initialize_Protection;
14046 ---------------------------
14047 -- Make_Task_Create_Call --
14048 ---------------------------
14050 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
14051 Loc : constant Source_Ptr := Sloc (Task_Rec);
14061 Ttyp := Corresponding_Concurrent_Type (Task_Rec);
14062 Tnam := Chars (Ttyp);
14064 -- Get task declaration. In the case of a task type declaration, this is
14065 -- simply the parent of the task type entity. In the single task
14066 -- declaration, this parent will be the implicit type, and we can find
14067 -- the corresponding single task declaration by searching forward in the
14068 -- declaration list in the tree.
14070 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14071 -- this type should have been removed during semantic analysis.
14073 Tdec := Parent (Ttyp);
14074 while not Nkind_In (Tdec, N_Task_Type_Declaration,
14075 N_Single_Task_Declaration)
14080 -- Now we can find the task definition from this declaration
14082 Tdef := Task_Definition (Tdec);
14084 -- Build the parameter list for the call. Note that _Init is the name
14085 -- of the formal for the object to be initialized, which is the task
14086 -- value record itself.
14090 -- Priority parameter. Set to Unspecified_Priority unless there is a
14091 -- Priority rep item, in which case we take the value from the rep item.
14093 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
14095 Make_Selected_Component (Loc,
14096 Prefix => Make_Identifier (Loc, Name_uInit),
14097 Selector_Name => Make_Identifier (Loc, Name_uPriority)));
14100 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14103 -- Optional Stack parameter
14105 if Restricted_Profile then
14107 -- If the stack has been preallocated by the expander then
14108 -- pass its address. Otherwise, pass a null address.
14110 if Preallocated_Stacks_On_Target then
14112 Make_Attribute_Reference (Loc,
14114 Make_Selected_Component (Loc,
14115 Prefix => Make_Identifier (Loc, Name_uInit),
14116 Selector_Name => Make_Identifier (Loc, Name_uStack)),
14117 Attribute_Name => Name_Address));
14121 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
14125 -- Size parameter. If no Storage_Size pragma is present, then
14126 -- the size is taken from the taskZ variable for the type, which
14127 -- is either Unspecified_Size, or has been reset by the use of
14128 -- a Storage_Size attribute definition clause. If a pragma is
14129 -- present, then the size is taken from the _Size field of the
14130 -- task value record, which was set from the pragma value.
14132 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then
14134 Make_Selected_Component (Loc,
14135 Prefix => Make_Identifier (Loc, Name_uInit),
14136 Selector_Name => Make_Identifier (Loc, Name_uSize)));
14140 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc));
14143 -- Secondary_Stack_Size parameter. Set Default_Secondary_Stack_Size
14144 -- unless there is a Secondary_Stack_Size rep item, in which case we
14145 -- take the value from the rep item. If the restriction
14146 -- No_Secondary_Stack is active then a size of 0 is passed regardless
14147 -- to prevent the allocation of the unused stack.
14149 if Restriction_Active (No_Secondary_Stack) then
14150 Append_To (Args, Make_Integer_Literal (Loc, 0));
14152 elsif Has_Rep_Item (Ttyp, Name_Secondary_Stack_Size,
14153 Check_Parents => False)
14156 Make_Selected_Component (Loc,
14157 Prefix => Make_Identifier (Loc, Name_uInit),
14159 Make_Identifier (Loc, Name_uSecondary_Stack_Size)));
14163 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
14166 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14167 -- Task_Info pragma, in which case we take the value from the pragma.
14169 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then
14171 Make_Selected_Component (Loc,
14172 Prefix => Make_Identifier (Loc, Name_uInit),
14173 Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
14177 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc));
14180 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14181 -- in which case we take the value from the rep item. The parameter is
14182 -- passed as an Integer because in the case of unspecified CPU the
14183 -- value is not in the range of CPU_Range.
14185 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then
14187 Convert_To (Standard_Integer,
14188 Make_Selected_Component (Loc,
14189 Prefix => Make_Identifier (Loc, Name_uInit),
14190 Selector_Name => Make_Identifier (Loc, Name_uCPU))));
14193 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc));
14196 if not Restricted_Profile then
14198 -- Deadline parameter. If no Relative_Deadline pragma is present,
14199 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14200 -- the deadline is taken from the _Relative_Deadline field of the
14201 -- task value record, which was set from the pragma value. Note that
14202 -- this parameter must not be generated for the restricted profiles
14203 -- since Ravenscar does not allow deadlines.
14205 -- Case where pragma Relative_Deadline applies: use given value
14207 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
14209 Make_Selected_Component (Loc,
14210 Prefix => Make_Identifier (Loc, Name_uInit),
14212 Make_Identifier (Loc, Name_uRelative_Deadline)));
14214 -- No pragma Relative_Deadline apply to the task
14218 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14221 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14222 -- present, then the dispatching domain is null. If a rep item is
14223 -- present, then the dispatching domain is taken from the
14224 -- _Dispatching_Domain field of the task value record, which was set
14225 -- from the rep item value.
14227 -- Case where Dispatching_Domain rep item applies: use given value
14230 (Ttyp, Name_Dispatching_Domain, Check_Parents => False)
14233 Make_Selected_Component (Loc,
14235 Make_Identifier (Loc, Name_uInit),
14237 Make_Identifier (Loc, Name_uDispatching_Domain)));
14239 -- No pragma or aspect Dispatching_Domain applies to the task
14242 Append_To (Args, Make_Null (Loc));
14245 -- Number of entries. This is an expression of the form:
14247 -- n + _Init.a'Length + _Init.a'B'Length + ...
14249 -- where a,b... are the entry family names for the task definition
14252 Build_Entry_Count_Expression
14257 (Parent (Corresponding_Record_Type (Ttyp))))),
14259 Append_To (Args, Ecount);
14261 -- Master parameter. This is a reference to the _Master parameter of
14262 -- the initialization procedure, except in the case of the pragma
14263 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14264 -- System.Tasking.Library_Task_Level.
14266 if Restriction_Active (No_Task_Hierarchy) = False then
14267 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
14270 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
14274 -- State parameter. This is a pointer to the task body procedure. The
14275 -- required value is obtained by taking 'Unrestricted_Access of the task
14276 -- body procedure and converting it (with an unchecked conversion) to
14277 -- the type required by the task kernel. For further details, see the
14278 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14279 -- than 'Address in order to avoid creating trampolines.
14282 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp);
14283 Subp_Ptr_Typ : constant Node_Id :=
14284 Create_Itype (E_Access_Subprogram_Type, Tdec);
14285 Ref : constant Node_Id := Make_Itype_Reference (Loc);
14288 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc);
14289 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
14291 -- Be sure to freeze a reference to the access-to-subprogram type,
14292 -- otherwise gigi will complain that it's in the wrong scope, because
14293 -- it's actually inside the init procedure for the record type that
14294 -- corresponds to the task type.
14296 Set_Itype (Ref, Subp_Ptr_Typ);
14297 Append_Freeze_Action (Task_Rec, Ref);
14300 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
14301 Make_Qualified_Expression (Loc,
14302 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc),
14304 Make_Attribute_Reference (Loc,
14305 Prefix => New_Occurrence_Of (Body_Proc, Loc),
14306 Attribute_Name => Name_Unrestricted_Access))));
14309 -- Discriminants parameter. This is just the address of the task
14310 -- value record itself (which contains the discriminant values
14313 Make_Attribute_Reference (Loc,
14314 Prefix => Make_Identifier (Loc, Name_uInit),
14315 Attribute_Name => Name_Address));
14317 -- Elaborated parameter. This is an access to the elaboration Boolean
14320 Make_Attribute_Reference (Loc,
14321 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
14322 Attribute_Name => Name_Unchecked_Access));
14324 -- Add Chain parameter (not done for sequential elaboration policy, see
14325 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14327 if Partition_Elaboration_Policy /= 'S' then
14328 Append_To (Args, Make_Identifier (Loc, Name_uChain));
14331 -- Task name parameter. Take this from the _Task_Id parameter to the
14332 -- init call unless there is a Task_Name pragma, in which case we take
14333 -- the value from the pragma.
14335 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then
14336 -- Copy expression in full, because it may be dynamic and have
14343 (Pragma_Argument_Associations
14345 (Ttyp, Name_Task_Name, Check_Parents => False))))));
14348 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
14351 -- Created_Task parameter. This is the _Task_Id field of the task
14355 Make_Selected_Component (Loc,
14356 Prefix => Make_Identifier (Loc, Name_uInit),
14357 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
14363 if Restricted_Profile then
14364 if Partition_Elaboration_Policy = 'S' then
14365 Create_RE := RE_Create_Restricted_Task_Sequential;
14367 Create_RE := RE_Create_Restricted_Task;
14370 Create_RE := RE_Create_Task;
14373 Name := New_Occurrence_Of (RTE (Create_RE), Loc);
14377 Make_Procedure_Call_Statement (Loc,
14379 Parameter_Associations => Args);
14380 end Make_Task_Create_Call;
14382 ------------------------------
14383 -- Next_Protected_Operation --
14384 ------------------------------
14386 function Next_Protected_Operation (N : Node_Id) return Node_Id is
14390 -- Check whether there is a subsequent body for a protected operation
14391 -- in the current protected body. In Ada2012 that includes expression
14392 -- functions that are completions.
14394 Next_Op := Next (N);
14395 while Present (Next_Op)
14396 and then not Nkind_In (Next_Op,
14397 N_Subprogram_Body, N_Entry_Body, N_Expression_Function)
14403 end Next_Protected_Operation;
14405 ---------------------
14406 -- Null_Statements --
14407 ---------------------
14409 function Null_Statements (Stats : List_Id) return Boolean is
14413 Stmt := First (Stats);
14414 while Nkind (Stmt) /= N_Empty
14415 and then (Nkind_In (Stmt, N_Null_Statement, N_Label)
14417 (Nkind (Stmt) = N_Pragma
14419 Nam_In (Pragma_Name_Unmapped (Stmt),
14427 return Nkind (Stmt) = N_Empty;
14428 end Null_Statements;
14430 --------------------------
14431 -- Parameter_Block_Pack --
14432 --------------------------
14434 function Parameter_Block_Pack
14436 Blk_Typ : Entity_Id;
14440 Stmts : List_Id) return Node_Id
14442 Actual : Entity_Id;
14443 Expr : Node_Id := Empty;
14444 Formal : Entity_Id;
14445 Has_Param : Boolean := False;
14448 Temp_Asn : Node_Id;
14449 Temp_Nam : Node_Id;
14452 Actual := First (Actuals);
14453 Formal := Defining_Identifier (First (Formals));
14454 Params := New_List;
14455 while Present (Actual) loop
14456 if Is_By_Copy_Type (Etype (Actual)) then
14458 -- Jnn : aliased <formal-type>
14460 Temp_Nam := Make_Temporary (Loc, 'J');
14463 Make_Object_Declaration (Loc,
14464 Aliased_Present => True,
14465 Defining_Identifier => Temp_Nam,
14466 Object_Definition =>
14467 New_Occurrence_Of (Etype (Formal), Loc)));
14469 if Ekind (Formal) /= E_Out_Parameter then
14475 New_Occurrence_Of (Temp_Nam, Loc);
14477 Set_Assignment_OK (Temp_Asn);
14480 Make_Assignment_Statement (Loc,
14482 Expression => New_Copy_Tree (Actual)));
14486 -- Jnn'unchecked_access
14489 Make_Attribute_Reference (Loc,
14490 Attribute_Name => Name_Unchecked_Access,
14491 Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
14495 -- The controlling parameter is omitted
14498 if not Is_Controlling_Actual (Actual) then
14500 Make_Reference (Loc, New_Copy_Tree (Actual)));
14506 Next_Actual (Actual);
14507 Next_Formal_With_Extras (Formal);
14511 Expr := Make_Aggregate (Loc, Params);
14516 -- J1'unchecked_access;
14517 -- <actual2>'reference;
14520 P := Make_Temporary (Loc, 'P');
14523 Make_Object_Declaration (Loc,
14524 Defining_Identifier => P,
14525 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc),
14526 Expression => Expr));
14529 end Parameter_Block_Pack;
14531 ----------------------------
14532 -- Parameter_Block_Unpack --
14533 ----------------------------
14535 function Parameter_Block_Unpack
14539 Formals : List_Id) return List_Id
14541 Actual : Entity_Id;
14543 Formal : Entity_Id;
14544 Has_Asnmt : Boolean := False;
14545 Result : constant List_Id := New_List;
14548 Actual := First (Actuals);
14549 Formal := Defining_Identifier (First (Formals));
14550 while Present (Actual) loop
14551 if Is_By_Copy_Type (Etype (Actual))
14552 and then Ekind (Formal) /= E_In_Parameter
14555 -- <actual> := P.<formal>;
14558 Make_Assignment_Statement (Loc,
14562 Make_Explicit_Dereference (Loc,
14563 Make_Selected_Component (Loc,
14565 New_Occurrence_Of (P, Loc),
14567 Make_Identifier (Loc, Chars (Formal)))));
14569 Set_Assignment_OK (Name (Asnmt));
14570 Append_To (Result, Asnmt);
14575 Next_Actual (Actual);
14576 Next_Formal_With_Extras (Formal);
14582 return New_List (Make_Null_Statement (Loc));
14584 end Parameter_Block_Unpack;
14586 ----------------------
14587 -- Set_Discriminals --
14588 ----------------------
14590 procedure Set_Discriminals (Dec : Node_Id) is
14593 D_Minal : Entity_Id;
14596 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
14597 Pdef := Defining_Identifier (Dec);
14599 if Has_Discriminants (Pdef) then
14600 D := First_Discriminant (Pdef);
14601 while Present (D) loop
14603 Make_Defining_Identifier (Sloc (D),
14604 Chars => New_External_Name (Chars (D), 'D'));
14606 Set_Ekind (D_Minal, E_Constant);
14607 Set_Etype (D_Minal, Etype (D));
14608 Set_Scope (D_Minal, Pdef);
14609 Set_Discriminal (D, D_Minal);
14610 Set_Discriminal_Link (D_Minal, D);
14612 Next_Discriminant (D);
14615 end Set_Discriminals;
14617 -----------------------
14618 -- Trivial_Accept_OK --
14619 -----------------------
14621 function Trivial_Accept_OK return Boolean is
14623 case Opt.Task_Dispatching_Policy is
14625 -- If we have the default task dispatching policy in effect, we can
14626 -- definitely do the optimization (one way of looking at this is to
14627 -- think of the formal definition of the default policy being allowed
14628 -- to run any task it likes after a rendezvous, so even if notionally
14629 -- a full rescheduling occurs, we can say that our dispatching policy
14630 -- (i.e. the default dispatching policy) reorders the queue to be the
14631 -- same as just before the call.
14636 -- FIFO_Within_Priorities certainly does not permit this
14637 -- optimization since the Rendezvous is a scheduling action that may
14638 -- require some other task to be run.
14643 -- For now, disallow the optimization for all other policies. This
14644 -- may be over-conservative, but it is certainly not incorrect.
14650 end Trivial_Accept_OK;