OSDN Git Service

gcc/ada/
[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_ch9.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                              E X P _ C H 9                               --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
10 --                                                                          --
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.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
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_Ch11; use Exp_Ch11;
33 with Exp_Ch6;  use Exp_Ch6;
34 with Exp_Dbug; use Exp_Dbug;
35 with Exp_Sel;  use Exp_Sel;
36 with Exp_Smem; use Exp_Smem;
37 with Exp_Tss;  use Exp_Tss;
38 with Exp_Util; use Exp_Util;
39 with Freeze;   use Freeze;
40 with Hostparm;
41 with Nlists;   use Nlists;
42 with Nmake;    use Nmake;
43 with Opt;      use Opt;
44 with Restrict; use Restrict;
45 with Rident;   use Rident;
46 with Rtsfind;  use Rtsfind;
47 with Sem;      use Sem;
48 with Sem_Ch6;  use Sem_Ch6;
49 with Sem_Ch8;  use Sem_Ch8;
50 with Sem_Ch11; use Sem_Ch11;
51 with Sem_Elab; use Sem_Elab;
52 with Sem_Res;  use Sem_Res;
53 with Sem_Util; use Sem_Util;
54 with Sinfo;    use Sinfo;
55 with Snames;   use Snames;
56 with Stand;    use Stand;
57 with Targparm; use Targparm;
58 with Tbuild;   use Tbuild;
59 with Uintp;    use Uintp;
60
61 package body Exp_Ch9 is
62
63    --  The following constant establishes the upper bound for the index of
64    --  an entry family. It is used to limit the allocated size of protected
65    --  types with defaulted discriminant of an integer type, when the bound
66    --  of some entry family depends on a discriminant. The limitation to
67    --  entry families of 128K should be reasonable in all cases, and is a
68    --  documented implementation restriction. It will be lifted when protected
69    --  entry families are re-implemented as a single ordered queue.
70
71    Entry_Family_Bound : constant Int := 2**16;
72
73    -----------------------
74    -- Local Subprograms --
75    -----------------------
76
77    function Actual_Index_Expression
78      (Sloc  : Source_Ptr;
79       Ent   : Entity_Id;
80       Index : Node_Id;
81       Tsk   : Entity_Id) return Node_Id;
82    --  Compute the index position for an entry call. Tsk is the target
83    --  task. If the bounds of some entry family depend on discriminants,
84    --  the expression computed by this function uses the discriminants
85    --  of the target task.
86
87    procedure Add_Object_Pointer
88      (Decls : List_Id;
89       Pid   : Entity_Id;
90       Loc   : Source_Ptr);
91    --  Prepend an object pointer declaration to the declaration list
92    --  Decls. This object pointer is initialized to a type conversion
93    --  of the System.Address pointer passed to entry barrier functions
94    --  and entry body procedures.
95
96    procedure Add_Formal_Renamings
97      (Spec  : Node_Id;
98       Decls : List_Id;
99       Ent   : Entity_Id;
100       Loc   : Source_Ptr);
101    --  Create renaming declarations for the formals, inside the procedure
102    --  that implements an entry body. The renamings make the original names
103    --  of the formals accessible to gdb, and serve no other purpose.
104    --    Spec is the specification of the procedure being built.
105    --    Decls is the list of declarations to be enhanced.
106    --    Ent is the entity for the original entry body.
107
108    function Build_Accept_Body (Astat : Node_Id) return Node_Id;
109    --  Transform accept statement into a block with added exception handler.
110    --  Used both for simple accept statements and for accept alternatives in
111    --  select statements. Astat is the accept statement.
112
113    function Build_Barrier_Function
114      (N   : Node_Id;
115       Ent : Entity_Id;
116       Pid : Node_Id) return Node_Id;
117    --  Build the function body returning the value of the barrier expression
118    --  for the specified entry body.
119
120    function Build_Barrier_Function_Specification
121      (Def_Id : Entity_Id;
122       Loc    : Source_Ptr) return Node_Id;
123    --  Build a specification for a function implementing
124    --  the protected entry barrier of the specified entry body.
125
126    function Build_Entry_Count_Expression
127      (Concurrent_Type : Node_Id;
128       Component_List  : List_Id;
129       Loc             : Source_Ptr) return Node_Id;
130    --  Compute number of entries for concurrent object. This is a count of
131    --  simple entries, followed by an expression that computes the length
132    --  of the range of each entry family. A single array with that size is
133    --  allocated for each concurrent object of the type.
134
135    function Build_Parameter_Block
136      (Loc     : Source_Ptr;
137       Actuals : List_Id;
138       Formals : List_Id;
139       Decls   : List_Id) return Entity_Id;
140    --  Generate an access type for each actual parameter in the list Actuals.
141    --  Cleate an encapsulating record that contains all the actuals and return
142    --  its type. Generate:
143    --    type Ann1 is access all <actual1-type>
144    --    ...
145    --    type AnnN is access all <actualN-type>
146    --    type Pnn is record
147    --       <formal1> : Ann1;
148    --       ...
149    --       <formalN> : AnnN;
150    --    end record;
151
152    function Build_Wrapper_Body
153      (Loc      : Source_Ptr;
154       Proc_Nam : Entity_Id;
155       Obj_Typ  : Entity_Id;
156       Formals  : List_Id) return Node_Id;
157    --  Ada 2005 (AI-345): Build the body that wraps a primitive operation
158    --  associated with a protected or task type. This is required to implement
159    --  dispatching calls through interfaces. Proc_Nam is the entry name to be
160    --  wrapped, Obj_Typ is the type of the newly added formal parameter to
161    --  handle object notation, Formals are the original entry formals that will
162    --  be explicitly replicated.
163
164    function Build_Wrapper_Spec
165      (Loc      : Source_Ptr;
166       Proc_Nam : Entity_Id;
167       Obj_Typ  : Entity_Id;
168       Formals  : List_Id) return Node_Id;
169    --  Ada 2005 (AI-345): Build the specification of a primitive operation
170    --  associated with a protected or task type. This is required implement
171    --  dispatching calls through interfaces. Proc_Nam is the entry name to be
172    --  wrapped, Obj_Typ is the type of the newly added formal parameter to
173    --  handle object notation, Formals are the original entry formals that will
174    --  be explicitly replicated.
175
176    function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
177    --  Build the function that translates the entry index in the call
178    --  (which depends on the size of entry families) into an index into the
179    --  Entry_Bodies_Array, to determine the body and barrier function used
180    --  in a protected entry call. A pointer to this function appears in every
181    --  protected object.
182
183    function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
184    --  Build subprogram declaration for previous one
185
186    function Build_Protected_Entry
187      (N   : Node_Id;
188       Ent : Entity_Id;
189       Pid : Node_Id) return Node_Id;
190    --  Build the procedure implementing the statement sequence of
191    --  the specified entry body.
192
193    function Build_Protected_Entry_Specification
194      (Def_Id : Entity_Id;
195       Ent_Id : Entity_Id;
196       Loc    : Source_Ptr) return Node_Id;
197    --  Build a specification for a procedure implementing
198    --  the statement sequence of the specified entry body.
199    --  Add attributes associating it with the entry defining identifier
200    --  Ent_Id.
201
202    function Build_Protected_Subprogram_Body
203      (N         : Node_Id;
204       Pid       : Node_Id;
205       N_Op_Spec : Node_Id) return Node_Id;
206    --  This function is used to construct the protected version of a protected
207    --  subprogram. Its statement sequence first defers abort, then locks
208    --  the associated protected object, and then enters a block that contains
209    --  a call to the unprotected version of the subprogram (for details, see
210    --  Build_Unprotected_Subprogram_Body). This block statement requires
211    --  a cleanup handler that unlocks the object in all cases.
212    --  (see Exp_Ch7.Expand_Cleanup_Actions).
213
214    function Build_Protected_Spec
215      (N           : Node_Id;
216       Obj_Type    : Entity_Id;
217       Unprotected : Boolean := False;
218       Ident       : Entity_Id) return List_Id;
219    --  Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
220    --  Subprogram_Type. Builds signature of protected subprogram, adding the
221    --  formal that corresponds to the object itself. For an access to protected
222    --  subprogram, there is no object type to specify, so the additional
223    --  parameter has type Address and mode In. An indirect call through such
224    --  a pointer converts the address to a reference to the actual object.
225    --  The object is a limited record and therefore a by_reference type.
226
227    function Build_Selected_Name
228      (Prefix      : Entity_Id;
229       Selector    : Entity_Id;
230       Append_Char : Character := ' ') return Name_Id;
231    --  Build a name in the form of Prefix__Selector, with an optional
232    --  character appended. This is used for internal subprograms generated
233    --  for operations of protected types, including barrier functions.
234    --  For the subprograms generated for entry bodies and entry barriers,
235    --  the generated name includes a sequence number that makes names
236    --  unique in the presence of entry overloading. This is necessary
237    --  because entry body procedures and barrier functions all have the
238    --  same signature.
239
240    procedure Build_Simple_Entry_Call
241      (N       : Node_Id;
242       Concval : Node_Id;
243       Ename   : Node_Id;
244       Index   : Node_Id);
245    --  Some comments here would be useful ???
246
247    function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
248    --  This routine constructs a specification for the procedure that we will
249    --  build for the task body for task type T. The spec has the form:
250    --
251    --    procedure tnameB (_Task : access tnameV);
252    --
253    --  where name is the character name taken from the task type entity that
254    --  is passed as the argument to the procedure, and tnameV is the task
255    --  value type that is associated with the task type.
256
257    function Build_Unprotected_Subprogram_Body
258      (N   : Node_Id;
259       Pid : Node_Id) return Node_Id;
260    --  This routine constructs the unprotected version of a protected
261    --  subprogram body, which is contains all of the code in the
262    --  original, unexpanded body. This is the version of the protected
263    --  subprogram that is called from all protected operations on the same
264    --  object, including the protected version of the same subprogram.
265
266    procedure Collect_Entry_Families
267      (Loc          : Source_Ptr;
268       Cdecls       : List_Id;
269       Current_Node : in out Node_Id;
270       Conctyp      : Entity_Id);
271    --  For each entry family in a concurrent type, create an anonymous array
272    --  type of the right size, and add a component to the corresponding_record.
273
274    function Copy_Result_Type (Res : Node_Id) return Node_Id;
275    --  Copy the result type of a function specification, when building the
276    --  internal operation corresponding to a protected function, or when
277    --  expanding an access to protected function. If the result is an anonymous
278    --  access to subprogram itself, we need to create a new signature with the
279    --  same parameter names and the same resolved types, but with new entities
280    --  for the formals.
281
282    function Family_Offset
283      (Loc  : Source_Ptr;
284       Hi   : Node_Id;
285       Lo   : Node_Id;
286       Ttyp : Entity_Id;
287       Cap  : Boolean) return Node_Id;
288    --  Compute (Hi - Lo) for two entry family indices. Hi is the index in
289    --  an accept statement, or the upper bound in the discrete subtype of
290    --  an entry declaration. Lo is the corresponding lower bound. Ttyp is
291    --  the concurrent type of the entry. If Cap is true, the result is
292    --  capped according to Entry_Family_Bound.
293
294    function Family_Size
295      (Loc  : Source_Ptr;
296       Hi   : Node_Id;
297       Lo   : Node_Id;
298       Ttyp : Entity_Id;
299       Cap  : Boolean) return Node_Id;
300    --  Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
301    --  a family, and handle properly the superflat case. This is equivalent
302    --  to the use of 'Length on the index type, but must use Family_Offset
303    --  to handle properly the case of bounds that depend on discriminants.
304    --  If Cap is true, the result is capped according to Entry_Family_Bound.
305
306    procedure Extract_Dispatching_Call
307      (N        : Node_Id;
308       Call_Ent : out Entity_Id;
309       Object   : out Entity_Id;
310       Actuals  : out List_Id;
311       Formals  : out List_Id);
312    --  Given a dispatching call, extract the entity of the name of the call,
313    --  its object parameter, its actual parameters and the formal parameters
314    --  of the overriden interface-level version.
315
316    procedure Extract_Entry
317      (N       : Node_Id;
318       Concval : out Node_Id;
319       Ename   : out Node_Id;
320       Index   : out Node_Id);
321    --  Given an entry call, returns the associated concurrent object,
322    --  the entry name, and the entry family index.
323
324    function Find_Task_Or_Protected_Pragma
325      (T : Node_Id;
326       P : Name_Id) return Node_Id;
327    --  Searches the task or protected definition T for the first occurrence
328    --  of the pragma whose name is given by P. The caller has ensured that
329    --  the pragma is present in the task definition. A special case is that
330    --  when P is Name_uPriority, the call will also find Interrupt_Priority.
331    --  ??? Should be implemented with the rep item chain mechanism.
332
333    function Index_Constant_Declaration
334      (N        : Node_Id;
335       Index_Id : Entity_Id;
336       Prot     : Entity_Id) return List_Id;
337    --  For an entry family and its barrier function, we define a local entity
338    --  that maps the index in the call into the entry index into the object:
339    --
340    --     I : constant Index_Type := Index_Type'Val (
341    --       E - <<index of first family member>> +
342    --       Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
343
344    function Is_Potentially_Large_Family
345      (Base_Index : Entity_Id;
346       Conctyp    : Entity_Id;
347       Lo         : Node_Id;
348       Hi         : Node_Id) return Boolean;
349
350    function Parameter_Block_Pack
351      (Loc     : Source_Ptr;
352       Blk_Typ : Entity_Id;
353       Actuals : List_Id;
354       Formals : List_Id;
355       Decls   : List_Id;
356       Stmts   : List_Id) return Entity_Id;
357    --  Set the components of the generated parameter block with the values of
358    --  the actual parameters. Generate aliased temporaries to capture the
359    --  values for types that are passed by copy. Otherwise generate a reference
360    --  to the actual's value. Return the address of the aggregate block.
361    --  Generate:
362    --    Jnn1 : alias <formal-type1>;
363    --    Jnn1 := <actual1>;
364    --    ...
365    --    P : Blk_Typ := (
366    --      Jnn1'unchecked_access;
367    --      <actual2>'reference;
368    --      ...);
369
370    function Parameter_Block_Unpack
371      (Loc     : Source_Ptr;
372       P       : Entity_Id;
373       Actuals : List_Id;
374       Formals : List_Id) return List_Id;
375    --  Retrieve the values of the components from the parameter block and
376    --  assign then to the original actual parameters. Generate:
377    --    <actual1> := P.<formal1>;
378    --    ...
379    --    <actualN> := P.<formalN>;
380
381    procedure Update_Prival_Subtypes (N : Node_Id);
382    --  The actual subtypes of the privals will differ from the type of the
383    --  private declaration in the original protected type, if the protected
384    --  type has discriminants or if the prival has constrained components.
385    --  This is because the privals are generated out of sequence w.r.t. the
386    --  analysis of a protected body. After generating the bodies for protected
387    --  operations, we set correctly the type of all references to privals, by
388    --  means of a recursive tree traversal, which is heavy-handed but
389    --  correct.
390
391    -----------------------------
392    -- Actual_Index_Expression --
393    -----------------------------
394
395    function Actual_Index_Expression
396      (Sloc  : Source_Ptr;
397       Ent   : Entity_Id;
398       Index : Node_Id;
399       Tsk   : Entity_Id) return Node_Id
400    is
401       Ttyp : constant Entity_Id := Etype (Tsk);
402       Expr : Node_Id;
403       Num  : Node_Id;
404       Lo   : Node_Id;
405       Hi   : Node_Id;
406       Prev : Entity_Id;
407       S    : Node_Id;
408
409       function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
410       --  Compute difference between bounds of entry family
411
412       --------------------------
413       -- Actual_Family_Offset --
414       --------------------------
415
416       function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
417
418          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
419          --  Replace a reference to a discriminant with a selected component
420          --  denoting the discriminant of the target task.
421
422          -----------------------------
423          -- Actual_Discriminant_Ref --
424          -----------------------------
425
426          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
427             Typ : constant Entity_Id := Etype (Bound);
428             B   : Node_Id;
429
430          begin
431             if not Is_Entity_Name (Bound)
432               or else Ekind (Entity (Bound)) /= E_Discriminant
433             then
434                if Nkind (Bound) = N_Attribute_Reference then
435                   return Bound;
436                else
437                   B := New_Copy_Tree (Bound);
438                end if;
439
440             else
441                B :=
442                  Make_Selected_Component (Sloc,
443                    Prefix => New_Copy_Tree (Tsk),
444                    Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
445
446                Analyze_And_Resolve (B, Typ);
447             end if;
448
449             return
450               Make_Attribute_Reference (Sloc,
451                 Attribute_Name => Name_Pos,
452                 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
453                 Expressions => New_List (B));
454          end Actual_Discriminant_Ref;
455
456       --  Start of processing for Actual_Family_Offset
457
458       begin
459          return
460            Make_Op_Subtract (Sloc,
461              Left_Opnd  => Actual_Discriminant_Ref (Hi),
462              Right_Opnd => Actual_Discriminant_Ref (Lo));
463       end Actual_Family_Offset;
464
465    --  Start of processing for Actual_Index_Expression
466
467    begin
468       --  The queues of entries and entry families appear in textual order in
469       --  the associated record. The entry index is computed as the sum of the
470       --  number of queues for all entries that precede the designated one, to
471       --  which is added the index expression, if this expression denotes a
472       --  member of a family.
473
474       --  The following is a place holder for the count of simple entries
475
476       Num := Make_Integer_Literal (Sloc, 1);
477
478       --  We construct an expression which is a series of addition operations.
479       --  See comments in Entry_Index_Expression, which is identical in
480       --  structure.
481
482       if Present (Index) then
483          S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
484
485          Expr :=
486            Make_Op_Add (Sloc,
487              Left_Opnd  => Num,
488
489              Right_Opnd =>
490                Actual_Family_Offset (
491                  Make_Attribute_Reference (Sloc,
492                    Attribute_Name => Name_Pos,
493                    Prefix => New_Reference_To (Base_Type (S), Sloc),
494                    Expressions => New_List (Relocate_Node (Index))),
495                  Type_Low_Bound (S)));
496       else
497          Expr := Num;
498       end if;
499
500       --  Now add lengths of preceding entries and entry families
501
502       Prev := First_Entity (Ttyp);
503
504       while Chars (Prev) /= Chars (Ent)
505         or else (Ekind (Prev) /= Ekind (Ent))
506         or else not Sem_Ch6.Type_Conformant (Ent, Prev)
507       loop
508          if Ekind (Prev) = E_Entry then
509             Set_Intval (Num, Intval (Num) + 1);
510
511          elsif Ekind (Prev) = E_Entry_Family then
512             S :=
513               Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
514
515             --  The need for the following full view retrieval stems from
516             --  this complex case of nested generics and tasking:
517
518             --     generic
519             --        type Formal_Index is range <>;
520             --        ...
521             --     package Outer is
522             --        type Index is private;
523             --        generic
524             --           ...
525             --        package Inner is
526             --           procedure P;
527             --        end Inner;
528             --     private
529             --        type Index is new Formal_Index range 1 .. 10;
530             --     end Outer;
531
532             --     package body Outer is
533             --        task type T is
534             --           entry Fam (Index);  --  (2)
535             --           entry E;
536             --        end T;
537             --        package body Inner is  --  (3)
538             --           procedure P is
539             --           begin
540             --              T.E;             --  (1)
541             --           end P;
542             --       end Inner;
543             --       ...
544
545             --  We are currently building the index expression for the entry
546             --  call "T.E" (1). Part of the expansion must mention the range
547             --  of the discrete type "Index" (2) of entry family "Fam".
548             --  However only the private view of type "Index" is available to
549             --  the inner generic (3) because there was no prior mention of
550             --  the type inside "Inner". This visibility requirement is
551             --  implicit and cannot be detected during the construction of
552             --  the generic trees and needs special handling.
553
554             if In_Instance_Body
555               and then Is_Private_Type (S)
556               and then Present (Full_View (S))
557             then
558                S := Full_View (S);
559             end if;
560
561             Lo := Type_Low_Bound  (S);
562             Hi := Type_High_Bound (S);
563
564             Expr :=
565               Make_Op_Add (Sloc,
566               Left_Opnd  => Expr,
567               Right_Opnd =>
568                 Make_Op_Add (Sloc,
569                   Left_Opnd =>
570                     Actual_Family_Offset (Hi, Lo),
571                   Right_Opnd =>
572                     Make_Integer_Literal (Sloc, 1)));
573
574          --  Other components are anonymous types to be ignored
575
576          else
577             null;
578          end if;
579
580          Next_Entity (Prev);
581       end loop;
582
583       return Expr;
584    end Actual_Index_Expression;
585
586    ----------------------------------
587    -- Add_Discriminal_Declarations --
588    ----------------------------------
589
590    procedure Add_Discriminal_Declarations
591      (Decls : List_Id;
592       Typ   : Entity_Id;
593       Name  : Name_Id;
594       Loc   : Source_Ptr)
595    is
596       D     : Entity_Id;
597
598    begin
599       if Has_Discriminants (Typ) then
600          D := First_Discriminant (Typ);
601
602          while Present (D) loop
603
604             Prepend_To (Decls,
605               Make_Object_Renaming_Declaration (Loc,
606                 Defining_Identifier => Discriminal (D),
607                 Subtype_Mark => New_Reference_To (Etype (D), Loc),
608                 Name =>
609                   Make_Selected_Component (Loc,
610                     Prefix        => Make_Identifier (Loc, Name),
611                     Selector_Name => Make_Identifier (Loc, Chars (D)))));
612
613             Next_Discriminant (D);
614          end loop;
615       end if;
616    end Add_Discriminal_Declarations;
617
618    ------------------------
619    -- Add_Object_Pointer --
620    ------------------------
621
622    procedure Add_Object_Pointer
623      (Decls : List_Id;
624       Pid   : Entity_Id;
625       Loc   : Source_Ptr)
626    is
627       Decl    : Node_Id;
628       Obj_Ptr : Node_Id;
629
630    begin
631       --  Prepend the declaration of _object. This must be first in the
632       --  declaration list, since it is used by the discriminal and
633       --  prival declarations.
634       --  ??? An attempt to make this a renaming was unsuccessful.
635       --
636       --     type poVP is access poV;
637       --     _object : poVP := poVP!O;
638
639       Obj_Ptr :=
640         Make_Defining_Identifier (Loc,
641           Chars =>
642             New_External_Name
643               (Chars (Corresponding_Record_Type (Pid)), 'P'));
644
645       Decl :=
646         Make_Object_Declaration (Loc,
647           Defining_Identifier =>
648             Make_Defining_Identifier (Loc, Name_uObject),
649           Object_Definition => New_Reference_To (Obj_Ptr, Loc),
650           Expression =>
651             Unchecked_Convert_To (Obj_Ptr,
652               Make_Identifier (Loc, Name_uO)));
653       Set_Needs_Debug_Info (Defining_Identifier (Decl));
654       Prepend_To (Decls, Decl);
655
656       Prepend_To (Decls,
657         Make_Full_Type_Declaration (Loc,
658           Defining_Identifier => Obj_Ptr,
659           Type_Definition => Make_Access_To_Object_Definition (Loc,
660             Subtype_Indication =>
661               New_Reference_To (Corresponding_Record_Type (Pid), Loc))));
662    end Add_Object_Pointer;
663
664    --------------------------
665    -- Add_Formal_Renamings --
666    --------------------------
667
668    procedure Add_Formal_Renamings
669      (Spec  : Node_Id;
670       Decls : List_Id;
671       Ent   : Entity_Id;
672       Loc   : Source_Ptr)
673    is
674       Ptr : constant Entity_Id :=
675               Defining_Identifier
676                 (Next (First (Parameter_Specifications (Spec))));
677       --  The name of the formal that holds the address of the parameter block
678       --  for the call.
679
680       Comp   : Entity_Id;
681       Decl   : Node_Id;
682       Formal : Entity_Id;
683       New_F  : Entity_Id;
684
685    begin
686       Formal := First_Formal (Ent);
687       while Present (Formal) loop
688          Comp   := Entry_Component (Formal);
689          New_F  :=
690            Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
691          Set_Etype (New_F, Etype (Formal));
692          Set_Scope (New_F, Ent);
693          Set_Needs_Debug_Info (New_F);   --  That's the whole point.
694
695          if Ekind (Formal) = E_In_Parameter then
696             Set_Ekind (New_F, E_Constant);
697          else
698             Set_Ekind (New_F, E_Variable);
699             Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
700          end if;
701
702          Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
703
704          Decl :=
705            Make_Object_Renaming_Declaration (Loc,
706            Defining_Identifier => New_F,
707            Subtype_Mark => New_Reference_To (Etype (Formal), Loc),
708            Name =>
709              Make_Explicit_Dereference (Loc,
710                Make_Selected_Component (Loc,
711                  Prefix =>
712                    Unchecked_Convert_To (Entry_Parameters_Type (Ent),
713                      Make_Identifier (Loc, Chars (Ptr))),
714                  Selector_Name =>
715                    New_Reference_To (Comp, Loc))));
716
717          Append (Decl, Decls);
718          Set_Renamed_Object (Formal, New_F);
719          Next_Formal (Formal);
720       end loop;
721    end Add_Formal_Renamings;
722
723    ------------------------------
724    -- Add_Private_Declarations --
725    ------------------------------
726
727    procedure Add_Private_Declarations
728      (Decls : List_Id;
729       Typ   : Entity_Id;
730       Name  : Name_Id;
731       Loc   : Source_Ptr)
732    is
733       Def      : constant Node_Id   := Protected_Definition (Parent (Typ));
734       Decl     : Node_Id;
735       Body_Ent : constant Entity_Id := Corresponding_Body   (Parent (Typ));
736       P        : Node_Id;
737       Pdef     : Entity_Id;
738
739    begin
740       pragma Assert (Nkind (Def) = N_Protected_Definition);
741
742       if Present (Private_Declarations (Def)) then
743          P := First (Private_Declarations (Def));
744          while Present (P) loop
745             if Nkind (P) = N_Component_Declaration then
746                Pdef := Defining_Identifier (P);
747
748                --  The privals are declared before the current body is
749                --  analyzed. for visibility reasons. Set their Sloc so
750                --  that it is consistent with their renaming declaration,
751                --  to prevent anomalies in gdb.
752
753                --  This kludgy model for privals should be redesigned ???
754
755                Set_Sloc (Prival (Pdef), Loc);
756
757                Decl :=
758                  Make_Object_Renaming_Declaration (Loc,
759                    Defining_Identifier => Prival (Pdef),
760                    Subtype_Mark => New_Reference_To (Etype (Pdef), Loc),
761                    Name =>
762                      Make_Selected_Component (Loc,
763                        Prefix        => Make_Identifier (Loc, Name),
764                        Selector_Name => Make_Identifier (Loc, Chars (Pdef))));
765                Set_Needs_Debug_Info (Defining_Identifier (Decl));
766                Prepend_To (Decls, Decl);
767             end if;
768
769             Next (P);
770          end loop;
771       end if;
772
773       --  One more "prival" for object itself, with the right protection type
774
775       declare
776          Protection_Type : RE_Id;
777
778       begin
779          if Has_Attach_Handler (Typ) then
780             if Restricted_Profile then
781                if Has_Entries (Typ) then
782                   Protection_Type := RE_Protection_Entry;
783                else
784                   Protection_Type := RE_Protection;
785                end if;
786             else
787                Protection_Type := RE_Static_Interrupt_Protection;
788             end if;
789
790          elsif Has_Interrupt_Handler (Typ) then
791             Protection_Type := RE_Dynamic_Interrupt_Protection;
792
793          --  The type has explicit entries or generated primitive entry
794          --  wrappers.
795
796          elsif Has_Entries (Typ)
797             or else (Ada_Version >= Ada_05
798                        and then Present (Interface_List (Parent (Typ))))
799          then
800             if Abort_Allowed
801               or else Restriction_Active (No_Entry_Queue) = False
802               or else Number_Entries (Typ) > 1
803             then
804                Protection_Type := RE_Protection_Entries;
805             else
806                Protection_Type := RE_Protection_Entry;
807             end if;
808
809          else
810             Protection_Type := RE_Protection;
811          end if;
812
813          --  Adjust Sloc, as for the other privals
814
815          Set_Sloc (Object_Ref (Body_Ent), Loc);
816
817          Decl :=
818            Make_Object_Renaming_Declaration (Loc,
819              Defining_Identifier => Object_Ref (Body_Ent),
820              Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc),
821              Name =>
822                Make_Selected_Component (Loc,
823                  Prefix        => Make_Identifier (Loc, Name),
824                  Selector_Name => Make_Identifier (Loc, Name_uObject)));
825          Set_Needs_Debug_Info (Defining_Identifier (Decl));
826          Prepend_To (Decls, Decl);
827       end;
828    end Add_Private_Declarations;
829
830    -----------------------
831    -- Build_Accept_Body --
832    -----------------------
833
834    function Build_Accept_Body (Astat : Node_Id) return  Node_Id is
835       Loc     : constant Source_Ptr := Sloc (Astat);
836       Stats   : constant Node_Id    := Handled_Statement_Sequence (Astat);
837       New_S   : Node_Id;
838       Hand    : Node_Id;
839       Call    : Node_Id;
840       Ohandle : Node_Id;
841
842    begin
843       --  At the end of the statement sequence, Complete_Rendezvous is called.
844       --  A label skipping the Complete_Rendezvous, and all other accept
845       --  processing, has already been added for the expansion of requeue
846       --  statements.
847
848       Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
849       Insert_Before (Last (Statements (Stats)), Call);
850       Analyze (Call);
851
852       --  If exception handlers are present, then append Complete_Rendezvous
853       --  calls to the handlers, and construct the required outer block.
854
855       if Present (Exception_Handlers (Stats)) then
856          Hand := First (Exception_Handlers (Stats));
857
858          while Present (Hand) loop
859             Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
860             Append (Call, Statements (Hand));
861             Analyze (Call);
862             Next (Hand);
863          end loop;
864
865          New_S :=
866            Make_Handled_Sequence_Of_Statements (Loc,
867              Statements => New_List (
868                Make_Block_Statement (Loc,
869                  Handled_Statement_Sequence => Stats)));
870
871       else
872          New_S := Stats;
873       end if;
874
875       --  At this stage we know that the new statement sequence does not
876       --  have an exception handler part, so we supply one to call
877       --  Exceptional_Complete_Rendezvous. This handler is
878
879       --    when all others =>
880       --       Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
881
882       --  We handle Abort_Signal to make sure that we properly catch the abort
883       --  case and wake up the caller.
884
885       Ohandle := Make_Others_Choice (Loc);
886       Set_All_Others (Ohandle);
887
888       Set_Exception_Handlers (New_S,
889         New_List (
890           Make_Implicit_Exception_Handler (Loc,
891             Exception_Choices => New_List (Ohandle),
892
893             Statements =>  New_List (
894               Make_Procedure_Call_Statement (Loc,
895                 Name => New_Reference_To (
896                   RTE (RE_Exceptional_Complete_Rendezvous), Loc),
897                 Parameter_Associations => New_List (
898                   Make_Function_Call (Loc,
899                     Name => New_Reference_To (
900                       RTE (RE_Get_GNAT_Exception), Loc))))))));
901
902       Set_Parent (New_S, Astat); -- temp parent for Analyze call
903       Analyze_Exception_Handlers (Exception_Handlers (New_S));
904       Expand_Exception_Handlers (New_S);
905
906       --  Exceptional_Complete_Rendezvous must be called with abort
907       --  still deferred, which is the case for a "when all others" handler.
908
909       return New_S;
910    end Build_Accept_Body;
911
912    -----------------------------------
913    -- Build_Activation_Chain_Entity --
914    -----------------------------------
915
916    procedure Build_Activation_Chain_Entity (N : Node_Id) is
917       P     : Node_Id;
918       Decls : List_Id;
919       Chain : Entity_Id;
920
921    begin
922       --  Loop to find enclosing construct containing activation chain variable
923
924       P := Parent (N);
925
926       while Nkind (P) /= N_Subprogram_Body
927         and then Nkind (P) /= N_Package_Declaration
928         and then Nkind (P) /= N_Package_Body
929         and then Nkind (P) /= N_Block_Statement
930         and then Nkind (P) /= N_Task_Body
931         and then Nkind (P) /= N_Extended_Return_Statement
932       loop
933          P := Parent (P);
934       end loop;
935
936       --  If we are in a package body, the activation chain variable is
937       --  declared in the body, but the Activation_Chain_Entity is attached to
938       --  the spec.
939
940       if Nkind (P) = N_Package_Body then
941          Decls := Declarations (P);
942          P := Unit_Declaration_Node (Corresponding_Spec (P));
943
944       elsif Nkind (P) = N_Package_Declaration then
945          Decls := Visible_Declarations (Specification (P));
946
947       elsif Nkind (P) = N_Extended_Return_Statement then
948          Decls := Return_Object_Declarations (P);
949
950       else
951          Decls := Declarations (P);
952       end if;
953
954       --  If activation chain entity not already declared, declare it
955
956       if Nkind (P) = N_Extended_Return_Statement
957         or else No (Activation_Chain_Entity (P))
958       then
959          Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
960
961          --  Note: An extended return statement is not really a task activator,
962          --  but it does have an activation chain on which to store the tasks
963          --  temporarily. On successful return, the tasks on this chain are
964          --  moved to the chain passed in by the caller. We do not build an
965          --  Activatation_Chain_Entity for an N_Extended_Return_Statement,
966          --  because we do not want to build a call to Activate_Tasks. Task
967          --  activation is the responsibility of the caller.
968
969          if Nkind (P) /= N_Extended_Return_Statement then
970             Set_Activation_Chain_Entity (P, Chain);
971          end if;
972
973          Prepend_To (Decls,
974            Make_Object_Declaration (Sloc (P),
975              Defining_Identifier => Chain,
976              Aliased_Present => True,
977              Object_Definition =>
978                New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
979
980          Analyze (First (Decls));
981       end if;
982    end Build_Activation_Chain_Entity;
983
984    ----------------------------
985    -- Build_Barrier_Function --
986    ----------------------------
987
988    function Build_Barrier_Function
989      (N   : Node_Id;
990       Ent : Entity_Id;
991       Pid : Node_Id) return Node_Id
992    is
993       Loc         : constant Source_Ptr := Sloc (N);
994       Ent_Formals : constant Node_Id    := Entry_Body_Formal_Part (N);
995       Index_Spec  : constant Node_Id    := Entry_Index_Specification
996                                                            (Ent_Formals);
997       Op_Decls : constant List_Id := New_List;
998       Bdef     : Entity_Id;
999       Bspec    : Node_Id;
1000       EBF      : Node_Id;
1001
1002    begin
1003       Bdef :=
1004         Make_Defining_Identifier (Loc,
1005           Chars => Chars (Barrier_Function (Ent)));
1006       Bspec := Build_Barrier_Function_Specification (Bdef, Loc);
1007
1008       --  <object pointer declaration>
1009       --  <discriminant renamings>
1010       --  <private object renamings>
1011       --  Add discriminal and private renamings. These names have
1012       --  already been used to expand references to discriminants
1013       --  and private data.
1014
1015       Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc);
1016       Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc);
1017       Add_Object_Pointer (Op_Decls, Pid, Loc);
1018
1019       --  If this is the barrier for an entry family, the entry index is
1020       --  visible in the body of the barrier. Create a local variable that
1021       --  converts the entry index (which is the last formal of the barrier
1022       --  function) into the appropriate offset into the entry array. The
1023       --  entry index constant must be set, as for the entry body, so that
1024       --  local references to the entry index are correctly replaced with
1025       --  the local variable. This parallels what is done for entry bodies.
1026
1027       if Present (Index_Spec) then
1028          declare
1029             Index_Id  : constant Entity_Id := Defining_Identifier (Index_Spec);
1030             Index_Con : constant Entity_Id :=
1031                           Make_Defining_Identifier (Loc,
1032                             Chars => New_Internal_Name ('J'));
1033          begin
1034             Set_Entry_Index_Constant (Index_Id, Index_Con);
1035             Append_List_To (Op_Decls,
1036               Index_Constant_Declaration (N, Index_Id, Pid));
1037          end;
1038       end if;
1039
1040       --  Note: the condition in the barrier function needs to be properly
1041       --  processed for the C/Fortran boolean possibility, but this happens
1042       --  automatically since the return statement does this normalization.
1043
1044       EBF :=
1045         Make_Subprogram_Body (Loc,
1046           Specification => Bspec,
1047           Declarations => Op_Decls,
1048           Handled_Statement_Sequence =>
1049             Make_Handled_Sequence_Of_Statements (Loc,
1050               Statements => New_List (
1051                 Make_Simple_Return_Statement (Loc,
1052                   Expression => Condition (Ent_Formals)))));
1053       Set_Is_Entry_Barrier_Function (EBF);
1054       return EBF;
1055    end Build_Barrier_Function;
1056
1057    ------------------------------------------
1058    -- Build_Barrier_Function_Specification --
1059    ------------------------------------------
1060
1061    function Build_Barrier_Function_Specification
1062      (Def_Id : Entity_Id;
1063       Loc    : Source_Ptr) return Node_Id
1064    is
1065    begin
1066       Set_Needs_Debug_Info (Def_Id);
1067       return Make_Function_Specification (Loc,
1068         Defining_Unit_Name => Def_Id,
1069         Parameter_Specifications => New_List (
1070           Make_Parameter_Specification (Loc,
1071             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1072             Parameter_Type =>
1073               New_Reference_To (RTE (RE_Address), Loc)),
1074
1075           Make_Parameter_Specification (Loc,
1076             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
1077             Parameter_Type =>
1078               New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
1079
1080         Result_Definition => New_Reference_To (Standard_Boolean, Loc));
1081    end Build_Barrier_Function_Specification;
1082
1083    --------------------------
1084    -- Build_Call_With_Task --
1085    --------------------------
1086
1087    function Build_Call_With_Task
1088      (N : Node_Id;
1089       E : Entity_Id) return Node_Id
1090    is
1091       Loc : constant Source_Ptr := Sloc (N);
1092    begin
1093       return
1094         Make_Function_Call (Loc,
1095           Name => New_Reference_To (E, Loc),
1096           Parameter_Associations => New_List (Concurrent_Ref (N)));
1097    end Build_Call_With_Task;
1098
1099    --------------------------------
1100    -- Build_Corresponding_Record --
1101    --------------------------------
1102
1103    function Build_Corresponding_Record
1104     (N    : Node_Id;
1105      Ctyp : Entity_Id;
1106      Loc  : Source_Ptr) return Node_Id
1107    is
1108       Rec_Ent  : constant Entity_Id :=
1109                    Make_Defining_Identifier
1110                      (Loc, New_External_Name (Chars (Ctyp), 'V'));
1111       Disc     : Entity_Id;
1112       Dlist    : List_Id;
1113       New_Disc : Entity_Id;
1114       Cdecls   : List_Id;
1115
1116    begin
1117       Set_Corresponding_Record_Type     (Ctyp, Rec_Ent);
1118       Set_Ekind                         (Rec_Ent, E_Record_Type);
1119       Set_Has_Delayed_Freeze            (Rec_Ent, Has_Delayed_Freeze (Ctyp));
1120       Set_Is_Concurrent_Record_Type     (Rec_Ent, True);
1121       Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
1122       Set_Stored_Constraint             (Rec_Ent, No_Elist);
1123       Cdecls := New_List;
1124
1125       --  Use discriminals to create list of discriminants for record, and
1126       --  create new discriminals for use in default expressions, etc. It is
1127       --  worth noting that a task discriminant gives rise to 5 entities;
1128
1129       --  a) The original discriminant.
1130       --  b) The discriminal for use in the task.
1131       --  c) The discriminant of the corresponding record.
1132       --  d) The discriminal for the init proc of the corresponding record.
1133       --  e) The local variable that renames the discriminant in the procedure
1134       --     for the task body.
1135
1136       --  In fact the discriminals b) are used in the renaming declarations
1137       --  for e). See details in  einfo (Handling of Discriminants).
1138
1139       if Present (Discriminant_Specifications (N)) then
1140          Dlist := New_List;
1141          Disc := First_Discriminant (Ctyp);
1142
1143          while Present (Disc) loop
1144             New_Disc := CR_Discriminant (Disc);
1145
1146             Append_To (Dlist,
1147               Make_Discriminant_Specification (Loc,
1148                 Defining_Identifier => New_Disc,
1149                 Discriminant_Type =>
1150                   New_Occurrence_Of (Etype (Disc), Loc),
1151                 Expression =>
1152                   New_Copy (Discriminant_Default_Value (Disc))));
1153
1154             Next_Discriminant (Disc);
1155          end loop;
1156
1157       else
1158          Dlist := No_List;
1159       end if;
1160
1161       --  Now we can construct the record type declaration. Note that this
1162       --  record is "limited tagged". It is "limited" to reflect the underlying
1163       --  limitedness of the task or protected object that it represents, and
1164       --  ensuring for example that it is properly passed by reference. It is
1165       --  "tagged" to give support to dispatching calls through interfaces (Ada
1166       --  2005: AI-345)
1167
1168       return
1169         Make_Full_Type_Declaration (Loc,
1170           Defining_Identifier => Rec_Ent,
1171           Discriminant_Specifications => Dlist,
1172           Type_Definition =>
1173             Make_Record_Definition (Loc,
1174               Component_List =>
1175                 Make_Component_List (Loc,
1176                   Component_Items => Cdecls),
1177               Tagged_Present  =>
1178                  Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp),
1179               Limited_Present => True));
1180    end Build_Corresponding_Record;
1181
1182    ----------------------------------
1183    -- Build_Entry_Count_Expression --
1184    ----------------------------------
1185
1186    function Build_Entry_Count_Expression
1187      (Concurrent_Type : Node_Id;
1188       Component_List  : List_Id;
1189       Loc             : Source_Ptr) return Node_Id
1190    is
1191       Eindx  : Nat;
1192       Ent    : Entity_Id;
1193       Ecount : Node_Id;
1194       Comp   : Node_Id;
1195       Lo     : Node_Id;
1196       Hi     : Node_Id;
1197       Typ    : Entity_Id;
1198       Large  : Boolean;
1199
1200    begin
1201       --  Count number of non-family entries
1202
1203       Eindx := 0;
1204       Ent := First_Entity (Concurrent_Type);
1205       while Present (Ent) loop
1206          if Ekind (Ent) = E_Entry then
1207             Eindx := Eindx + 1;
1208          end if;
1209
1210          Next_Entity (Ent);
1211       end loop;
1212
1213       Ecount := Make_Integer_Literal (Loc, Eindx);
1214
1215       --  Loop through entry families building the addition nodes
1216
1217       Ent := First_Entity (Concurrent_Type);
1218       Comp := First (Component_List);
1219       while Present (Ent) loop
1220          if Ekind (Ent) = E_Entry_Family then
1221             while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
1222                Next (Comp);
1223             end loop;
1224
1225             Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1226             Hi := Type_High_Bound (Typ);
1227             Lo := Type_Low_Bound  (Typ);
1228             Large := Is_Potentially_Large_Family
1229                        (Base_Type (Typ), Concurrent_Type, Lo, Hi);
1230             Ecount :=
1231               Make_Op_Add (Loc,
1232                 Left_Opnd  => Ecount,
1233                 Right_Opnd => Family_Size
1234                                 (Loc, Hi, Lo, Concurrent_Type, Large));
1235          end if;
1236
1237          Next_Entity (Ent);
1238       end loop;
1239
1240       return Ecount;
1241    end Build_Entry_Count_Expression;
1242
1243    ---------------------------
1244    -- Build_Parameter_Block --
1245    ---------------------------
1246
1247    function Build_Parameter_Block
1248      (Loc     : Source_Ptr;
1249       Actuals : List_Id;
1250       Formals : List_Id;
1251       Decls   : List_Id) return Entity_Id
1252    is
1253       Actual   : Entity_Id;
1254       Comp_Nam : Node_Id;
1255       Comps    : List_Id;
1256       Formal   : Entity_Id;
1257       Has_Comp : Boolean := False;
1258       Rec_Nam  : Node_Id;
1259
1260    begin
1261       Actual := First (Actuals);
1262       Comps  := New_List;
1263       Formal := Defining_Identifier (First (Formals));
1264
1265       while Present (Actual) loop
1266          if not Is_Controlling_Actual (Actual) then
1267
1268             --  Generate:
1269             --    type Ann is access all <actual-type>
1270
1271             Comp_Nam :=
1272               Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
1273
1274             Append_To (Decls,
1275               Make_Full_Type_Declaration (Loc,
1276                 Defining_Identifier =>
1277                   Comp_Nam,
1278                 Type_Definition =>
1279                   Make_Access_To_Object_Definition (Loc,
1280                     All_Present =>
1281                       True,
1282                     Constant_Present =>
1283                       Ekind (Formal) = E_In_Parameter,
1284                     Subtype_Indication =>
1285                       New_Reference_To (Etype (Actual), Loc))));
1286
1287             --  Generate:
1288             --    Param : Ann;
1289
1290             Append_To (Comps,
1291               Make_Component_Declaration (Loc,
1292                 Defining_Identifier =>
1293                   Make_Defining_Identifier (Loc, Chars (Formal)),
1294                 Component_Definition =>
1295                   Make_Component_Definition (Loc,
1296                     Aliased_Present =>
1297                       False,
1298                     Subtype_Indication =>
1299                       New_Reference_To (Comp_Nam, Loc))));
1300
1301             Has_Comp := True;
1302          end if;
1303
1304          Next_Actual (Actual);
1305          Next_Formal_With_Extras (Formal);
1306       end loop;
1307
1308       Rec_Nam :=
1309         Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1310
1311       if Has_Comp then
1312
1313          --  Generate:
1314          --    type Pnn is record
1315          --       Param1 : Ann1;
1316          --       ...
1317          --       ParamN : AnnN;
1318
1319          --  where Pnn is a parameter wrapping record, Param1 .. ParamN are
1320          --  the original parameter names and Ann1 .. AnnN are the access to
1321          --  actual types.
1322
1323          Append_To (Decls,
1324            Make_Full_Type_Declaration (Loc,
1325              Defining_Identifier =>
1326                Rec_Nam,
1327              Type_Definition =>
1328                Make_Record_Definition (Loc,
1329                  Component_List =>
1330                    Make_Component_List (Loc, Comps))));
1331       else
1332          --  Generate:
1333          --    type Pnn is null record;
1334
1335          Append_To (Decls,
1336            Make_Full_Type_Declaration (Loc,
1337              Defining_Identifier =>
1338                Rec_Nam,
1339              Type_Definition =>
1340                Make_Record_Definition (Loc,
1341                  Null_Present   => True,
1342                  Component_List => Empty)));
1343       end if;
1344
1345       return Rec_Nam;
1346    end Build_Parameter_Block;
1347
1348    ------------------------
1349    -- Build_Wrapper_Body --
1350    ------------------------
1351
1352    function Build_Wrapper_Body
1353      (Loc      : Source_Ptr;
1354       Proc_Nam : Entity_Id;
1355       Obj_Typ  : Entity_Id;
1356       Formals  : List_Id) return Node_Id
1357    is
1358       Actuals      : List_Id := No_List;
1359       Body_Spec    : Node_Id;
1360       Conv_Id      : Node_Id;
1361       First_Formal : Node_Id;
1362       Formal       : Node_Id;
1363
1364    begin
1365       Body_Spec := Build_Wrapper_Spec (Loc, Proc_Nam, Obj_Typ, Formals);
1366
1367       --  If we did not generate the specification do have nothing else to do
1368
1369       if Body_Spec = Empty then
1370          return Empty;
1371       end if;
1372
1373       --  Map formals to actuals. Use the list built for the wrapper spec,
1374       --  skipping the object notation parameter.
1375
1376       First_Formal := First (Parameter_Specifications (Body_Spec));
1377
1378       Formal := First_Formal;
1379       Next (Formal);
1380
1381       if Present (Formal) then
1382          Actuals := New_List;
1383
1384          while Present (Formal) loop
1385             Append_To (Actuals,
1386               Make_Identifier (Loc, Chars =>
1387                 Chars (Defining_Identifier (Formal))));
1388
1389             Next (Formal);
1390          end loop;
1391       end if;
1392
1393       --  An access-to-variable first parameter will require an explicit
1394       --  dereference in the unchecked conversion. This case occurs when
1395       --  a protected entry wrapper must override an interface-level
1396       --  procedure with interface access as first parameter.
1397
1398       --     SubprgName (O.all).Proc_Nam (Formal_1 .. Formal_N)
1399
1400       if Nkind (Parameter_Type (First_Formal)) = N_Access_Definition then
1401          Conv_Id :=
1402            Make_Explicit_Dereference (Loc,
1403              Prefix =>
1404                Make_Identifier (Loc, Chars => Name_uO));
1405       else
1406          Conv_Id :=
1407            Make_Identifier (Loc, Chars => Name_uO);
1408       end if;
1409
1410       if Ekind (Proc_Nam) = E_Function then
1411          return
1412            Make_Subprogram_Body (Loc,
1413              Specification => Body_Spec,
1414              Declarations  => Empty_List,
1415              Handled_Statement_Sequence =>
1416                Make_Handled_Sequence_Of_Statements (Loc,
1417                  Statements =>
1418                    New_List (
1419                      Make_Simple_Return_Statement (Loc,
1420                         Make_Function_Call (Loc,
1421                           Name =>
1422                             Make_Selected_Component (Loc,
1423                               Prefix =>
1424                                 Unchecked_Convert_To (
1425                                   Corresponding_Concurrent_Type (Obj_Typ),
1426                                   Conv_Id),
1427                               Selector_Name =>
1428                                 New_Reference_To (Proc_Nam, Loc)),
1429                           Parameter_Associations => Actuals)))));
1430       else
1431          return
1432            Make_Subprogram_Body (Loc,
1433              Specification => Body_Spec,
1434              Declarations  => Empty_List,
1435              Handled_Statement_Sequence =>
1436                Make_Handled_Sequence_Of_Statements (Loc,
1437                  Statements =>
1438                    New_List (
1439                      Make_Procedure_Call_Statement (Loc,
1440                        Name =>
1441                          Make_Selected_Component (Loc,
1442                            Prefix =>
1443                              Unchecked_Convert_To (
1444                                Corresponding_Concurrent_Type (Obj_Typ),
1445                                Conv_Id),
1446                            Selector_Name =>
1447                              New_Reference_To (Proc_Nam, Loc)),
1448                        Parameter_Associations => Actuals))));
1449       end if;
1450    end Build_Wrapper_Body;
1451
1452    ------------------------
1453    -- Build_Wrapper_Spec --
1454    ------------------------
1455
1456    function Build_Wrapper_Spec
1457      (Loc      : Source_Ptr;
1458       Proc_Nam : Entity_Id;
1459       Obj_Typ  : Entity_Id;
1460       Formals  : List_Id) return Node_Id
1461    is
1462       New_Name_Id : constant Entity_Id :=
1463                       Make_Defining_Identifier (Loc, Chars (Proc_Nam));
1464
1465       First_Param        : Node_Id := Empty;
1466       Iface              : Entity_Id;
1467       Iface_Elmt         : Elmt_Id := No_Elmt;
1468       New_Formals        : List_Id;
1469       Obj_Param          : Node_Id;
1470       Obj_Param_Typ      : Node_Id;
1471       Iface_Prim_Op      : Entity_Id;
1472       Iface_Prim_Op_Elmt : Elmt_Id;
1473
1474       function Overriding_Possible
1475         (Iface_Prim_Op : Entity_Id;
1476          Proc_Nam      : Entity_Id) return Boolean;
1477       --  Determine whether a primitive operation can be overriden by the
1478       --  wrapper. Iface_Prim_Op is the candidate primitive operation of an
1479       --  abstract interface type, Proc_Nam is the generated entry wrapper.
1480
1481       function Replicate_Entry_Formals
1482         (Loc     : Source_Ptr;
1483          Formals : List_Id) return List_Id;
1484       --  An explicit parameter replication is required due to the
1485       --  Is_Entry_Formal flag being set for all the formals. The explicit
1486       --  replication removes the flag that would otherwise cause a different
1487       --  path of analysis.
1488
1489       -------------------------
1490       -- Overriding_Possible --
1491       -------------------------
1492
1493       function Overriding_Possible
1494         (Iface_Prim_Op : Entity_Id;
1495          Proc_Nam      : Entity_Id) return Boolean
1496       is
1497          Prim_Op_Spec  : constant Node_Id := Parent (Iface_Prim_Op);
1498          Proc_Spec     : constant Node_Id := Parent (Proc_Nam);
1499
1500          Is_Access_To_Variable : Boolean;
1501          Is_Out_Present        : Boolean;
1502
1503          function Type_Conformant_Parameters
1504            (Prim_Op_Param_Specs : List_Id;
1505             Proc_Param_Specs    : List_Id) return Boolean;
1506          --  Determine whether the parameters of the generated entry wrapper
1507          --  and those of a primitive operation are type conformant. During
1508          --  this check, the first parameter of the primitive operation is
1509          --  always skipped.
1510
1511          --------------------------------
1512          -- Type_Conformant_Parameters --
1513          --------------------------------
1514
1515          function Type_Conformant_Parameters
1516            (Prim_Op_Param_Specs : List_Id;
1517             Proc_Param_Specs    : List_Id) return Boolean
1518          is
1519             Prim_Op_Param : Node_Id;
1520             Prim_Op_Typ   : Entity_Id;
1521             Proc_Param    : Node_Id;
1522             Proc_Typ      : Entity_Id;
1523
1524             function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
1525             --  Return the controlling type denoted by a formal parameter
1526
1527             -------------------------
1528             -- Find_Parameter_Type --
1529             -------------------------
1530
1531             function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
1532             begin
1533                if Nkind (Param) /= N_Parameter_Specification then
1534                   return Empty;
1535
1536                elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
1537                   return Etype (Subtype_Mark (Parameter_Type (Param)));
1538
1539                else
1540                   return Etype (Parameter_Type (Param));
1541                end if;
1542             end Find_Parameter_Type;
1543
1544          --  Start of processing for Type_Conformant_Parameters
1545
1546          begin
1547             --  Skip the first parameter of the primitive operation
1548
1549             Prim_Op_Param := Next (First (Prim_Op_Param_Specs));
1550             Proc_Param    := First (Proc_Param_Specs);
1551             while Present (Prim_Op_Param)
1552               and then Present (Proc_Param)
1553             loop
1554                Prim_Op_Typ := Find_Parameter_Type (Prim_Op_Param);
1555                Proc_Typ    := Find_Parameter_Type (Proc_Param);
1556
1557                --  The two parameters must be mode conformant
1558
1559                if not Conforming_Types
1560                         (Prim_Op_Typ, Proc_Typ, Mode_Conformant)
1561                then
1562                   return False;
1563                end if;
1564
1565                Next (Prim_Op_Param);
1566                Next (Proc_Param);
1567             end loop;
1568
1569             --  One of the lists is longer than the other
1570
1571             if Present (Prim_Op_Param) or else Present (Proc_Param) then
1572                return False;
1573             end if;
1574
1575             return True;
1576          end Type_Conformant_Parameters;
1577
1578       --  Start of processing for Overriding_Possible
1579
1580       begin
1581          if Chars (Iface_Prim_Op) /= Chars (Proc_Nam) then
1582             return False;
1583          end if;
1584
1585          --  Special check for protected procedures: If an inherited subprogram
1586          --  is implemented by a protected procedure or an entry, then the
1587          --  first parameter of the inherited subprogram shall be of mode OUT
1588          --  or IN OUT, or an access-to-variable parameter.
1589
1590          if Ekind (Iface_Prim_Op) = E_Procedure then
1591
1592             Is_Out_Present :=
1593               Present (Parameter_Specifications (Prim_Op_Spec))
1594                 and then
1595               Out_Present (First (Parameter_Specifications (Prim_Op_Spec)));
1596
1597             Is_Access_To_Variable :=
1598               Present (Parameter_Specifications (Prim_Op_Spec))
1599                 and then
1600               Nkind (Parameter_Type
1601                      (First
1602                       (Parameter_Specifications (Prim_Op_Spec))))
1603                         = N_Access_Definition;
1604
1605             if not Is_Out_Present
1606               and then not Is_Access_To_Variable
1607             then
1608                return False;
1609             end if;
1610          end if;
1611
1612          return Type_Conformant_Parameters (
1613            Parameter_Specifications (Prim_Op_Spec),
1614            Parameter_Specifications (Proc_Spec));
1615       end Overriding_Possible;
1616
1617       -----------------------------
1618       -- Replicate_Entry_Formals --
1619       -----------------------------
1620
1621       function Replicate_Entry_Formals
1622         (Loc     : Source_Ptr;
1623          Formals : List_Id) return List_Id
1624       is
1625          New_Formals : constant List_Id := New_List;
1626          Formal      : Node_Id;
1627
1628       begin
1629          Formal := First (Formals);
1630          while Present (Formal) loop
1631
1632             --  Create an explicit copy of the entry parameter
1633
1634             Append_To (New_Formals,
1635               Make_Parameter_Specification (Loc,
1636                 Defining_Identifier =>
1637                   Make_Defining_Identifier (Loc,
1638                     Chars          => Chars (Defining_Identifier (Formal))),
1639                     In_Present     => In_Present  (Formal),
1640                     Out_Present    => Out_Present (Formal),
1641                     Parameter_Type => New_Reference_To (Etype (
1642                                         Parameter_Type (Formal)), Loc)));
1643
1644             Next (Formal);
1645          end loop;
1646
1647          return New_Formals;
1648       end Replicate_Entry_Formals;
1649
1650    --  Start of processing for Build_Wrapper_Spec
1651
1652    begin
1653       --  The mode is determined by the first parameter of the interface-level
1654       --  procedure that the current entry is trying to override.
1655
1656       pragma Assert (Is_Non_Empty_List (Abstract_Interface_List (Obj_Typ)));
1657
1658       --  We must examine all the protected operations of the implemented
1659       --  interfaces in order to discover a possible overriding candidate.
1660
1661       Iface := Etype (First (Abstract_Interface_List (Obj_Typ)));
1662
1663       Examine_Parents : loop
1664          if Present (Primitive_Operations (Iface)) then
1665             Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
1666             while Present (Iface_Prim_Op_Elmt) loop
1667                Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
1668
1669                if not Is_Predefined_Dispatching_Operation (Iface_Prim_Op) then
1670                   while Present (Alias (Iface_Prim_Op)) loop
1671                      Iface_Prim_Op := Alias (Iface_Prim_Op);
1672                   end loop;
1673
1674                   --  The current primitive operation can be overriden by the
1675                   --  generated entry wrapper.
1676
1677                   if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
1678                      First_Param := First  (Parameter_Specifications
1679                                              (Parent (Iface_Prim_Op)));
1680
1681                      goto Found;
1682                   end if;
1683                end if;
1684
1685                Next_Elmt (Iface_Prim_Op_Elmt);
1686             end loop;
1687          end if;
1688
1689          exit Examine_Parents when Etype (Iface) = Iface;
1690
1691          Iface := Etype (Iface);
1692       end loop Examine_Parents;
1693
1694       if Present (Abstract_Interfaces
1695                    (Corresponding_Record_Type (Scope (Proc_Nam))))
1696       then
1697          Iface_Elmt := First_Elmt
1698                          (Abstract_Interfaces
1699                            (Corresponding_Record_Type (Scope (Proc_Nam))));
1700          Examine_Interfaces : while Present (Iface_Elmt) loop
1701             Iface := Node (Iface_Elmt);
1702
1703             if Present (Primitive_Operations (Iface)) then
1704                Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
1705                while Present (Iface_Prim_Op_Elmt) loop
1706                   Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
1707
1708                   if not Is_Predefined_Dispatching_Operation
1709                            (Iface_Prim_Op)
1710                   then
1711                      while Present (Alias (Iface_Prim_Op)) loop
1712                         Iface_Prim_Op := Alias (Iface_Prim_Op);
1713                      end loop;
1714
1715                      --  The current primitive operation can be overriden by
1716                      --  the generated entry wrapper.
1717
1718                      if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
1719                         First_Param := First (Parameter_Specifications
1720                                                (Parent (Iface_Prim_Op)));
1721
1722                         goto Found;
1723                      end if;
1724                   end if;
1725
1726                   Next_Elmt (Iface_Prim_Op_Elmt);
1727                end loop;
1728             end if;
1729
1730             Next_Elmt (Iface_Elmt);
1731          end loop Examine_Interfaces;
1732       end if;
1733
1734       --  Return if no interface primitive can be overriden
1735
1736       return Empty;
1737
1738       <<Found>>
1739
1740       New_Formals := Replicate_Entry_Formals (Loc, Formals);
1741
1742       --  ??? Certain source packages contain protected or task types that do
1743       --  not implement any interfaces and are compiled with the -gnat05
1744       --  switch.  In this case, a default first parameter is created.
1745
1746       if Present (First_Param) then
1747          if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
1748             Obj_Param_Typ :=
1749               Make_Access_Definition (Loc,
1750                 Subtype_Mark =>
1751                   New_Reference_To (Obj_Typ, Loc));
1752          else
1753             Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc);
1754          end if;
1755
1756          Obj_Param :=
1757            Make_Parameter_Specification (Loc,
1758              Defining_Identifier =>
1759                Make_Defining_Identifier (Loc, Name_uO),
1760              In_Present  => In_Present  (First_Param),
1761              Out_Present => Out_Present (First_Param),
1762              Parameter_Type => Obj_Param_Typ);
1763
1764       else
1765          Obj_Param :=
1766            Make_Parameter_Specification (Loc,
1767              Defining_Identifier =>
1768                Make_Defining_Identifier (Loc, Name_uO),
1769              In_Present  => True,
1770              Out_Present => True,
1771                Parameter_Type => New_Reference_To (Obj_Typ, Loc));
1772       end if;
1773
1774       Prepend_To (New_Formals, Obj_Param);
1775
1776       --  Minimum decoration needed to catch the entity in
1777       --  Sem_Ch6.Override_Dispatching_Operation
1778
1779       if Ekind (Proc_Nam) = E_Procedure
1780         or else Ekind (Proc_Nam) = E_Entry
1781       then
1782          Set_Ekind                (New_Name_Id, E_Procedure);
1783          Set_Is_Primitive_Wrapper (New_Name_Id);
1784          Set_Wrapped_Entity       (New_Name_Id, Proc_Nam);
1785
1786          return
1787            Make_Procedure_Specification (Loc,
1788              Defining_Unit_Name => New_Name_Id,
1789              Parameter_Specifications => New_Formals);
1790
1791       else pragma Assert (Ekind (Proc_Nam) = E_Function);
1792          Set_Ekind (New_Name_Id, E_Function);
1793
1794          return
1795            Make_Function_Specification (Loc,
1796              Defining_Unit_Name => New_Name_Id,
1797              Parameter_Specifications => New_Formals,
1798              Result_Definition =>
1799                New_Copy (Result_Definition (Parent (Proc_Nam))));
1800       end if;
1801    end Build_Wrapper_Spec;
1802
1803    ---------------------------
1804    -- Build_Find_Body_Index --
1805    ---------------------------
1806
1807    function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
1808       Loc   : constant Source_Ptr := Sloc (Typ);
1809       Ent   : Entity_Id;
1810       E_Typ : Entity_Id;
1811       Has_F : Boolean := False;
1812       Index : Nat;
1813       If_St : Node_Id := Empty;
1814       Lo    : Node_Id;
1815       Hi    : Node_Id;
1816       Decls : List_Id := New_List;
1817       Ret   : Node_Id;
1818       Spec  : Node_Id;
1819       Siz   : Node_Id := Empty;
1820
1821       procedure Add_If_Clause (Expr : Node_Id);
1822       --  Add test for range of current entry
1823
1824       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
1825       --  If a bound of an entry is given by a discriminant, retrieve the
1826       --  actual value of the discriminant from the enclosing object.
1827
1828       -------------------
1829       -- Add_If_Clause --
1830       -------------------
1831
1832       procedure Add_If_Clause (Expr : Node_Id) is
1833          Cond  : Node_Id;
1834          Stats : constant List_Id :=
1835                    New_List (
1836                      Make_Simple_Return_Statement (Loc,
1837                        Expression => Make_Integer_Literal (Loc, Index + 1)));
1838
1839       begin
1840          --  Index for current entry body
1841
1842          Index := Index + 1;
1843
1844          --  Compute total length of entry queues so far
1845
1846          if No (Siz) then
1847             Siz := Expr;
1848          else
1849             Siz :=
1850               Make_Op_Add (Loc,
1851                 Left_Opnd => Siz,
1852                 Right_Opnd => Expr);
1853          end if;
1854
1855          Cond :=
1856            Make_Op_Le (Loc,
1857              Left_Opnd => Make_Identifier (Loc, Name_uE),
1858              Right_Opnd => Siz);
1859
1860          --  Map entry queue indices in the range of the current family
1861          --  into the current index, that designates the entry body.
1862
1863          if No (If_St) then
1864             If_St :=
1865               Make_Implicit_If_Statement (Typ,
1866                 Condition => Cond,
1867                 Then_Statements => Stats,
1868                 Elsif_Parts   => New_List);
1869
1870             Ret := If_St;
1871
1872          else
1873             Append (
1874               Make_Elsif_Part (Loc,
1875                 Condition => Cond,
1876                 Then_Statements => Stats),
1877               Elsif_Parts (If_St));
1878          end if;
1879       end Add_If_Clause;
1880
1881       ------------------------------
1882       -- Convert_Discriminant_Ref --
1883       ------------------------------
1884
1885       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
1886          B   : Node_Id;
1887
1888       begin
1889          if Is_Entity_Name (Bound)
1890            and then Ekind (Entity (Bound)) = E_Discriminant
1891          then
1892             B :=
1893               Make_Selected_Component (Loc,
1894                Prefix =>
1895                  Unchecked_Convert_To (Corresponding_Record_Type (Typ),
1896                    Make_Explicit_Dereference (Loc,
1897                      Make_Identifier (Loc, Name_uObject))),
1898                Selector_Name => Make_Identifier (Loc, Chars (Bound)));
1899             Set_Etype (B, Etype (Entity (Bound)));
1900          else
1901             B := New_Copy_Tree (Bound);
1902          end if;
1903
1904          return B;
1905       end Convert_Discriminant_Ref;
1906
1907    --  Start of processing for Build_Find_Body_Index
1908
1909    begin
1910       Spec := Build_Find_Body_Index_Spec (Typ);
1911
1912       Ent := First_Entity (Typ);
1913       while Present (Ent) loop
1914          if Ekind (Ent) = E_Entry_Family then
1915             Has_F := True;
1916             exit;
1917          end if;
1918
1919          Next_Entity (Ent);
1920       end loop;
1921
1922       if not Has_F then
1923
1924          --  If the protected type has no entry families, there is a one-one
1925          --  correspondence between entry queue and entry body.
1926
1927          Ret :=
1928            Make_Simple_Return_Statement (Loc,
1929              Expression => Make_Identifier (Loc, Name_uE));
1930
1931       else
1932          --  Suppose entries e1, e2, ... have size l1, l2, ... we generate
1933          --  the following:
1934          --
1935          --  if E <= l1 then return 1;
1936          --  elsif E <= l1 + l2 then return 2;
1937          --  ...
1938
1939          Index := 0;
1940          Siz   := Empty;
1941          Ent   := First_Entity (Typ);
1942
1943          Add_Object_Pointer (Decls, Typ, Loc);
1944
1945          while Present (Ent) loop
1946
1947             if Ekind (Ent) = E_Entry then
1948                Add_If_Clause (Make_Integer_Literal (Loc, 1));
1949
1950             elsif Ekind (Ent) = E_Entry_Family then
1951
1952                E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1953                Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
1954                Lo := Convert_Discriminant_Ref (Type_Low_Bound  (E_Typ));
1955                Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
1956             end if;
1957
1958             Next_Entity (Ent);
1959          end loop;
1960
1961          if Index = 1 then
1962             Decls := New_List;
1963             Ret :=
1964               Make_Simple_Return_Statement (Loc,
1965                 Expression => Make_Integer_Literal (Loc, 1));
1966
1967          elsif Nkind (Ret) = N_If_Statement then
1968
1969             --  Ranges are in increasing order, so last one doesn't need guard
1970
1971             declare
1972                Nod : constant Node_Id := Last (Elsif_Parts (Ret));
1973             begin
1974                Remove (Nod);
1975                Set_Else_Statements (Ret, Then_Statements (Nod));
1976             end;
1977          end if;
1978       end if;
1979
1980       return
1981         Make_Subprogram_Body (Loc,
1982           Specification => Spec,
1983           Declarations  => Decls,
1984           Handled_Statement_Sequence =>
1985             Make_Handled_Sequence_Of_Statements (Loc,
1986               Statements => New_List (Ret)));
1987    end Build_Find_Body_Index;
1988
1989    --------------------------------
1990    -- Build_Find_Body_Index_Spec --
1991    --------------------------------
1992
1993    function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
1994       Loc   : constant Source_Ptr := Sloc (Typ);
1995       Id    : constant Entity_Id :=
1996                Make_Defining_Identifier (Loc,
1997                  Chars => New_External_Name (Chars (Typ), 'F'));
1998       Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
1999       Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
2000
2001    begin
2002       return
2003         Make_Function_Specification (Loc,
2004           Defining_Unit_Name => Id,
2005           Parameter_Specifications => New_List (
2006             Make_Parameter_Specification (Loc,
2007               Defining_Identifier => Parm1,
2008               Parameter_Type =>
2009                 New_Reference_To (RTE (RE_Address), Loc)),
2010
2011             Make_Parameter_Specification (Loc,
2012               Defining_Identifier => Parm2,
2013               Parameter_Type =>
2014                 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
2015           Result_Definition => New_Occurrence_Of (
2016             RTE (RE_Protected_Entry_Index), Loc));
2017    end Build_Find_Body_Index_Spec;
2018
2019    -------------------------
2020    -- Build_Master_Entity --
2021    -------------------------
2022
2023    procedure Build_Master_Entity (E : Entity_Id) is
2024       Loc  : constant Source_Ptr := Sloc (E);
2025       P    : Node_Id;
2026       Decl : Node_Id;
2027       S    : Entity_Id;
2028
2029    begin
2030       S := Scope (E);
2031
2032       --  Ada 2005 (AI-287): Do not set/get the has_master_entity reminder
2033       --  in internal scopes, unless present already.. Required for nested
2034       --  limited aggregates. This could use some more explanation ????
2035
2036       if Ada_Version >= Ada_05 then
2037          while Is_Internal (S) loop
2038             S := Scope (S);
2039          end loop;
2040       end if;
2041
2042       --  Nothing to do if we already built a master entity for this scope
2043       --  or if there is no task hierarchy.
2044
2045       if Has_Master_Entity (S)
2046         or else Restriction_Active (No_Task_Hierarchy)
2047       then
2048          return;
2049       end if;
2050
2051       --  Otherwise first build the master entity
2052       --    _Master : constant Master_Id := Current_Master.all;
2053       --  and insert it just before the current declaration
2054
2055       Decl :=
2056         Make_Object_Declaration (Loc,
2057           Defining_Identifier =>
2058             Make_Defining_Identifier (Loc, Name_uMaster),
2059           Constant_Present => True,
2060           Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc),
2061           Expression =>
2062             Make_Explicit_Dereference (Loc,
2063               New_Reference_To (RTE (RE_Current_Master), Loc)));
2064
2065       P := Parent (E);
2066       Insert_Before (P, Decl);
2067       Analyze (Decl);
2068
2069       --  Ada 2005 (AI-287): Set the has_master_entity reminder in the
2070       --  non-internal scope selected above.
2071
2072       if Ada_Version >= Ada_05 then
2073          Set_Has_Master_Entity (S);
2074       else
2075          Set_Has_Master_Entity (Scope (E));
2076       end if;
2077
2078       --  Now mark the containing scope as a task master
2079
2080       while Nkind (P) /= N_Compilation_Unit loop
2081          P := Parent (P);
2082
2083          --  If we fall off the top, we are at the outer level, and the
2084          --  environment task is our effective master, so nothing to mark.
2085
2086          if Nkind (P) = N_Task_Body
2087            or else Nkind (P) = N_Block_Statement
2088            or else Nkind (P) = N_Subprogram_Body
2089          then
2090             Set_Is_Task_Master (P, True);
2091             return;
2092
2093          elsif Nkind (Parent (P)) = N_Subunit then
2094             P := Corresponding_Stub (Parent (P));
2095          end if;
2096       end loop;
2097    end Build_Master_Entity;
2098
2099    ---------------------------
2100    -- Build_Protected_Entry --
2101    ---------------------------
2102
2103    function Build_Protected_Entry
2104      (N   : Node_Id;
2105       Ent : Entity_Id;
2106       Pid : Node_Id) return Node_Id
2107    is
2108       Loc : constant Source_Ptr := Sloc (N);
2109
2110       End_Lab : constant Node_Id :=
2111                   End_Label (Handled_Statement_Sequence (N));
2112       End_Loc : constant Source_Ptr :=
2113                   Sloc (Last (Statements (Handled_Statement_Sequence (N))));
2114       --  Used for the generated call to Complete_Entry_Body
2115
2116       Han_Loc : Source_Ptr;
2117       --  Used for the exception handler, inserted at end of the body
2118
2119       Op_Decls : constant List_Id    := New_List;
2120       Edef     : Entity_Id;
2121       Espec    : Node_Id;
2122       Op_Stats : List_Id;
2123       Ohandle  : Node_Id;
2124       Complete : Node_Id;
2125
2126    begin
2127       --  Set the source location on the exception handler only when debugging
2128       --  the expanded code (see Make_Implicit_Exception_Handler).
2129
2130       if Debug_Generated_Code then
2131          Han_Loc := End_Loc;
2132
2133       --  Otherwise the inserted code should not be visible to the debugger
2134
2135       else
2136          Han_Loc := No_Location;
2137       end if;
2138
2139       Edef :=
2140         Make_Defining_Identifier (Loc,
2141           Chars => Chars (Protected_Body_Subprogram (Ent)));
2142       Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc);
2143
2144       --  <object pointer declaration>
2145
2146       --  Add object pointer declaration. This is needed by the discriminal and
2147       --  prival renamings, which should already have been inserted into the
2148       --  declaration list.
2149
2150       Add_Object_Pointer (Op_Decls, Pid, Loc);
2151
2152       --  Add renamings for formals for use by debugger
2153
2154       Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc);
2155
2156       if Abort_Allowed
2157         or else Restriction_Active (No_Entry_Queue) = False
2158         or else Number_Entries (Pid) > 1
2159         or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
2160       then
2161          Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
2162       else
2163          Complete :=
2164            New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc);
2165       end if;
2166
2167       Op_Stats := New_List (
2168          Make_Block_Statement (Loc,
2169            Declarations => Declarations (N),
2170            Handled_Statement_Sequence =>
2171              Handled_Statement_Sequence (N)),
2172
2173          Make_Procedure_Call_Statement (End_Loc,
2174            Name => Complete,
2175            Parameter_Associations => New_List (
2176              Make_Attribute_Reference (End_Loc,
2177                Prefix =>
2178                  Make_Selected_Component (End_Loc,
2179                    Prefix =>
2180                      Make_Identifier (End_Loc, Name_uObject),
2181
2182                    Selector_Name =>
2183                      Make_Identifier (End_Loc, Name_uObject)),
2184               Attribute_Name => Name_Unchecked_Access))));
2185
2186       --  When exceptions can not be propagated, we never need to call
2187       --  Exception_Complete_Entry_Body
2188
2189       if No_Exception_Handlers_Set then
2190          return
2191            Make_Subprogram_Body (Loc,
2192              Specification => Espec,
2193              Declarations => Op_Decls,
2194              Handled_Statement_Sequence =>
2195                Make_Handled_Sequence_Of_Statements (Loc,
2196                Op_Stats,
2197                End_Label => End_Lab));
2198
2199       else
2200          Ohandle := Make_Others_Choice (Loc);
2201          Set_All_Others (Ohandle);
2202
2203          if Abort_Allowed
2204            or else Restriction_Active (No_Entry_Queue) = False
2205            or else Number_Entries (Pid) > 1
2206            or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
2207          then
2208             Complete :=
2209               New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
2210
2211          else
2212             Complete := New_Reference_To (
2213               RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
2214          end if;
2215
2216          --  Create body of entry procedure. The renaming declarations are
2217          --  placed ahead of the block that contains the actual entry body.
2218
2219          return
2220            Make_Subprogram_Body (Loc,
2221              Specification => Espec,
2222              Declarations => Op_Decls,
2223              Handled_Statement_Sequence =>
2224                Make_Handled_Sequence_Of_Statements (Loc,
2225                  Statements => Op_Stats,
2226                  End_Label  => End_Lab,
2227                  Exception_Handlers => New_List (
2228                    Make_Implicit_Exception_Handler (Han_Loc,
2229                      Exception_Choices => New_List (Ohandle),
2230
2231                      Statements =>  New_List (
2232                        Make_Procedure_Call_Statement (Han_Loc,
2233                          Name => Complete,
2234                          Parameter_Associations => New_List (
2235                            Make_Attribute_Reference (Han_Loc,
2236                              Prefix =>
2237                                Make_Selected_Component (Han_Loc,
2238                                  Prefix =>
2239                                    Make_Identifier (Han_Loc, Name_uObject),
2240                                  Selector_Name =>
2241                                    Make_Identifier (Han_Loc, Name_uObject)),
2242                                Attribute_Name => Name_Unchecked_Access),
2243
2244                            Make_Function_Call (Han_Loc,
2245                              Name => New_Reference_To (
2246                                RTE (RE_Get_GNAT_Exception), Loc)))))))));
2247       end if;
2248    end Build_Protected_Entry;
2249
2250    -----------------------------------------
2251    -- Build_Protected_Entry_Specification --
2252    -----------------------------------------
2253
2254    function Build_Protected_Entry_Specification
2255      (Def_Id : Entity_Id;
2256       Ent_Id : Entity_Id;
2257       Loc    : Source_Ptr) return Node_Id
2258    is
2259       P : Entity_Id;
2260
2261    begin
2262       Set_Needs_Debug_Info (Def_Id);
2263       P := Make_Defining_Identifier (Loc, Name_uP);
2264
2265       if Present (Ent_Id) then
2266          Append_Elmt (P, Accept_Address (Ent_Id));
2267       end if;
2268
2269       return Make_Procedure_Specification (Loc,
2270         Defining_Unit_Name => Def_Id,
2271         Parameter_Specifications => New_List (
2272           Make_Parameter_Specification (Loc,
2273             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
2274             Parameter_Type =>
2275               New_Reference_To (RTE (RE_Address), Loc)),
2276
2277           Make_Parameter_Specification (Loc,
2278             Defining_Identifier => P,
2279             Parameter_Type =>
2280               New_Reference_To (RTE (RE_Address), Loc)),
2281
2282           Make_Parameter_Specification (Loc,
2283             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
2284             Parameter_Type =>
2285               New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))));
2286    end Build_Protected_Entry_Specification;
2287
2288    --------------------------
2289    -- Build_Protected_Spec --
2290    --------------------------
2291
2292    function Build_Protected_Spec
2293      (N           : Node_Id;
2294       Obj_Type    : Entity_Id;
2295       Unprotected : Boolean := False;
2296       Ident       : Entity_Id) return List_Id
2297    is
2298       Loc         : constant Source_Ptr := Sloc (N);
2299       Decl        : Node_Id;
2300       Formal      : Entity_Id;
2301       New_Plist   : List_Id;
2302       New_Param   : Node_Id;
2303
2304    begin
2305       New_Plist := New_List;
2306       Formal := First_Formal (Ident);
2307       while Present (Formal) loop
2308          New_Param :=
2309            Make_Parameter_Specification (Loc,
2310              Defining_Identifier =>
2311                Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
2312              In_Present => In_Present (Parent (Formal)),
2313              Out_Present => Out_Present (Parent (Formal)),
2314              Parameter_Type =>
2315                New_Reference_To (Etype (Formal), Loc));
2316
2317          if Unprotected then
2318             Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
2319          end if;
2320
2321          Append (New_Param, New_Plist);
2322          Next_Formal (Formal);
2323       end loop;
2324
2325       --  If the subprogram is a procedure and the context is not an access
2326       --  to protected subprogram, the parameter is in-out. Otherwise it is
2327       --  an in parameter.
2328
2329       Decl :=
2330         Make_Parameter_Specification (Loc,
2331           Defining_Identifier =>
2332             Make_Defining_Identifier (Loc, Name_uObject),
2333           In_Present => True,
2334           Out_Present =>
2335            (Etype (Ident) = Standard_Void_Type
2336               and then not Is_RTE (Obj_Type, RE_Address)),
2337           Parameter_Type => New_Reference_To (Obj_Type, Loc));
2338       Set_Needs_Debug_Info (Defining_Identifier (Decl));
2339       Prepend_To (New_Plist, Decl);
2340
2341       return New_Plist;
2342    end Build_Protected_Spec;
2343
2344    ---------------------------------------
2345    -- Build_Protected_Sub_Specification --
2346    ---------------------------------------
2347
2348    function Build_Protected_Sub_Specification
2349      (N       : Node_Id;
2350       Prottyp : Entity_Id;
2351       Mode    : Subprogram_Protection_Mode) return Node_Id
2352    is
2353       Loc       : constant Source_Ptr := Sloc (N);
2354       Decl      : Node_Id;
2355       Ident     : Entity_Id;
2356       New_Id    : Entity_Id;
2357       New_Plist : List_Id;
2358       New_Spec  : Node_Id;
2359
2360       Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
2361                      (Dispatching_Mode => ' ',
2362                       Protected_Mode   => 'P',
2363                       Unprotected_Mode => 'N');
2364
2365    begin
2366       if Ekind
2367          (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
2368       then
2369          Decl := Unit_Declaration_Node (Corresponding_Spec (N));
2370       else
2371          Decl := N;
2372       end if;
2373
2374       Ident := Defining_Unit_Name (Specification (Decl));
2375
2376       New_Plist :=
2377         Build_Protected_Spec (Decl,
2378           Corresponding_Record_Type (Prottyp),
2379                               Mode = Unprotected_Mode, Ident);
2380
2381       New_Id :=
2382         Make_Defining_Identifier (Loc,
2383           Chars => Build_Selected_Name (Prottyp, Ident, Append_Chr (Mode)));
2384
2385       --  The unprotected operation carries the user code, and debugging
2386       --  information must be generated for it, even though this spec does
2387       --  not come from source. It is also convenient to allow gdb to step
2388       --  into the protected operation, even though it only contains lock/
2389       --  unlock calls.
2390
2391       Set_Needs_Debug_Info (New_Id);
2392
2393       if Nkind (Specification (Decl)) = N_Procedure_Specification then
2394          return
2395            Make_Procedure_Specification (Loc,
2396              Defining_Unit_Name => New_Id,
2397              Parameter_Specifications => New_Plist);
2398
2399       else
2400          --  We need to create a new specification for the anonymous
2401          --  subprogram type.
2402
2403          New_Spec :=
2404            Make_Function_Specification (Loc,
2405              Defining_Unit_Name => New_Id,
2406              Parameter_Specifications => New_Plist,
2407              Result_Definition =>
2408                Copy_Result_Type (Result_Definition (Specification (Decl))));
2409
2410          Set_Return_Present (Defining_Unit_Name (New_Spec));
2411          return New_Spec;
2412       end if;
2413    end Build_Protected_Sub_Specification;
2414
2415    -------------------------------------
2416    -- Build_Protected_Subprogram_Body --
2417    -------------------------------------
2418
2419    function Build_Protected_Subprogram_Body
2420      (N         : Node_Id;
2421       Pid       : Node_Id;
2422       N_Op_Spec : Node_Id) return Node_Id
2423    is
2424       Loc          : constant Source_Ptr := Sloc (N);
2425       Op_Spec      : Node_Id;
2426       P_Op_Spec    : Node_Id;
2427       Uactuals     : List_Id;
2428       Pformal      : Node_Id;
2429       Unprot_Call  : Node_Id;
2430       Sub_Body     : Node_Id;
2431       Lock_Name    : Node_Id;
2432       Lock_Stmt    : Node_Id;
2433       Service_Name : Node_Id;
2434       R            : Node_Id;
2435       Return_Stmt  : Node_Id := Empty;    -- init to avoid gcc 3 warning
2436       Pre_Stmts    : List_Id := No_List;  -- init to avoid gcc 3 warning
2437       Stmts        : List_Id;
2438       Object_Parm  : Node_Id;
2439       Exc_Safe     : Boolean;
2440
2441       function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
2442       --  Tell whether a given subprogram cannot raise an exception
2443
2444       -----------------------
2445       -- Is_Exception_Safe --
2446       -----------------------
2447
2448       function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
2449
2450          function Has_Side_Effect (N : Node_Id) return Boolean;
2451          --  Return True whenever encountering a subprogram call or raise
2452          --  statement of any kind in the sequence of statements
2453
2454          ---------------------
2455          -- Has_Side_Effect --
2456          ---------------------
2457
2458          --  What is this doing buried two levels down in exp_ch9. It seems
2459          --  like a generally useful function, and indeed there may be code
2460          --  duplication going on here ???
2461
2462          function Has_Side_Effect (N : Node_Id) return Boolean is
2463             Stmt : Node_Id;
2464             Expr : Node_Id;
2465
2466             function Is_Call_Or_Raise (N : Node_Id) return Boolean;
2467             --  Indicate whether N is a subprogram call or a raise statement
2468
2469             ----------------------
2470             -- Is_Call_Or_Raise --
2471             ----------------------
2472
2473             function Is_Call_Or_Raise (N : Node_Id) return Boolean is
2474             begin
2475                return Nkind (N) = N_Procedure_Call_Statement
2476                  or else Nkind (N) = N_Function_Call
2477                  or else Nkind (N) = N_Raise_Statement
2478                  or else Nkind (N) = N_Raise_Constraint_Error
2479                  or else Nkind (N) = N_Raise_Program_Error
2480                  or else Nkind (N) = N_Raise_Storage_Error;
2481             end Is_Call_Or_Raise;
2482
2483          --  Start of processing for Has_Side_Effect
2484
2485          begin
2486             Stmt := N;
2487             while Present (Stmt) loop
2488                if Is_Call_Or_Raise (Stmt) then
2489                   return True;
2490                end if;
2491
2492                --  An object declaration can also contain a function call
2493                --  or a raise statement
2494
2495                if Nkind (Stmt) = N_Object_Declaration then
2496                   Expr := Expression (Stmt);
2497
2498                   if Present (Expr) and then Is_Call_Or_Raise (Expr) then
2499                      return True;
2500                   end if;
2501                end if;
2502
2503                Next (Stmt);
2504             end loop;
2505
2506             return False;
2507          end Has_Side_Effect;
2508
2509       --  Start of processing for Is_Exception_Safe
2510
2511       begin
2512          --  If the checks handled by the back end are not disabled, we cannot
2513          --  ensure that no exception will be raised.
2514
2515          if not Access_Checks_Suppressed (Empty)
2516            or else not Discriminant_Checks_Suppressed (Empty)
2517            or else not Range_Checks_Suppressed (Empty)
2518            or else not Index_Checks_Suppressed (Empty)
2519            or else Opt.Stack_Checking_Enabled
2520          then
2521             return False;
2522          end if;
2523
2524          if Has_Side_Effect (First (Declarations (Subprogram)))
2525            or else
2526               Has_Side_Effect (
2527                 First (Statements (Handled_Statement_Sequence (Subprogram))))
2528          then
2529             return False;
2530          else
2531             return True;
2532          end if;
2533       end Is_Exception_Safe;
2534
2535    --  Start of processing for Build_Protected_Subprogram_Body
2536
2537    begin
2538       Op_Spec := Specification (N);
2539       Exc_Safe := Is_Exception_Safe (N);
2540
2541       P_Op_Spec :=
2542         Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
2543
2544       --  Build a list of the formal parameters of the protected version of
2545       --  the subprogram to use as the actual parameters of the unprotected
2546       --  version.
2547
2548       Uactuals := New_List;
2549       Pformal := First (Parameter_Specifications (P_Op_Spec));
2550       while Present (Pformal) loop
2551          Append (
2552            Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))),
2553            Uactuals);
2554          Next (Pformal);
2555       end loop;
2556
2557       --  Make a call to the unprotected version of the subprogram built above
2558       --  for use by the protected version built below.
2559
2560       if Nkind (Op_Spec) = N_Function_Specification then
2561          if Exc_Safe then
2562             R := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2563             Unprot_Call :=
2564               Make_Object_Declaration (Loc,
2565                 Defining_Identifier => R,
2566                 Constant_Present => True,
2567                 Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
2568                 Expression =>
2569                   Make_Function_Call (Loc,
2570                     Name => Make_Identifier (Loc,
2571                       Chars (Defining_Unit_Name (N_Op_Spec))),
2572                     Parameter_Associations => Uactuals));
2573             Return_Stmt := Make_Simple_Return_Statement (Loc,
2574               Expression => New_Reference_To (R, Loc));
2575
2576          else
2577             Unprot_Call := Make_Simple_Return_Statement (Loc,
2578               Expression => Make_Function_Call (Loc,
2579                 Name =>
2580                   Make_Identifier (Loc,
2581                     Chars (Defining_Unit_Name (N_Op_Spec))),
2582                 Parameter_Associations => Uactuals));
2583          end if;
2584
2585       else
2586          Unprot_Call := Make_Procedure_Call_Statement (Loc,
2587            Name =>
2588              Make_Identifier (Loc,
2589                Chars (Defining_Unit_Name (N_Op_Spec))),
2590            Parameter_Associations => Uactuals);
2591       end if;
2592
2593       --  Wrap call in block that will be covered by an at_end handler
2594
2595       if not Exc_Safe then
2596          Unprot_Call := Make_Block_Statement (Loc,
2597            Handled_Statement_Sequence =>
2598              Make_Handled_Sequence_Of_Statements (Loc,
2599                Statements => New_List (Unprot_Call)));
2600       end if;
2601
2602       --  Make the protected subprogram body. This locks the protected
2603       --  object and calls the unprotected version of the subprogram.
2604
2605       --  If the protected object is controlled (i.e it has entries or
2606       --  needs finalization for interrupt handling), call Lock_Entries,
2607       --  except if the protected object follows the Ravenscar profile, in
2608       --  which case call Lock_Entry, otherwise call the simplified version,
2609       --  Lock.
2610
2611       if Has_Entries (Pid)
2612         or else Has_Interrupt_Handler (Pid)
2613         or else (Has_Attach_Handler (Pid)
2614                   and then not Restricted_Profile)
2615         or else (Ada_Version >= Ada_05
2616                   and then Present (Interface_List (Parent (Pid))))
2617       then
2618          if Abort_Allowed
2619            or else Restriction_Active (No_Entry_Queue) = False
2620            or else Number_Entries (Pid) > 1
2621            or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
2622          then
2623             Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
2624             Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
2625
2626          else
2627             Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc);
2628             Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
2629          end if;
2630
2631       else
2632          Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
2633          Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
2634       end if;
2635
2636       Object_Parm :=
2637         Make_Attribute_Reference (Loc,
2638            Prefix =>
2639              Make_Selected_Component (Loc,
2640                Prefix =>
2641                  Make_Identifier (Loc, Name_uObject),
2642              Selector_Name =>
2643                  Make_Identifier (Loc, Name_uObject)),
2644            Attribute_Name => Name_Unchecked_Access);
2645
2646       Lock_Stmt := Make_Procedure_Call_Statement (Loc,
2647         Name => Lock_Name,
2648         Parameter_Associations => New_List (Object_Parm));
2649
2650       if Abort_Allowed then
2651          Stmts := New_List (
2652            Make_Procedure_Call_Statement (Loc,
2653              Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
2654              Parameter_Associations => Empty_List),
2655            Lock_Stmt);
2656
2657       else
2658          Stmts := New_List (Lock_Stmt);
2659       end if;
2660
2661       if not Exc_Safe then
2662          Append (Unprot_Call, Stmts);
2663       else
2664          if Nkind (Op_Spec) = N_Function_Specification then
2665             Pre_Stmts := Stmts;
2666             Stmts     := Empty_List;
2667          else
2668             Append (Unprot_Call, Stmts);
2669          end if;
2670
2671          Append (
2672            Make_Procedure_Call_Statement (Loc,
2673              Name => Service_Name,
2674              Parameter_Associations =>
2675                New_List (New_Copy_Tree (Object_Parm))),
2676            Stmts);
2677
2678          if Abort_Allowed then
2679             Append (
2680               Make_Procedure_Call_Statement (Loc,
2681                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
2682                 Parameter_Associations => Empty_List),
2683               Stmts);
2684          end if;
2685
2686          if Nkind (Op_Spec) = N_Function_Specification then
2687             Append (Return_Stmt, Stmts);
2688             Append (Make_Block_Statement (Loc,
2689               Declarations => New_List (Unprot_Call),
2690               Handled_Statement_Sequence =>
2691                 Make_Handled_Sequence_Of_Statements (Loc,
2692                   Statements => Stmts)), Pre_Stmts);
2693             Stmts := Pre_Stmts;
2694          end if;
2695       end if;
2696
2697       Sub_Body :=
2698         Make_Subprogram_Body (Loc,
2699           Declarations => Empty_List,
2700           Specification => P_Op_Spec,
2701           Handled_Statement_Sequence =>
2702             Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
2703
2704       if not Exc_Safe then
2705          Set_Is_Protected_Subprogram_Body (Sub_Body);
2706       end if;
2707
2708       return Sub_Body;
2709    end Build_Protected_Subprogram_Body;
2710
2711    -------------------------------------
2712    -- Build_Protected_Subprogram_Call --
2713    -------------------------------------
2714
2715    procedure Build_Protected_Subprogram_Call
2716      (N        : Node_Id;
2717       Name     : Node_Id;
2718       Rec      : Node_Id;
2719       External : Boolean := True)
2720    is
2721       Loc     : constant Source_Ptr := Sloc (N);
2722       Sub     : constant Entity_Id  := Entity (Name);
2723       New_Sub : Node_Id;
2724       Params  : List_Id;
2725
2726    begin
2727       if External then
2728          New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
2729       else
2730          New_Sub :=
2731            New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
2732       end if;
2733
2734       if Present (Parameter_Associations (N)) then
2735          Params := New_Copy_List_Tree (Parameter_Associations (N));
2736       else
2737          Params := New_List;
2738       end if;
2739
2740       Prepend (Rec, Params);
2741
2742       if Ekind (Sub) = E_Procedure then
2743          Rewrite (N,
2744            Make_Procedure_Call_Statement (Loc,
2745              Name => New_Sub,
2746              Parameter_Associations => Params));
2747
2748       else
2749          pragma Assert (Ekind (Sub) = E_Function);
2750          Rewrite (N,
2751            Make_Function_Call (Loc,
2752              Name => New_Sub,
2753              Parameter_Associations => Params));
2754       end if;
2755
2756       if External
2757         and then Nkind (Rec) = N_Unchecked_Type_Conversion
2758         and then Is_Entity_Name (Expression (Rec))
2759         and then Is_Shared_Passive (Entity (Expression (Rec)))
2760       then
2761          Add_Shared_Var_Lock_Procs (N);
2762       end if;
2763    end Build_Protected_Subprogram_Call;
2764
2765    -------------------------
2766    -- Build_Selected_Name --
2767    -------------------------
2768
2769    function Build_Selected_Name
2770      (Prefix      : Entity_Id;
2771       Selector    : Entity_Id;
2772       Append_Char : Character := ' ') return Name_Id
2773    is
2774       Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
2775       Select_Len    : Natural;
2776
2777    begin
2778       Get_Name_String (Chars (Selector));
2779       Select_Len := Name_Len;
2780       Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
2781       Get_Name_String (Chars (Prefix));
2782
2783       --  If scope is anonymous type, discard suffix to recover name of
2784       --  single protected object. Otherwise use protected type name.
2785
2786       if Name_Buffer (Name_Len) = 'T' then
2787          Name_Len := Name_Len - 1;
2788       end if;
2789
2790       Name_Buffer (Name_Len + 1) := '_';
2791       Name_Buffer (Name_Len + 2) := '_';
2792
2793       Name_Len := Name_Len + 2;
2794       for J in 1 .. Select_Len loop
2795          Name_Len := Name_Len + 1;
2796          Name_Buffer (Name_Len) := Select_Buffer (J);
2797       end loop;
2798
2799       --  Now add the Append_Char if specified. The encoding to follow
2800       --  depends on the type of entity. If Append_Char is either 'N' or 'P',
2801       --  then the entity is associated to a protected type subprogram.
2802       --  Otherwise, it is a protected type entry. For each case, the
2803       --  encoding to follow for the suffix is documented in exp_dbug.ads.
2804
2805       --  It would be better to encapsulate this as a routine in Exp_Dbug ???
2806
2807       if Append_Char /= ' ' then
2808          if Append_Char = 'P' or Append_Char = 'N' then
2809             Name_Len := Name_Len + 1;
2810             Name_Buffer (Name_Len) := Append_Char;
2811             return Name_Find;
2812          else
2813             Name_Buffer (Name_Len + 1) := '_';
2814             Name_Buffer (Name_Len + 2) := Append_Char;
2815             Name_Len := Name_Len + 2;
2816             return New_External_Name (Name_Find, ' ', -1);
2817          end if;
2818       else
2819          return Name_Find;
2820       end if;
2821    end Build_Selected_Name;
2822
2823    -----------------------------
2824    -- Build_Simple_Entry_Call --
2825    -----------------------------
2826
2827    --  A task entry call is converted to a call to Call_Simple
2828
2829    --    declare
2830    --       P : parms := (parm, parm, parm);
2831    --    begin
2832    --       Call_Simple (acceptor-task, entry-index, P'Address);
2833    --       parm := P.param;
2834    --       parm := P.param;
2835    --       ...
2836    --    end;
2837
2838    --  Here Pnn is an aggregate of the type constructed for the entry to hold
2839    --  the parameters, and the constructed aggregate value contains either the
2840    --  parameters or, in the case of non-elementary types, references to these
2841    --  parameters. Then the address of this aggregate is passed to the runtime
2842    --  routine, along with the task id value and the task entry index value.
2843    --  Pnn is only required if parameters are present.
2844
2845    --  The assignments after the call are present only in the case of in-out
2846    --  or out parameters for elementary types, and are used to assign back the
2847    --  resulting values of such parameters.
2848
2849    --  Note: the reason that we insert a block here is that in the context
2850    --  of selects, conditional entry calls etc. the entry call statement
2851    --  appears on its own, not as an element of a list.
2852
2853    --  A protected entry call is converted to a Protected_Entry_Call:
2854
2855    --  declare
2856    --     P   : E1_Params := (param, param, param);
2857    --     Pnn : Boolean;
2858    --     Bnn : Communications_Block;
2859
2860    --  declare
2861    --     P   : E1_Params := (param, param, param);
2862    --     Bnn : Communications_Block;
2863
2864    --  begin
2865    --     Protected_Entry_Call (
2866    --       Object => po._object'Access,
2867    --       E => <entry index>;
2868    --       Uninterpreted_Data => P'Address;
2869    --       Mode => Simple_Call;
2870    --       Block => Bnn);
2871    --     parm := P.param;
2872    --     parm := P.param;
2873    --       ...
2874    --  end;
2875
2876    procedure Build_Simple_Entry_Call
2877      (N       : Node_Id;
2878       Concval : Node_Id;
2879       Ename   : Node_Id;
2880       Index   : Node_Id)
2881    is
2882    begin
2883       Expand_Call (N);
2884
2885       --  If call has been inlined, nothing left to do
2886
2887       if Nkind (N) = N_Block_Statement then
2888          return;
2889       end if;
2890
2891       --  Convert entry call to Call_Simple call
2892
2893       declare
2894          Loc       : constant Source_Ptr := Sloc (N);
2895          Parms     : constant List_Id    := Parameter_Associations (N);
2896          Stats     : constant List_Id    := New_List;
2897          Actual    : Node_Id;
2898          Call      : Node_Id;
2899          Comm_Name : Entity_Id;
2900          Conctyp   : Node_Id;
2901          Decls     : List_Id;
2902          Ent       : Entity_Id;
2903          Ent_Acc   : Entity_Id;
2904          Formal    : Node_Id;
2905          Iface_Tag : Entity_Id;
2906          Iface_Typ : Entity_Id;
2907          N_Node    : Node_Id;
2908          N_Var     : Node_Id;
2909          P         : Entity_Id;
2910          Parm1     : Node_Id;
2911          Parm2     : Node_Id;
2912          Parm3     : Node_Id;
2913          Pdecl     : Node_Id;
2914          Plist     : List_Id;
2915          X         : Entity_Id;
2916          Xdecl     : Node_Id;
2917
2918       begin
2919          --  Simple entry and entry family cases merge here
2920
2921          Ent     := Entity (Ename);
2922          Ent_Acc := Entry_Parameters_Type (Ent);
2923          Conctyp := Etype (Concval);
2924
2925          --  If prefix is an access type, dereference to obtain the task type
2926
2927          if Is_Access_Type (Conctyp) then
2928             Conctyp := Designated_Type (Conctyp);
2929          end if;
2930
2931          --  Special case for protected subprogram calls
2932
2933          if Is_Protected_Type (Conctyp)
2934            and then Is_Subprogram (Entity (Ename))
2935          then
2936             if not Is_Eliminated (Entity (Ename)) then
2937                Build_Protected_Subprogram_Call
2938                  (N, Ename, Convert_Concurrent (Concval, Conctyp));
2939                Analyze (N);
2940             end if;
2941
2942             return;
2943          end if;
2944
2945          --  First parameter is the Task_Id value from the task value or the
2946          --  Object from the protected object value, obtained by selecting
2947          --  the _Task_Id or _Object from the result of doing an unchecked
2948          --  conversion to convert the value to the corresponding record type.
2949
2950          Parm1 := Concurrent_Ref (Concval);
2951
2952          --  Second parameter is the entry index, computed by the routine
2953          --  provided for this purpose. The value of this expression is
2954          --  assigned to an intermediate variable to assure that any entry
2955          --  family index expressions are evaluated before the entry
2956          --  parameters.
2957
2958          if Abort_Allowed
2959            or else Restriction_Active (No_Entry_Queue) = False
2960            or else not Is_Protected_Type (Conctyp)
2961            or else Number_Entries (Conctyp) > 1
2962            or else (Has_Attach_Handler (Conctyp)
2963                      and then not Restricted_Profile)
2964          then
2965             X := Make_Defining_Identifier (Loc, Name_uX);
2966
2967             Xdecl :=
2968               Make_Object_Declaration (Loc,
2969                 Defining_Identifier => X,
2970                 Object_Definition =>
2971                   New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2972                 Expression => Actual_Index_Expression (
2973                   Loc, Entity (Ename), Index, Concval));
2974
2975             Decls := New_List (Xdecl);
2976             Parm2 := New_Reference_To (X, Loc);
2977
2978          else
2979             Xdecl := Empty;
2980             Decls := New_List;
2981             Parm2 := Empty;
2982          end if;
2983
2984          --  The third parameter is the packaged parameters. If there are
2985          --  none, then it is just the null address, since nothing is passed.
2986
2987          if No (Parms) then
2988             Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc);
2989             P := Empty;
2990
2991          --  Case of parameters present, where third argument is the address
2992          --  of a packaged record containing the required parameter values.
2993
2994          else
2995             --  First build a list of parameter values, which are references to
2996             --  objects of the parameter types.
2997
2998             Plist := New_List;
2999
3000             Actual := First_Actual (N);
3001             Formal := First_Formal (Ent);
3002
3003             while Present (Actual) loop
3004
3005                --  If it is a by_copy_type, copy it to a new variable. The
3006                --  packaged record has a field that points to this variable.
3007
3008                if Is_By_Copy_Type (Etype (Actual)) then
3009                   N_Node :=
3010                     Make_Object_Declaration (Loc,
3011                       Defining_Identifier =>
3012                         Make_Defining_Identifier (Loc,
3013                           Chars => New_Internal_Name ('J')),
3014                       Aliased_Present => True,
3015                       Object_Definition =>
3016                         New_Reference_To (Etype (Formal), Loc));
3017
3018                   --  Mark the object as not needing initialization since the
3019                   --  initialization is performed separately, avoiding errors
3020                   --  on cases such as formals of null-excluding access types.
3021
3022                   Set_No_Initialization (N_Node);
3023
3024                   --  We have to make an assignment statement separate for the
3025                   --  case of limited type. We cannot assign it unless the
3026                   --  Assignment_OK flag is set first.
3027                   --  An out formal of an access type must also be initialized
3028                   --  from the actual, as stated in RM 6.4.1 (13).
3029
3030                   if Ekind (Formal) /= E_Out_Parameter
3031                     or else Is_Access_Type (Etype (Formal))
3032                   then
3033                      N_Var :=
3034                        New_Reference_To (Defining_Identifier (N_Node), Loc);
3035                      Set_Assignment_OK (N_Var);
3036                      Append_To (Stats,
3037                        Make_Assignment_Statement (Loc,
3038                          Name => N_Var,
3039                          Expression => Relocate_Node (Actual)));
3040                   end if;
3041
3042                   Append (N_Node, Decls);
3043
3044                   Append_To (Plist,
3045                     Make_Attribute_Reference (Loc,
3046                       Attribute_Name => Name_Unchecked_Access,
3047                     Prefix =>
3048                       New_Reference_To (Defining_Identifier (N_Node), Loc)));
3049                else
3050                   --  Interface class-wide formal
3051
3052                   if Ada_Version >= Ada_05
3053                     and then Ekind (Etype (Formal)) = E_Class_Wide_Type
3054                     and then Is_Interface (Etype (Formal))
3055                   then
3056                      Iface_Typ := Etype (Etype (Formal));
3057
3058                      --  Generate:
3059                      --    formal_iface_type! (actual.iface_tag)'reference
3060
3061                      Iface_Tag :=
3062                        Find_Interface_Tag (Etype (Actual), Iface_Typ);
3063                      pragma Assert (Present (Iface_Tag));
3064
3065                      Append_To (Plist,
3066                        Make_Reference (Loc,
3067                          Unchecked_Convert_To (Iface_Typ,
3068                            Make_Selected_Component (Loc,
3069                              Prefix =>
3070                                Relocate_Node (Actual),
3071                              Selector_Name =>
3072                                New_Reference_To (Iface_Tag, Loc)))));
3073                   else
3074                      --  Generate:
3075                      --    actual'reference
3076
3077                      Append_To (Plist,
3078                        Make_Reference (Loc, Relocate_Node (Actual)));
3079                   end if;
3080                end if;
3081
3082                Next_Actual (Actual);
3083                Next_Formal_With_Extras (Formal);
3084             end loop;
3085
3086             --  Now build the declaration of parameters initialized with the
3087             --  aggregate containing this constructed parameter list.
3088
3089             P := Make_Defining_Identifier (Loc, Name_uP);
3090
3091             Pdecl :=
3092               Make_Object_Declaration (Loc,
3093                 Defining_Identifier => P,
3094                 Object_Definition =>
3095                   New_Reference_To (Designated_Type (Ent_Acc), Loc),
3096                 Expression =>
3097                   Make_Aggregate (Loc, Expressions => Plist));
3098
3099             Parm3 :=
3100               Make_Attribute_Reference (Loc,
3101                 Attribute_Name => Name_Address,
3102                 Prefix => New_Reference_To (P, Loc));
3103
3104             Append (Pdecl, Decls);
3105          end if;
3106
3107          --  Now we can create the call, case of protected type
3108
3109          if Is_Protected_Type (Conctyp) then
3110             if Abort_Allowed
3111               or else Restriction_Active (No_Entry_Queue) = False
3112               or else Number_Entries (Conctyp) > 1
3113               or else (Has_Attach_Handler (Conctyp)
3114                         and then not Restricted_Profile)
3115             then
3116                --  Change the type of the index declaration
3117
3118                Set_Object_Definition (Xdecl,
3119                  New_Reference_To (RTE (RE_Protected_Entry_Index), Loc));
3120
3121                --  Some additional declarations for protected entry calls
3122
3123                if No (Decls) then
3124                   Decls := New_List;
3125                end if;
3126
3127                --  Bnn : Communications_Block;
3128
3129                Comm_Name :=
3130                  Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
3131
3132                Append_To (Decls,
3133                  Make_Object_Declaration (Loc,
3134                    Defining_Identifier => Comm_Name,
3135                    Object_Definition =>
3136                      New_Reference_To (RTE (RE_Communication_Block), Loc)));
3137
3138                --  Some additional statements for protected entry calls
3139
3140                --     Protected_Entry_Call (
3141                --       Object => po._object'Access,
3142                --       E => <entry index>;
3143                --       Uninterpreted_Data => P'Address;
3144                --       Mode => Simple_Call;
3145                --       Block => Bnn);
3146
3147                Call :=
3148                  Make_Procedure_Call_Statement (Loc,
3149                    Name =>
3150                      New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
3151
3152                    Parameter_Associations => New_List (
3153                      Make_Attribute_Reference (Loc,
3154                        Attribute_Name => Name_Unchecked_Access,
3155                        Prefix         => Parm1),
3156                      Parm2,
3157                      Parm3,
3158                      New_Reference_To (RTE (RE_Simple_Call), Loc),
3159                      New_Occurrence_Of (Comm_Name, Loc)));
3160
3161             else
3162                --     Protected_Single_Entry_Call (
3163                --       Object => po._object'Access,
3164                --       Uninterpreted_Data => P'Address;
3165                --       Mode => Simple_Call);
3166
3167                Call :=
3168                  Make_Procedure_Call_Statement (Loc,
3169                    Name => New_Reference_To (
3170                      RTE (RE_Protected_Single_Entry_Call), Loc),
3171
3172                    Parameter_Associations => New_List (
3173                      Make_Attribute_Reference (Loc,
3174                        Attribute_Name => Name_Unchecked_Access,
3175                        Prefix         => Parm1),
3176                      Parm3,
3177                      New_Reference_To (RTE (RE_Simple_Call), Loc)));
3178             end if;
3179
3180          --  Case of task type
3181
3182          else
3183             Call :=
3184               Make_Procedure_Call_Statement (Loc,
3185                 Name => New_Reference_To (RTE (RE_Call_Simple), Loc),
3186                 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
3187
3188          end if;
3189
3190          Append_To (Stats, Call);
3191
3192          --  If there are out or in/out parameters by copy add assignment
3193          --  statements for the result values.
3194
3195          if Present (Parms) then
3196             Actual := First_Actual (N);
3197             Formal := First_Formal (Ent);
3198
3199             Set_Assignment_OK (Actual);
3200             while Present (Actual) loop
3201                if Is_By_Copy_Type (Etype (Actual))
3202                  and then Ekind (Formal) /= E_In_Parameter
3203                then
3204                   N_Node :=
3205                     Make_Assignment_Statement (Loc,
3206                       Name => New_Copy (Actual),
3207                       Expression =>
3208                         Make_Explicit_Dereference (Loc,
3209                           Make_Selected_Component (Loc,
3210                             Prefix => New_Reference_To (P, Loc),
3211                             Selector_Name =>
3212                               Make_Identifier (Loc, Chars (Formal)))));
3213
3214                   --  In all cases (including limited private types) we want
3215                   --  the assignment to be valid.
3216
3217                   Set_Assignment_OK (Name (N_Node));
3218
3219                   --  If the call is the triggering alternative in an
3220                   --  asynchronous select, or the entry_call alternative of a
3221                   --  conditional entry call, the assignments for in-out
3222                   --  parameters are incorporated into the statement list that
3223                   --  follows, so that there are executed only if the entry
3224                   --  call succeeds.
3225
3226                   if (Nkind (Parent (N)) = N_Triggering_Alternative
3227                        and then N = Triggering_Statement (Parent (N)))
3228                     or else
3229                      (Nkind (Parent (N)) = N_Entry_Call_Alternative
3230                        and then N = Entry_Call_Statement (Parent (N)))
3231                   then
3232                      if No (Statements (Parent (N))) then
3233                         Set_Statements (Parent (N), New_List);
3234                      end if;
3235
3236                      Prepend (N_Node, Statements (Parent (N)));
3237
3238                   else
3239                      Insert_After (Call, N_Node);
3240                   end if;
3241                end if;
3242
3243                Next_Actual (Actual);
3244                Next_Formal_With_Extras (Formal);
3245             end loop;
3246          end if;
3247
3248          --  Finally, create block and analyze it
3249
3250          Rewrite (N,
3251            Make_Block_Statement (Loc,
3252              Declarations => Decls,
3253              Handled_Statement_Sequence =>
3254                Make_Handled_Sequence_Of_Statements (Loc,
3255                  Statements => Stats)));
3256
3257          Analyze (N);
3258       end;
3259    end Build_Simple_Entry_Call;
3260
3261    --------------------------------
3262    -- Build_Task_Activation_Call --
3263    --------------------------------
3264
3265    procedure Build_Task_Activation_Call (N : Node_Id) is
3266       Loc   : constant Source_Ptr := Sloc (N);
3267       Chain : Entity_Id;
3268       Call  : Node_Id;
3269       Name  : Node_Id;
3270       P     : Node_Id;
3271
3272    begin
3273       --  Get the activation chain entity. Except in the case of a package
3274       --  body, this is in the node that was passed. For a package body, we
3275       --  have to find the corresponding package declaration node.
3276
3277       if Nkind (N) = N_Package_Body then
3278          P := Corresponding_Spec (N);
3279          loop
3280             P := Parent (P);
3281             exit when Nkind (P) = N_Package_Declaration;
3282          end loop;
3283
3284          Chain := Activation_Chain_Entity (P);
3285
3286       else
3287          Chain := Activation_Chain_Entity (N);
3288       end if;
3289
3290       if Present (Chain) then
3291          if Restricted_Profile then
3292             Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc);
3293          else
3294             Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
3295          end if;
3296
3297          Call :=
3298            Make_Procedure_Call_Statement (Loc,
3299              Name => Name,