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-2010, 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_Ch6;  use Exp_Ch6;
  33 with Exp_Ch11; use Exp_Ch11;
  34 with Exp_Dbug; use Exp_Dbug;
  35 with Exp_Disp; use Exp_Disp;
  36 with Exp_Sel;  use Exp_Sel;
  37 with Exp_Smem; use Exp_Smem;
  38 with Exp_Tss;  use Exp_Tss;
  39 with Exp_Util; use Exp_Util;
  40 with Freeze;   use Freeze;
  41 with Hostparm;
  42 with Itypes;   use Itypes;
  43 with Namet;    use Namet;
  44 with Nlists;   use Nlists;
  45 with Nmake;    use Nmake;
  46 with Opt;      use Opt;
  47 with Restrict; use Restrict;
  48 with Rident;   use Rident;
  49 with Rtsfind;  use Rtsfind;
  50 with Sem;      use Sem;
  51 with Sem_Aux;  use Sem_Aux;
  52 with Sem_Ch6;  use Sem_Ch6;
  53 with Sem_Ch8;  use Sem_Ch8;
  54 with Sem_Ch11; use Sem_Ch11;
  55 with Sem_Elab; use Sem_Elab;
  56 with Sem_Eval; use Sem_Eval;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Util; use Sem_Util;
  59 with Sinfo;    use Sinfo;
  60 with Snames;   use Snames;
  61 with Stand;    use Stand;
  62 with Stringt;  use Stringt;
  63 with Targparm; use Targparm;
  64 with Tbuild;   use Tbuild;
  65 with Uintp;    use Uintp;
  66
  67 package body Exp_Ch9 is
  68
  69    --  The following constant establishes the upper bound for the index of
  70    --  an entry family. It is used to limit the allocated size of protected
  71    --  types with defaulted discriminant of an integer type, when the bound
  72    --  of some entry family depends on a discriminant. The limitation to
  73    --  entry families of 128K should be reasonable in all cases, and is a
  74    --  documented implementation restriction. It will be lifted when protected
  75    --  entry families are re-implemented as a single ordered queue.
  76
  77    Entry_Family_Bound : constant Int := 2**16;
  78
  79    -----------------------
  80    -- Local Subprograms --
  81    -----------------------
  82
  83    function Actual_Index_Expression
  84      (Sloc  : Source_Ptr;
  85       Ent   : Entity_Id;
  86       Index : Node_Id;
  87       Tsk   : Entity_Id) return Node_Id;
  88    --  Compute the index position for an entry call. Tsk is the target task. If
  89    --  the bounds of some entry family depend on discriminants, the expression
  90    --  computed by this function uses the discriminants of the target task.
  91
  92    procedure Add_Object_Pointer
  93      (Loc      : Source_Ptr;
  94       Conc_Typ : Entity_Id;
  95       Decls    : List_Id);
  96    --  Prepend an object pointer declaration to the declaration list Decls.
  97    --  This object pointer is initialized to a type conversion of the System.
  98    --  Address pointer passed to entry barrier functions and entry body
  99    --  procedures.
 100
 101    procedure Add_Formal_Renamings
 102      (Spec  : Node_Id;
 103       Decls : List_Id;
 104       Ent   : Entity_Id;
 105       Loc   : Source_Ptr);
 106    --  Create renaming declarations for the formals, inside the procedure that
 107    --  implements an entry body. The renamings make the original names of the
 108    --  formals accessible to gdb, and serve no other purpose.
 109    --    Spec is the specification of the procedure being built.
 110    --    Decls is the list of declarations to be enhanced.
 111    --    Ent is the entity for the original entry body.
 112
 113    function Build_Accept_Body (Astat : Node_Id) return Node_Id;
 114    --  Transform accept statement into a block with added exception handler.
 115    --  Used both for simple accept statements and for accept alternatives in
 116    --  select statements. Astat is the accept statement.
 117
 118    function Build_Barrier_Function
 119      (N   : Node_Id;
 120       Ent : Entity_Id;
 121       Pid : Node_Id) return Node_Id;
 122    --  Build the function body returning the value of the barrier expression
 123    --  for the specified entry body.
 124
 125    function Build_Barrier_Function_Specification
 126      (Loc    : Source_Ptr;
 127       Def_Id : Entity_Id) return Node_Id;
 128    --  Build a specification for a function implementing the protected entry
 129    --  barrier of the specified entry body.
 130
 131    function Build_Corresponding_Record
 132      (N    : Node_Id;
 133       Ctyp : Node_Id;
 134       Loc  : Source_Ptr) return Node_Id;
 135    --  Common to tasks and protected types. Copy discriminant specifications,
 136    --  build record declaration. N is the type declaration, Ctyp is the
 137    --  concurrent entity (task type or protected type).
 138
 139    function Build_Entry_Count_Expression
 140      (Concurrent_Type : Node_Id;
 141       Component_List  : List_Id;
 142       Loc             : Source_Ptr) return Node_Id;
 143    --  Compute number of entries for concurrent object. This is a count of
 144    --  simple entries, followed by an expression that computes the length
 145    --  of the range of each entry family. A single array with that size is
 146    --  allocated for each concurrent object of the type.
 147
 148    function Build_Parameter_Block
 149      (Loc     : Source_Ptr;
 150       Actuals : List_Id;
 151       Formals : List_Id;
 152       Decls   : List_Id) return Entity_Id;
 153    --  Generate an access type for each actual parameter in the list Actuals.
 154    --  Create an encapsulating record that contains all the actuals and return
 155    --  its type. Generate:
 156    --    type Ann1 is access all <actual1-type>
 157    --    ...
 158    --    type AnnN is access all <actualN-type>
 159    --    type Pnn is record
 160    --       <formal1> : Ann1;
 161    --       ...
 162    --       <formalN> : AnnN;
 163    --    end record;
 164
 165    procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id);
 166    --  Build body of wrapper procedure for an entry or entry family that has
 167    --  pre/postconditions. The body gathers the PPC's and expands them in the
 168    --  usual way, and performs the entry call itself. This way preconditions
 169    --  are evaluated before the call is queued. E is the entry in question,
 170    --  and Decl is the enclosing synchronized type declaration at whose
 171    --  freeze point the generated body is analyzed.
 172
 173    procedure Build_Wrapper_Bodies
 174      (Loc : Source_Ptr;
 175       Typ : Entity_Id;
 176       N   : Node_Id);
 177    --  Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
 178    --  record of a concurrent type. N is the insertion node where all bodies
 179    --  will be placed. This routine builds the bodies of the subprograms which
 180    --  serve as an indirection mechanism to overriding primitives of concurrent
 181    --  types, entries and protected procedures. Any new body is analyzed.
 182
 183    procedure Build_Wrapper_Specs
 184      (Loc : Source_Ptr;
 185       Typ : Entity_Id;
 186       N   : in out Node_Id);
 187    --  Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
 188    --  record of a concurrent type. N is the insertion node where all specs
 189    --  will be placed. This routine builds the specs of the subprograms which
 190    --  serve as an indirection mechanism to overriding primitives of concurrent
 191    --  types, entries and protected procedures. Any new spec is analyzed.
 192
 193    function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
 194    --  Build the function that translates the entry index in the call
 195    --  (which depends on the size of entry families) into an index into the
 196    --  Entry_Bodies_Array, to determine the body and barrier function used
 197    --  in a protected entry call. A pointer to this function appears in every
 198    --  protected object.
 199
 200    function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
 201    --  Build subprogram declaration for previous one
 202
 203    function Build_Protected_Entry
 204      (N   : Node_Id;
 205       Ent : Entity_Id;
 206       Pid : Node_Id) return Node_Id;
 207    --  Build the procedure implementing the statement sequence of the specified
 208    --  entry body.
 209
 210    function Build_Protected_Entry_Specification
 211      (Loc    : Source_Ptr;
 212       Def_Id : Entity_Id;
 213       Ent_Id : Entity_Id) return Node_Id;
 214    --  Build a specification for the procedure implementing the statements of
 215    --  the specified entry body. Add attributes associating it with the entry
 216    --  defining identifier Ent_Id.
 217
 218    function Build_Protected_Spec
 219      (N           : Node_Id;
 220       Obj_Type    : Entity_Id;
 221       Ident       : Entity_Id;
 222       Unprotected : Boolean := False) return List_Id;
 223    --  Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
 224    --  Subprogram_Type. Builds signature of protected subprogram, adding the
 225    --  formal that corresponds to the object itself. For an access to protected
 226    --  subprogram, there is no object type to specify, so the parameter has
 227    --  type Address and mode In. An indirect call through such a pointer will
 228    --  convert the address to a reference to the actual object. The object is
 229    --  a limited record and therefore a by_reference type.
 230
 231    function Build_Protected_Subprogram_Body
 232      (N         : Node_Id;
 233       Pid       : Node_Id;
 234       N_Op_Spec : Node_Id) return Node_Id;
 235    --  This function is used to construct the protected version of a protected
 236    --  subprogram. Its statement sequence first defers abort, then locks
 237    --  the associated protected object, and then enters a block that contains
 238    --  a call to the unprotected version of the subprogram (for details, see
 239    --  Build_Unprotected_Subprogram_Body). This block statement requires
 240    --  a cleanup handler that unlocks the object in all cases.
 241    --  (see Exp_Ch7.Expand_Cleanup_Actions).
 242
 243    function Build_Selected_Name
 244      (Prefix      : Entity_Id;
 245       Selector    : Entity_Id;
 246       Append_Char : Character := ' ') return Name_Id;
 247    --  Build a name in the form of Prefix__Selector, with an optional
 248    --  character appended. This is used for internal subprograms generated
 249    --  for operations of protected types, including barrier functions.
 250    --  For the subprograms generated for entry bodies and entry barriers,
 251    --  the generated name includes a sequence number that makes names
 252    --  unique in the presence of entry overloading. This is necessary
 253    --  because entry body procedures and barrier functions all have the
 254    --  same signature.
 255
 256    procedure Build_Simple_Entry_Call
 257      (N       : Node_Id;
 258       Concval : Node_Id;
 259       Ename   : Node_Id;
 260       Index   : Node_Id);
 261    --  Some comments here would be useful ???
 262
 263    function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
 264    --  This routine constructs a specification for the procedure that we will
 265    --  build for the task body for task type T. The spec has the form:
 266    --
 267    --    procedure tnameB (_Task : access tnameV);
 268    --
 269    --  where name is the character name taken from the task type entity that
 270    --  is passed as the argument to the procedure, and tnameV is the task
 271    --  value type that is associated with the task type.
 272
 273    function Build_Unprotected_Subprogram_Body
 274      (N   : Node_Id;
 275       Pid : Node_Id) return Node_Id;
 276    --  This routine constructs the unprotected version of a protected
 277    --  subprogram body, which is contains all of the code in the
 278    --  original, unexpanded body. This is the version of the protected
 279    --  subprogram that is called from all protected operations on the same
 280    --  object, including the protected version of the same subprogram.
 281
 282    procedure Collect_Entry_Families
 283      (Loc          : Source_Ptr;
 284       Cdecls       : List_Id;
 285       Current_Node : in out Node_Id;
 286       Conctyp      : Entity_Id);
 287    --  For each entry family in a concurrent type, create an anonymous array
 288    --  type of the right size, and add a component to the corresponding_record.
 289
 290    function Concurrent_Object
 291      (Spec_Id  : Entity_Id;
 292       Conc_Typ : Entity_Id) return Entity_Id;
 293    --  Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
 294    --  the entity associated with the concurrent object in the Protected_Body_
 295    --  Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
 296    --  denotes formal parameter _O, _object or _task.
 297
 298    function Copy_Result_Type (Res : Node_Id) return Node_Id;
 299    --  Copy the result type of a function specification, when building the
 300    --  internal operation corresponding to a protected function, or when
 301    --  expanding an access to protected function. If the result is an anonymous
 302    --  access to subprogram itself, we need to create a new signature with the
 303    --  same parameter names and the same resolved types, but with new entities
 304    --  for the formals.
 305
 306    procedure Debug_Private_Data_Declarations (Decls : List_Id);
 307    --  Decls is a list which may contain the declarations created by Install_
 308    --  Private_Data_Declarations. All generated entities are marked as needing
 309    --  debug info and debug nodes are manually generation where necessary. This
 310    --  step of the expansion must to be done after private data has been moved
 311    --  to its final resting scope to ensure proper visibility of debug objects.
 312
 313    function Family_Offset
 314      (Loc  : Source_Ptr;
 315       Hi   : Node_Id;
 316       Lo   : Node_Id;
 317       Ttyp : Entity_Id;
 318       Cap  : Boolean) return Node_Id;
 319    --  Compute (Hi - Lo) for two entry family indexes. Hi is the index in
 320    --  an accept statement, or the upper bound in the discrete subtype of
 321    --  an entry declaration. Lo is the corresponding lower bound. Ttyp is
 322    --  the concurrent type of the entry. If Cap is true, the result is
 323    --  capped according to Entry_Family_Bound.
 324
 325    function Family_Size
 326      (Loc  : Source_Ptr;
 327       Hi   : Node_Id;
 328       Lo   : Node_Id;
 329       Ttyp : Entity_Id;
 330       Cap  : Boolean) return Node_Id;
 331    --  Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
 332    --  a family, and handle properly the superflat case. This is equivalent
 333    --  to the use of 'Length on the index type, but must use Family_Offset
 334    --  to handle properly the case of bounds that depend on discriminants.
 335    --  If Cap is true, the result is capped according to Entry_Family_Bound.
 336
 337    procedure Extract_Dispatching_Call
 338      (N        : Node_Id;
 339       Call_Ent : out Entity_Id;
 340       Object   : out Entity_Id;
 341       Actuals  : out List_Id;
 342       Formals  : out List_Id);
 343    --  Given a dispatching call, extract the entity of the name of the call,
 344    --  its object parameter, its actual parameters and the formal parameters
 345    --  of the overridden interface-level version.
 346
 347    procedure Extract_Entry
 348      (N       : Node_Id;
 349       Concval : out Node_Id;
 350       Ename   : out Node_Id;
 351       Index   : out Node_Id);
 352    --  Given an entry call, returns the associated concurrent object,
 353    --  the entry name, and the entry family index.
 354
 355    function Find_Task_Or_Protected_Pragma
 356      (T : Node_Id;
 357       P : Name_Id) return Node_Id;
 358    --  Searches the task or protected definition T for the first occurrence
 359    --  of the pragma whose name is given by P. The caller has ensured that
 360    --  the pragma is present in the task definition. A special case is that
 361    --  when P is Name_uPriority, the call will also find Interrupt_Priority.
 362    --  ??? Should be implemented with the rep item chain mechanism.
 363
 364    function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
 365    --  Given a subprogram identifier, return the entity which is associated
 366    --  with the protection entry index in the Protected_Body_Subprogram or the
 367    --  Task_Body_Procedure of Spec_Id. The returned entity denotes formal
 368    --  parameter _E.
 369
 370    function Is_Potentially_Large_Family
 371      (Base_Index : Entity_Id;
 372       Conctyp    : Entity_Id;
 373       Lo         : Node_Id;
 374       Hi         : Node_Id) return Boolean;
 375
 376    function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
 377    --  Determine whether Id is a function or a procedure and is marked as a
 378    --  private primitive.
 379
 380    function Null_Statements (Stats : List_Id) return Boolean;
 381    --  Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
 382    --  Allows labels, and pragma Warnings/Unreferenced in the sequence as
 383    --  well to still count as null. Returns True for a null sequence. The
 384    --  argument is the list of statements from the DO-END sequence.
 385
 386    function Parameter_Block_Pack
 387      (Loc     : Source_Ptr;
 388       Blk_Typ : Entity_Id;
 389       Actuals : List_Id;
 390       Formals : List_Id;
 391       Decls   : List_Id;
 392       Stmts   : List_Id) return Entity_Id;
 393    --  Set the components of the generated parameter block with the values of
 394    --  the actual parameters. Generate aliased temporaries to capture the
 395    --  values for types that are passed by copy. Otherwise generate a reference
 396    --  to the actual's value. Return the address of the aggregate block.
 397    --  Generate:
 398    --    Jnn1 : alias <formal-type1>;
 399    --    Jnn1 := <actual1>;
 400    --    ...
 401    --    P : Blk_Typ := (
 402    --      Jnn1'unchecked_access;
 403    --      <actual2>'reference;
 404    --      ...);
 405
 406    function Parameter_Block_Unpack
 407      (Loc     : Source_Ptr;
 408       P       : Entity_Id;
 409       Actuals : List_Id;
 410       Formals : List_Id) return List_Id;
 411    --  Retrieve the values of the components from the parameter block and
 412    --  assign then to the original actual parameters. Generate:
 413    --    <actual1> := P.<formal1>;
 414    --    ...
 415    --    <actualN> := P.<formalN>;
 416
 417    function Trivial_Accept_OK return Boolean;
 418    --  If there is no DO-END block for an accept, or if the DO-END block has
 419    --  only null statements, then it is possible to do the Rendezvous with much
 420    --  less overhead using the Accept_Trivial routine in the run-time library.
 421    --  However, this is not always a valid optimization. Whether it is valid or
 422    --  not depends on the Task_Dispatching_Policy. The issue is whether a full
 423    --  rescheduling action is required or not. In FIFO_Within_Priorities, such
 424    --  a rescheduling is required, so this optimization is not allowed. This
 425    --  function returns True if the optimization is permitted.
 426
 427    -----------------------------
 428    -- Actual_Index_Expression --
 429    -----------------------------
 430
 431    function Actual_Index_Expression
 432      (Sloc  : Source_Ptr;
 433       Ent   : Entity_Id;
 434       Index : Node_Id;
 435       Tsk   : Entity_Id) return Node_Id
 436    is
 437       Ttyp : constant Entity_Id := Etype (Tsk);
 438       Expr : Node_Id;
 439       Num  : Node_Id;
 440       Lo   : Node_Id;
 441       Hi   : Node_Id;
 442       Prev : Entity_Id;
 443       S    : Node_Id;
 444
 445       function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
 446       --  Compute difference between bounds of entry family
 447
 448       --------------------------
 449       -- Actual_Family_Offset --
 450       --------------------------
 451
 452       function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
 453
 454          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
 455          --  Replace a reference to a discriminant with a selected component
 456          --  denoting the discriminant of the target task.
 457
 458          -----------------------------
 459          -- Actual_Discriminant_Ref --
 460          -----------------------------
 461
 462          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
 463             Typ : constant Entity_Id := Etype (Bound);
 464             B   : Node_Id;
 465
 466          begin
 467             if not Is_Entity_Name (Bound)
 468               or else Ekind (Entity (Bound)) /= E_Discriminant
 469             then
 470                if Nkind (Bound) = N_Attribute_Reference then
 471                   return Bound;
 472                else
 473                   B := New_Copy_Tree (Bound);
 474                end if;
 475
 476             else
 477                B :=
 478                  Make_Selected_Component (Sloc,
 479                    Prefix => New_Copy_Tree (Tsk),
 480                    Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
 481
 482                Analyze_And_Resolve (B, Typ);
 483             end if;
 484
 485             return
 486               Make_Attribute_Reference (Sloc,
 487                 Attribute_Name => Name_Pos,
 488                 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
 489                 Expressions => New_List (B));
 490          end Actual_Discriminant_Ref;
 491
 492       --  Start of processing for Actual_Family_Offset
 493
 494       begin
 495          return
 496            Make_Op_Subtract (Sloc,
 497              Left_Opnd  => Actual_Discriminant_Ref (Hi),
 498              Right_Opnd => Actual_Discriminant_Ref (Lo));
 499       end Actual_Family_Offset;
 500
 501    --  Start of processing for Actual_Index_Expression
 502
 503    begin
 504       --  The queues of entries and entry families appear in textual order in
 505       --  the associated record. The entry index is computed as the sum of the
 506       --  number of queues for all entries that precede the designated one, to
 507       --  which is added the index expression, if this expression denotes a
 508       --  member of a family.
 509
 510       --  The following is a place holder for the count of simple entries
 511
 512       Num := Make_Integer_Literal (Sloc, 1);
 513
 514       --  We construct an expression which is a series of addition operations.
 515       --  See comments in Entry_Index_Expression, which is identical in
 516       --  structure.
 517
 518       if Present (Index) then
 519          S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
 520
 521          Expr :=
 522            Make_Op_Add (Sloc,
 523              Left_Opnd  => Num,
 524
 525              Right_Opnd =>
 526                Actual_Family_Offset (
 527                  Make_Attribute_Reference (Sloc,
 528                    Attribute_Name => Name_Pos,
 529                    Prefix => New_Reference_To (Base_Type (S), Sloc),
 530                    Expressions => New_List (Relocate_Node (Index))),
 531                  Type_Low_Bound (S)));
 532       else
 533          Expr := Num;
 534       end if;
 535
 536       --  Now add lengths of preceding entries and entry families
 537
 538       Prev := First_Entity (Ttyp);
 539
 540       while Chars (Prev) /= Chars (Ent)
 541         or else (Ekind (Prev) /= Ekind (Ent))
 542         or else not Sem_Ch6.Type_Conformant (Ent, Prev)
 543       loop
 544          if Ekind (Prev) = E_Entry then
 545             Set_Intval (Num, Intval (Num) + 1);
 546
 547          elsif Ekind (Prev) = E_Entry_Family then
 548             S :=
 549               Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
 550
 551             --  The need for the following full view retrieval stems from
 552             --  this complex case of nested generics and tasking:
 553
 554             --     generic
 555             --        type Formal_Index is range <>;
 556             --        ...
 557             --     package Outer is
 558             --        type Index is private;
 559             --        generic
 560             --           ...
 561             --        package Inner is
 562             --           procedure P;
 563             --        end Inner;
 564             --     private
 565             --        type Index is new Formal_Index range 1 .. 10;
 566             --     end Outer;
 567
 568             --     package body Outer is
 569             --        task type T is
 570             --           entry Fam (Index);  --  (2)
 571             --           entry E;
 572             --        end T;
 573             --        package body Inner is  --  (3)
 574             --           procedure P is
 575             --           begin
 576             --              T.E;             --  (1)
 577             --           end P;
 578             --       end Inner;
 579             --       ...
 580
 581             --  We are currently building the index expression for the entry
 582             --  call "T.E" (1). Part of the expansion must mention the range
 583             --  of the discrete type "Index" (2) of entry family "Fam".
 584             --  However only the private view of type "Index" is available to
 585             --  the inner generic (3) because there was no prior mention of
 586             --  the type inside "Inner". This visibility requirement is
 587             --  implicit and cannot be detected during the construction of
 588             --  the generic trees and needs special handling.
 589
 590             if In_Instance_Body
 591               and then Is_Private_Type (S)
 592               and then Present (Full_View (S))
 593             then
 594                S := Full_View (S);
 595             end if;
 596
 597             Lo := Type_Low_Bound  (S);
 598             Hi := Type_High_Bound (S);
 599
 600             Expr :=
 601               Make_Op_Add (Sloc,
 602               Left_Opnd  => Expr,
 603               Right_Opnd =>
 604                 Make_Op_Add (Sloc,
 605                   Left_Opnd =>
 606                     Actual_Family_Offset (Hi, Lo),
 607                   Right_Opnd =>
 608                     Make_Integer_Literal (Sloc, 1)));
 609
 610          --  Other components are anonymous types to be ignored
 611
 612          else
 613             null;
 614          end if;
 615
 616          Next_Entity (Prev);
 617       end loop;
 618
 619       return Expr;
 620    end Actual_Index_Expression;
 621
 622    --------------------------
 623    -- Add_Formal_Renamings --
 624    --------------------------
 625
 626    procedure Add_Formal_Renamings
 627      (Spec  : Node_Id;
 628       Decls : List_Id;
 629       Ent   : Entity_Id;
 630       Loc   : Source_Ptr)
 631    is
 632       Ptr : constant Entity_Id :=
 633               Defining_Identifier
 634                 (Next (First (Parameter_Specifications (Spec))));
 635       --  The name of the formal that holds the address of the parameter block
 636       --  for the call.
 637
 638       Comp   : Entity_Id;
 639       Decl   : Node_Id;
 640       Formal : Entity_Id;
 641       New_F  : Entity_Id;
 642
 643    begin
 644       Formal := First_Formal (Ent);
 645       while Present (Formal) loop
 646          Comp := Entry_Component (Formal);
 647          New_F :=
 648            Make_Defining_Identifier (Sloc (Formal),
 649              Chars => Chars (Formal));
 650          Set_Etype (New_F, Etype (Formal));
 651          Set_Scope (New_F, Ent);
 652
 653          --  Now we set debug info needed on New_F even though it does not
 654          --  come from source, so that the debugger will get the right
 655          --  information for these generated names.
 656
 657          Set_Debug_Info_Needed (New_F);
 658
 659          if Ekind (Formal) = E_In_Parameter then
 660             Set_Ekind (New_F, E_Constant);
 661          else
 662             Set_Ekind (New_F, E_Variable);
 663             Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
 664          end if;
 665
 666          Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
 667
 668          Decl :=
 669            Make_Object_Renaming_Declaration (Loc,
 670            Defining_Identifier => New_F,
 671            Subtype_Mark =>
 672              New_Reference_To (Etype (Formal), Loc),
 673            Name =>
 674              Make_Explicit_Dereference (Loc,
 675                Make_Selected_Component (Loc,
 676                  Prefix        =>
 677                    Unchecked_Convert_To (Entry_Parameters_Type (Ent),
 678                      Make_Identifier (Loc, Chars (Ptr))),
 679                  Selector_Name => New_Reference_To (Comp, Loc))));
 680
 681          Append (Decl, Decls);
 682          Set_Renamed_Object (Formal, New_F);
 683          Next_Formal (Formal);
 684       end loop;
 685    end Add_Formal_Renamings;
 686
 687    ------------------------
 688    -- Add_Object_Pointer --
 689    ------------------------
 690
 691    procedure Add_Object_Pointer
 692      (Loc      : Source_Ptr;
 693       Conc_Typ : Entity_Id;
 694       Decls    : List_Id)
 695    is
 696       Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ);
 697       Decl    : Node_Id;
 698       Obj_Ptr : Node_Id;
 699
 700    begin
 701       --  Create the renaming declaration for the Protection object of a
 702       --  protected type. _Object is used by Complete_Entry_Body.
 703       --  ??? An attempt to make this a renaming was unsuccessful.
 704
 705       --  Build the entity for the access type
 706
 707       Obj_Ptr :=
 708         Make_Defining_Identifier (Loc,
 709           New_External_Name (Chars (Rec_Typ), 'P'));
 710
 711       --  Generate:
 712       --    _object : poVP := poVP!O;
 713
 714       Decl :=
 715         Make_Object_Declaration (Loc,
 716           Defining_Identifier =>
 717             Make_Defining_Identifier (Loc, Name_uObject),
 718           Object_Definition =>
 719             New_Reference_To (Obj_Ptr, Loc),
 720           Expression =>
 721             Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO)));
 722       Set_Debug_Info_Needed (Defining_Identifier (Decl));
 723       Prepend_To (Decls, Decl);
 724
 725       --  Generate:
 726       --    type poVP is access poV;
 727
 728       Decl :=
 729         Make_Full_Type_Declaration (Loc,
 730           Defining_Identifier =>
 731             Obj_Ptr,
 732           Type_Definition =>
 733             Make_Access_To_Object_Definition (Loc,
 734           Subtype_Indication =>
 735             New_Reference_To (Rec_Typ, Loc)));
 736       Set_Debug_Info_Needed (Defining_Identifier (Decl));
 737       Prepend_To (Decls, Decl);
 738    end Add_Object_Pointer;
 739
 740    -----------------------
 741    -- Build_Accept_Body --
 742    -----------------------
 743
 744    function Build_Accept_Body (Astat : Node_Id) return  Node_Id is
 745       Loc     : constant Source_Ptr := Sloc (Astat);
 746       Stats   : constant Node_Id    := Handled_Statement_Sequence (Astat);
 747       New_S   : Node_Id;
 748       Hand    : Node_Id;
 749       Call    : Node_Id;
 750       Ohandle : Node_Id;
 751
 752    begin
 753       --  At the end of the statement sequence, Complete_Rendezvous is called.
 754       --  A label skipping the Complete_Rendezvous, and all other accept
 755       --  processing, has already been added for the expansion of requeue
 756       --  statements. The Sloc is copied from the last statement since it
 757       --  is really part of this last statement.
 758
 759       Call :=
 760         Build_Runtime_Call
 761           (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
 762       Insert_Before (Last (Statements (Stats)), Call);
 763       Analyze (Call);
 764
 765       --  If exception handlers are present, then append Complete_Rendezvous
 766       --  calls to the handlers, and construct the required outer block. As
 767       --  above, the Sloc is copied from the last statement in the sequence.
 768
 769       if Present (Exception_Handlers (Stats)) then
 770          Hand := First (Exception_Handlers (Stats));
 771          while Present (Hand) loop
 772             Call :=
 773               Build_Runtime_Call
 774                 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
 775             Append (Call, Statements (Hand));
 776             Analyze (Call);
 777             Next (Hand);
 778          end loop;
 779
 780          New_S :=
 781            Make_Handled_Sequence_Of_Statements (Loc,
 782              Statements => New_List (
 783                Make_Block_Statement (Loc,
 784                  Handled_Statement_Sequence => Stats)));
 785
 786       else
 787          New_S := Stats;
 788       end if;
 789
 790       --  At this stage we know that the new statement sequence does not
 791       --  have an exception handler part, so we supply one to call
 792       --  Exceptional_Complete_Rendezvous. This handler is
 793
 794       --    when all others =>
 795       --       Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
 796
 797       --  We handle Abort_Signal to make sure that we properly catch the abort
 798       --  case and wake up the caller.
 799
 800       Ohandle := Make_Others_Choice (Loc);
 801       Set_All_Others (Ohandle);
 802
 803       Set_Exception_Handlers (New_S,
 804         New_List (
 805           Make_Implicit_Exception_Handler (Loc,
 806             Exception_Choices => New_List (Ohandle),
 807
 808             Statements =>  New_List (
 809               Make_Procedure_Call_Statement (Sloc (Stats),
 810                 Name => New_Reference_To (
 811                   RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
 812                 Parameter_Associations => New_List (
 813                   Make_Function_Call (Sloc (Stats),
 814                     Name => New_Reference_To (
 815                       RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
 816
 817       Set_Parent (New_S, Astat); -- temp parent for Analyze call
 818       Analyze_Exception_Handlers (Exception_Handlers (New_S));
 819       Expand_Exception_Handlers (New_S);
 820
 821       --  Exceptional_Complete_Rendezvous must be called with abort
 822       --  still deferred, which is the case for a "when all others" handler.
 823
 824       return New_S;
 825    end Build_Accept_Body;
 826
 827    -----------------------------------
 828    -- Build_Activation_Chain_Entity --
 829    -----------------------------------
 830
 831    procedure Build_Activation_Chain_Entity (N : Node_Id) is
 832       P     : Node_Id;
 833       Decls : List_Id;
 834       Chain : Entity_Id;
 835
 836    begin
 837       --  Loop to find enclosing construct containing activation chain variable
 838       --  The construct is a body, a block, or an extended return.
 839
 840       P := Parent (N);
 841
 842       while not Nkind_In (P, N_Subprogram_Body,
 843                              N_Entry_Body,
 844                              N_Package_Declaration,
 845                              N_Package_Body,
 846                              N_Block_Statement,
 847                              N_Task_Body,
 848                              N_Extended_Return_Statement)
 849       loop
 850          P := Parent (P);
 851       end loop;
 852
 853       --  If we are in a package body, the activation chain variable is
 854       --  declared in the body, but the Activation_Chain_Entity is attached
 855       --  to the spec.
 856
 857       if Nkind (P) = N_Package_Body then
 858          Decls := Declarations (P);
 859          P := Unit_Declaration_Node (Corresponding_Spec (P));
 860
 861       elsif Nkind (P) = N_Package_Declaration then
 862          Decls := Visible_Declarations (Specification (P));
 863
 864       elsif Nkind (P) = N_Extended_Return_Statement then
 865          Decls := Return_Object_Declarations (P);
 866
 867       else
 868          Decls := Declarations (P);
 869       end if;
 870
 871       --  If activation chain entity not already declared, declare it
 872
 873       if Nkind (P) = N_Extended_Return_Statement
 874         or else No (Activation_Chain_Entity (P))
 875       then
 876          Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
 877
 878          --  Note: An extended return statement is not really a task activator,
 879          --  but it does have an activation chain on which to store the tasks
 880          --  temporarily. On successful return, the tasks on this chain are
 881          --  moved to the chain passed in by the caller. We do not build an
 882          --  Activation_Chain_Entity for an N_Extended_Return_Statement,
 883          --  because we do not want to build a call to Activate_Tasks. Task
 884          --  activation is the responsibility of the caller.
 885
 886          if Nkind (P) /= N_Extended_Return_Statement then
 887             Set_Activation_Chain_Entity (P, Chain);
 888          end if;
 889
 890          Prepend_To (Decls,
 891            Make_Object_Declaration (Sloc (P),
 892              Defining_Identifier => Chain,
 893              Aliased_Present => True,
 894              Object_Definition =>
 895                New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
 896
 897          Analyze (First (Decls));
 898       end if;
 899    end Build_Activation_Chain_Entity;
 900
 901    ----------------------------
 902    -- Build_Barrier_Function --
 903    ----------------------------
 904
 905    function Build_Barrier_Function
 906      (N   : Node_Id;
 907       Ent : Entity_Id;
 908       Pid : Node_Id) return Node_Id
 909    is
 910       Loc         : constant Source_Ptr := Sloc (N);
 911       Func_Id     : constant Entity_Id  := Barrier_Function (Ent);
 912       Ent_Formals : constant Node_Id    := Entry_Body_Formal_Part (N);
 913       Op_Decls    : constant List_Id    := New_List;
 914       Func_Body   : Node_Id;
 915
 916    begin
 917       --  Add a declaration for the Protection object, renaming declarations
 918       --  for the discriminals and privals and finally a declaration for the
 919       --  entry family index (if applicable).
 920
 921       Install_Private_Data_Declarations
 922         (Loc, Func_Id, Pid, N, Op_Decls, True, Ekind (Ent) = E_Entry_Family);
 923
 924       --  Note: the condition in the barrier function needs to be properly
 925       --  processed for the C/Fortran boolean possibility, but this happens
 926       --  automatically since the return statement does this normalization.
 927
 928       Func_Body :=
 929         Make_Subprogram_Body (Loc,
 930           Specification =>
 931             Build_Barrier_Function_Specification (Loc,
 932               Make_Defining_Identifier (Loc, Chars (Func_Id))),
 933           Declarations => Op_Decls,
 934           Handled_Statement_Sequence =>
 935             Make_Handled_Sequence_Of_Statements (Loc,
 936               Statements => New_List (
 937                 Make_Simple_Return_Statement (Loc,
 938                   Expression => Condition (Ent_Formals)))));
 939       Set_Is_Entry_Barrier_Function (Func_Body);
 940
 941       return Func_Body;
 942    end Build_Barrier_Function;
 943
 944    ------------------------------------------
 945    -- Build_Barrier_Function_Specification --
 946    ------------------------------------------
 947
 948    function Build_Barrier_Function_Specification
 949      (Loc    : Source_Ptr;
 950       Def_Id : Entity_Id) return Node_Id
 951    is
 952    begin
 953       Set_Debug_Info_Needed (Def_Id);
 954
 955       return Make_Function_Specification (Loc,
 956         Defining_Unit_Name => Def_Id,
 957         Parameter_Specifications => New_List (
 958           Make_Parameter_Specification (Loc,
 959             Defining_Identifier =>
 960               Make_Defining_Identifier (Loc, Name_uO),
 961             Parameter_Type =>
 962               New_Reference_To (RTE (RE_Address), Loc)),
 963
 964           Make_Parameter_Specification (Loc,
 965             Defining_Identifier =>
 966               Make_Defining_Identifier (Loc, Name_uE),
 967             Parameter_Type =>
 968               New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
 969
 970         Result_Definition =>
 971           New_Reference_To (Standard_Boolean, Loc));
 972    end Build_Barrier_Function_Specification;
 973
 974    --------------------------
 975    -- Build_Call_With_Task --
 976    --------------------------
 977
 978    function Build_Call_With_Task
 979      (N : Node_Id;
 980       E : Entity_Id) return Node_Id
 981    is
 982       Loc : constant Source_Ptr := Sloc (N);
 983    begin
 984       return
 985         Make_Function_Call (Loc,
 986           Name => New_Reference_To (E, Loc),
 987           Parameter_Associations => New_List (Concurrent_Ref (N)));
 988    end Build_Call_With_Task;
 989
 990    --------------------------------
 991    -- Build_Corresponding_Record --
 992    --------------------------------
 993
 994    function Build_Corresponding_Record
 995     (N    : Node_Id;
 996      Ctyp : Entity_Id;
 997      Loc  : Source_Ptr) return Node_Id
 998    is
 999       Rec_Ent  : constant Entity_Id :=
1000                    Make_Defining_Identifier
1001                      (Loc, New_External_Name (Chars (Ctyp), 'V'));
1002       Disc     : Entity_Id;
1003       Dlist    : List_Id;
1004       New_Disc : Entity_Id;
1005       Cdecls   : List_Id;
1006
1007    begin
1008       Set_Corresponding_Record_Type     (Ctyp, Rec_Ent);
1009       Set_Ekind                         (Rec_Ent, E_Record_Type);
1010       Set_Has_Delayed_Freeze            (Rec_Ent, Has_Delayed_Freeze (Ctyp));
1011       Set_Is_Concurrent_Record_Type     (Rec_Ent, True);
1012       Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
1013       Set_Stored_Constraint             (Rec_Ent, No_Elist);
1014       Cdecls := New_List;
1015
1016       --  Use discriminals to create list of discriminants for record, and
1017       --  create new discriminals for use in default expressions, etc. It is
1018       --  worth noting that a task discriminant gives rise to 5 entities;
1019
1020       --  a) The original discriminant.
1021       --  b) The discriminal for use in the task.
1022       --  c) The discriminant of the corresponding record.
1023       --  d) The discriminal for the init proc of the corresponding record.
1024       --  e) The local variable that renames the discriminant in the procedure
1025       --     for the task body.
1026
1027       --  In fact the discriminals b) are used in the renaming declarations
1028       --  for e). See details in  einfo (Handling of Discriminants).
1029
1030       if Present (Discriminant_Specifications (N)) then
1031          Dlist := New_List;
1032          Disc := First_Discriminant (Ctyp);
1033
1034          while Present (Disc) loop
1035             New_Disc := CR_Discriminant (Disc);
1036
1037             Append_To (Dlist,
1038               Make_Discriminant_Specification (Loc,
1039                 Defining_Identifier => New_Disc,
1040                 Discriminant_Type =>
1041                   New_Occurrence_Of (Etype (Disc), Loc),
1042                 Expression =>
1043                   New_Copy (Discriminant_Default_Value (Disc))));
1044
1045             Next_Discriminant (Disc);
1046          end loop;
1047
1048       else
1049          Dlist := No_List;
1050       end if;
1051
1052       --  Now we can construct the record type declaration. Note that this
1053       --  record is "limited tagged". It is "limited" to reflect the underlying
1054       --  limitedness of the task or protected object that it represents, and
1055       --  ensuring for example that it is properly passed by reference. It is
1056       --  "tagged" to give support to dispatching calls through interfaces. We
1057       --  propagate here the list of interfaces covered by the concurrent type
1058       --  (Ada 2005: AI-345).
1059
1060       return
1061         Make_Full_Type_Declaration (Loc,
1062           Defining_Identifier => Rec_Ent,
1063           Discriminant_Specifications => Dlist,
1064           Type_Definition =>
1065             Make_Record_Definition (Loc,
1066               Component_List =>
1067                 Make_Component_List (Loc,
1068                   Component_Items => Cdecls),
1069               Tagged_Present  =>
1070                  Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp),
1071               Interface_List  => Interface_List (N),
1072               Limited_Present => True));
1073    end Build_Corresponding_Record;
1074
1075    ----------------------------------
1076    -- Build_Entry_Count_Expression --
1077    ----------------------------------
1078
1079    function Build_Entry_Count_Expression
1080      (Concurrent_Type : Node_Id;
1081       Component_List  : List_Id;
1082       Loc             : Source_Ptr) return Node_Id
1083    is
1084       Eindx  : Nat;
1085       Ent    : Entity_Id;
1086       Ecount : Node_Id;
1087       Comp   : Node_Id;
1088       Lo     : Node_Id;
1089       Hi     : Node_Id;
1090       Typ    : Entity_Id;
1091       Large  : Boolean;
1092
1093    begin
1094       --  Count number of non-family entries
1095
1096       Eindx := 0;
1097       Ent := First_Entity (Concurrent_Type);
1098       while Present (Ent) loop
1099          if Ekind (Ent) = E_Entry then
1100             Eindx := Eindx + 1;
1101          end if;
1102
1103          Next_Entity (Ent);
1104       end loop;
1105
1106       Ecount := Make_Integer_Literal (Loc, Eindx);
1107
1108       --  Loop through entry families building the addition nodes
1109
1110       Ent := First_Entity (Concurrent_Type);
1111       Comp := First (Component_List);
1112       while Present (Ent) loop
1113          if Ekind (Ent) = E_Entry_Family then
1114             while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
1115                Next (Comp);
1116             end loop;
1117
1118             Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1119             Hi := Type_High_Bound (Typ);
1120             Lo := Type_Low_Bound  (Typ);
1121             Large := Is_Potentially_Large_Family
1122                        (Base_Type (Typ), Concurrent_Type, Lo, Hi);
1123             Ecount :=
1124               Make_Op_Add (Loc,
1125                 Left_Opnd  => Ecount,
1126                 Right_Opnd => Family_Size
1127                                 (Loc, Hi, Lo, Concurrent_Type, Large));
1128          end if;
1129
1130          Next_Entity (Ent);
1131       end loop;
1132
1133       return Ecount;
1134    end Build_Entry_Count_Expression;
1135
1136    -----------------------
1137    -- Build_Entry_Names --
1138    -----------------------
1139
1140    function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is
1141       Loc       : constant Source_Ptr := Sloc (Conc_Typ);
1142       B_Decls   : List_Id;
1143       B_Stmts   : List_Id;
1144       Comp      : Node_Id;
1145       Index     : Entity_Id;
1146       Index_Typ : RE_Id;
1147       Typ       : Entity_Id := Conc_Typ;
1148
1149       procedure Build_Entry_Family_Name (Id : Entity_Id);
1150       --  Generate:
1151       --    for Lnn in Family_Low .. Family_High loop
1152       --       Inn := Inn + 1;
1153       --       Set_Entry_Name
1154       --         (_init._object <or> _init._task_id,
1155       --          Inn,
1156       --          new String ("<Entry name>(" & Lnn'Img & ")"));
1157       --    end loop;
1158       --  Note that the bounds of the range may reference discriminants. The
1159       --  above construct is added directly to the statements of the block.
1160
1161       procedure Build_Entry_Name (Id : Entity_Id);
1162       --  Generate:
1163       --    Inn := Inn + 1;
1164       --    Set_Entry_Name
1165       --      (_init._object <or>_init._task_id,
1166       --       Inn,
1167       --       new String ("<Entry name>");
1168       --  The above construct is added directly to the statements of the block.
1169
1170       function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id;
1171       --  Generate the call to the runtime routine Set_Entry_Name with actuals
1172       --  _init._task_id or _init._object, Inn and Arg3.
1173
1174       function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id;
1175       --  Given a protected type or its corresponding record, find the type of
1176       --  field _object.
1177
1178       procedure Increment_Index (Stmts : List_Id);
1179       --  Generate the following and add it to Stmts
1180       --    Inn := Inn + 1;
1181
1182       -----------------------------
1183       -- Build_Entry_Family_Name --
1184       -----------------------------
1185
1186       procedure Build_Entry_Family_Name (Id : Entity_Id) is
1187          Def     : constant Node_Id :=
1188                      Discrete_Subtype_Definition (Parent (Id));
1189          L_Id    : constant Entity_Id := Make_Temporary (Loc, 'L');
1190          L_Stmts : constant List_Id := New_List;
1191          Val     : Node_Id;
1192
1193          function Build_Range (Def : Node_Id) return Node_Id;
1194          --  Given a discrete subtype definition of an entry family, generate a
1195          --  range node which covers the range of Def's type.
1196
1197          -----------------
1198          -- Build_Range --
1199          -----------------
1200
1201          function Build_Range (Def : Node_Id) return Node_Id is
1202             High : Node_Id := Type_High_Bound (Etype (Def));
1203             Low  : Node_Id := Type_Low_Bound  (Etype (Def));
1204
1205          begin
1206             --  If a bound references a discriminant, generate an identifier
1207             --  with the same name. Resolution will map it to the formals of
1208             --  the init proc.
1209
1210             if Is_Entity_Name (Low)
1211               and then Ekind (Entity (Low)) = E_Discriminant
1212             then
1213                Low := Make_Identifier (Loc, Chars (Low));
1214             else
1215                Low := New_Copy_Tree (Low);
1216             end if;
1217
1218             if Is_Entity_Name (High)
1219               and then Ekind (Entity (High)) = E_Discriminant
1220             then
1221                High := Make_Identifier (Loc, Chars (High));
1222             else
1223                High := New_Copy_Tree (High);
1224             end if;
1225
1226             return
1227               Make_Range (Loc,
1228                 Low_Bound  => Low,
1229                 High_Bound => High);
1230          end Build_Range;
1231
1232       --  Start of processing for Build_Entry_Family_Name
1233
1234       begin
1235          Get_Name_String (Chars (Id));
1236
1237          --  Add a leading '('
1238
1239          Add_Char_To_Name_Buffer ('(');
1240
1241          --  Generate:
1242          --    new String'("<Entry name>(" & Lnn'Img & ")");
1243
1244          --  This is an implicit heap allocation, and Comes_From_Source is
1245          --  False, which ensures that it will get flagged as a violation of
1246          --  No_Implicit_Heap_Allocations when that restriction applies.
1247
1248          Val :=
1249            Make_Allocator (Loc,
1250              Make_Qualified_Expression (Loc,
1251                Subtype_Mark =>
1252                  New_Reference_To (Standard_String, Loc),
1253                Expression =>
1254                  Make_Op_Concat (Loc,
1255                    Left_Opnd =>
1256                      Make_Op_Concat (Loc,
1257                        Left_Opnd =>
1258                          Make_String_Literal (Loc,
1259                            Strval => String_From_Name_Buffer),
1260                        Right_Opnd =>
1261                          Make_Attribute_Reference (Loc,
1262                            Prefix =>
1263                              New_Reference_To (L_Id, Loc),
1264                                Attribute_Name => Name_Img)),
1265                    Right_Opnd =>
1266                      Make_String_Literal (Loc,
1267                        Strval => ")"))));
1268
1269          Increment_Index (L_Stmts);
1270          Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
1271
1272          --  Generate:
1273          --    for Lnn in Family_Low .. Family_High loop
1274          --       Inn := Inn + 1;
1275          --       Set_Entry_Name
1276          --         (_init._object <or> _init._task_id, Inn, <Val>);
1277          --    end loop;
1278
1279          Append_To (B_Stmts,
1280            Make_Loop_Statement (Loc,
1281              Iteration_Scheme =>
1282                Make_Iteration_Scheme (Loc,
1283                  Loop_Parameter_Specification =>
1284                    Make_Loop_Parameter_Specification (Loc,
1285                     Defining_Identifier         => L_Id,
1286                     Discrete_Subtype_Definition => Build_Range (Def))),
1287              Statements => L_Stmts,
1288              End_Label => Empty));
1289       end Build_Entry_Family_Name;
1290
1291       ----------------------
1292       -- Build_Entry_Name --
1293       ----------------------
1294
1295       procedure Build_Entry_Name (Id : Entity_Id) is
1296          Val : Node_Id;
1297
1298       begin
1299          Get_Name_String (Chars (Id));
1300
1301          --  This is an implicit heap allocation, and Comes_From_Source is
1302          --  False, which ensures that it will get flagged as a violation of
1303          --  No_Implicit_Heap_Allocations when that restriction applies.
1304
1305          Val :=
1306            Make_Allocator (Loc,
1307              Make_Qualified_Expression (Loc,
1308                Subtype_Mark =>
1309                  New_Reference_To (Standard_String, Loc),
1310                Expression =>
1311                  Make_String_Literal (Loc,
1312                    String_From_Name_Buffer)));
1313
1314          Increment_Index (B_Stmts);
1315          Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val));
1316       end Build_Entry_Name;
1317
1318       -------------------------------
1319       -- Build_Set_Entry_Name_Call --
1320       -------------------------------
1321
1322       function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is
1323          Arg1 : Name_Id;
1324          Proc : RE_Id;
1325
1326       begin
1327          --  Determine the proper name for the first argument and the RTS
1328          --  routine to call.
1329
1330          if Is_Protected_Type (Typ) then
1331             Arg1 := Name_uObject;
1332             Proc := RO_PE_Set_Entry_Name;
1333
1334          else pragma Assert (Is_Task_Type (Typ));
1335             Arg1 := Name_uTask_Id;
1336             Proc := RO_TS_Set_Entry_Name;
1337          end if;
1338
1339          --  Generate:
1340          --    Set_Entry_Name (_init.Arg1, Inn, Arg3);
1341
1342          return
1343            Make_Procedure_Call_Statement (Loc,
1344              Name =>
1345                New_Reference_To (RTE (Proc), Loc),
1346              Parameter_Associations => New_List (
1347                Make_Selected_Component (Loc,              --  _init._object
1348                  Prefix =>                                --  _init._task_id
1349                    Make_Identifier (Loc, Name_uInit),
1350                  Selector_Name =>
1351                    Make_Identifier (Loc, Arg1)),
1352                New_Reference_To (Index, Loc),             --  Inn
1353                Arg3));                                    --  Val
1354       end Build_Set_Entry_Name_Call;
1355
1356       --------------------------
1357       -- Find_Protection_Type --
1358       --------------------------
1359
1360       function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
1361          Comp : Entity_Id;
1362          Typ  : Entity_Id := Conc_Typ;
1363
1364       begin
1365          if Is_Concurrent_Type (Typ) then
1366             Typ := Corresponding_Record_Type (Typ);
1367          end if;
1368
1369          Comp := First_Component (Typ);
1370          while Present (Comp) loop
1371             if Chars (Comp) = Name_uObject then
1372                return Base_Type (Etype (Comp));
1373             end if;
1374
1375             Next_Component (Comp);
1376          end loop;
1377
1378          --  The corresponding record of a protected type should always have an
1379          --  _object field.
1380
1381          raise Program_Error;
1382       end Find_Protection_Type;
1383
1384       ---------------------
1385       -- Increment_Index --
1386       ---------------------
1387
1388       procedure Increment_Index (Stmts : List_Id) is
1389       begin
1390          --  Generate:
1391          --    Inn := Inn + 1;
1392
1393          Append_To (Stmts,
1394            Make_Assignment_Statement (Loc,
1395              Name =>
1396                New_Reference_To (Index, Loc),
1397              Expression =>
1398                Make_Op_Add (Loc,
1399                  Left_Opnd =>
1400                    New_Reference_To (Index, Loc),
1401                  Right_Opnd =>
1402                    Make_Integer_Literal (Loc, 1))));
1403       end Increment_Index;
1404
1405    --  Start of processing for Build_Entry_Names
1406
1407    begin
1408       --  Retrieve the original concurrent type
1409
1410       if Is_Concurrent_Record_Type (Typ) then
1411          Typ := Corresponding_Concurrent_Type (Typ);
1412       end if;
1413
1414       pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
1415
1416       --  Nothing to do if the type has no entries
1417
1418       if not Has_Entries (Typ) then
1419          return Empty;
1420       end if;
1421
1422       --  Avoid generating entry names for a protected type with only one entry
1423
1424       if Is_Protected_Type (Typ)
1425         and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries)
1426       then
1427          return Empty;
1428       end if;
1429
1430       Index := Make_Temporary (Loc, 'I');
1431
1432       --  Step 1: Generate the declaration of the index variable:
1433       --    Inn : Protected_Entry_Index := 0;
1434       --      or
1435       --    Inn : Task_Entry_Index := 0;
1436
1437       if Is_Protected_Type (Typ) then
1438          Index_Typ := RE_Protected_Entry_Index;
1439       else
1440          Index_Typ := RE_Task_Entry_Index;
1441       end if;
1442
1443       B_Decls := New_List;
1444       Append_To (B_Decls,
1445         Make_Object_Declaration (Loc,
1446           Defining_Identifier => Index,
1447           Object_Definition   => New_Reference_To (RTE (Index_Typ), Loc),
1448           Expression          => Make_Integer_Literal (Loc, 0)));
1449
1450       B_Stmts := New_List;
1451
1452       --  Step 2: Generate a call to Set_Entry_Name for each entry and entry
1453       --  family member.
1454
1455       Comp := First_Entity (Typ);
1456       while Present (Comp) loop
1457          if Ekind (Comp) = E_Entry then
1458             Build_Entry_Name (Comp);
1459
1460          elsif Ekind (Comp) = E_Entry_Family then
1461             Build_Entry_Family_Name (Comp);
1462          end if;
1463
1464          Next_Entity (Comp);
1465       end loop;
1466
1467       --  Step 3: Wrap the statements in a block
1468
1469       return
1470         Make_Block_Statement (Loc,
1471           Declarations => B_Decls,
1472           Handled_Statement_Sequence =>
1473             Make_Handled_Sequence_Of_Statements (Loc,
1474               Statements => B_Stmts));
1475    end Build_Entry_Names;
1476
1477    ---------------------------
1478    -- Build_Parameter_Block --
1479    ---------------------------
1480
1481    function Build_Parameter_Block
1482      (Loc     : Source_Ptr;
1483       Actuals : List_Id;
1484       Formals : List_Id;
1485       Decls   : List_Id) return Entity_Id
1486    is
1487       Actual   : Entity_Id;
1488       Comp_Nam : Node_Id;
1489       Comps    : List_Id;
1490       Formal   : Entity_Id;
1491       Has_Comp : Boolean := False;
1492       Rec_Nam  : Node_Id;
1493
1494    begin
1495       Actual := First (Actuals);
1496       Comps  := New_List;
1497       Formal := Defining_Identifier (First (Formals));
1498
1499       while Present (Actual) loop
1500          if not Is_Controlling_Actual (Actual) then
1501
1502             --  Generate:
1503             --    type Ann is access all <actual-type>
1504
1505             Comp_Nam := Make_Temporary (Loc, 'A');
1506
1507             Append_To (Decls,
1508               Make_Full_Type_Declaration (Loc,
1509                 Defining_Identifier => Comp_Nam,
1510                 Type_Definition     =>
1511                   Make_Access_To_Object_Definition (Loc,
1512                     All_Present        => True,
1513                     Constant_Present   => Ekind (Formal) = E_In_Parameter,
1514                     Subtype_Indication =>
1515                       New_Reference_To (Etype (Actual), Loc))));
1516
1517             --  Generate:
1518             --    Param : Ann;
1519
1520             Append_To (Comps,
1521               Make_Component_Declaration (Loc,
1522                 Defining_Identifier =>
1523                   Make_Defining_Identifier (Loc, Chars (Formal)),
1524                 Component_Definition =>
1525                   Make_Component_Definition (Loc,
1526                     Aliased_Present =>
1527                       False,
1528                     Subtype_Indication =>
1529                       New_Reference_To (Comp_Nam, Loc))));
1530
1531             Has_Comp := True;
1532          end if;
1533
1534          Next_Actual (Actual);
1535          Next_Formal_With_Extras (Formal);
1536       end loop;
1537
1538       Rec_Nam := Make_Temporary (Loc, 'P');
1539
1540       if Has_Comp then
1541
1542          --  Generate:
1543          --    type Pnn is record
1544          --       Param1 : Ann1;
1545          --       ...
1546          --       ParamN : AnnN;
1547
1548          --  where Pnn is a parameter wrapping record, Param1 .. ParamN are
1549          --  the original parameter names and Ann1 .. AnnN are the access to
1550          --  actual types.
1551
1552          Append_To (Decls,
1553            Make_Full_Type_Declaration (Loc,
1554              Defining_Identifier =>
1555                Rec_Nam,
1556              Type_Definition =>
1557                Make_Record_Definition (Loc,
1558                  Component_List =>
1559                    Make_Component_List (Loc, Comps))));
1560       else
1561          --  Generate:
1562          --    type Pnn is null record;
1563
1564          Append_To (Decls,
1565            Make_Full_Type_Declaration (Loc,
1566              Defining_Identifier =>
1567                Rec_Nam,
1568              Type_Definition =>
1569                Make_Record_Definition (Loc,
1570                  Null_Present   => True,
1571                  Component_List => Empty)));
1572       end if;
1573
1574       return Rec_Nam;
1575    end Build_Parameter_Block;
1576
1577    -----------------------
1578    -- Build_PPC_Wrapper --
1579    -----------------------
1580
1581    procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id) is
1582       Loc        : constant Source_Ptr := Sloc (E);
1583       Synch_Type : constant Entity_Id := Scope (E);
1584
1585       Wrapper_Id : constant Entity_Id :=
1586                      Make_Defining_Identifier (Loc,
1587                        Chars => New_External_Name (Chars (E), 'E'));
1588       --  the wrapper procedure name
1589
1590       Wrapper_Body : Node_Id;
1591
1592       Synch_Id : constant Entity_Id :=
1593                    Make_Defining_Identifier (Loc,
1594                      Chars => New_External_Name (Chars (Scope (E)), 'A'));
1595       --  The parameter that designates the synchronized object in the call
1596
1597       Actuals : constant List_Id := New_List;
1598       --  the actuals in the entry call.
1599
1600       Decls : constant List_Id := New_List;
1601
1602       Entry_Call : Node_Id;
1603       Entry_Name : Node_Id;
1604
1605       Specs : List_Id;
1606       --  The specification of the wrapper procedure
1607
1608    begin
1609
1610       --  Only build the wrapper if entry has pre/postconditions.
1611       --  Should this be done unconditionally instead ???
1612
1613       declare
1614          P : Node_Id;
1615
1616       begin
1617          P := Spec_PPC_List (E);
1618          if No (P) then
1619             return;
1620          end if;
1621
1622          --  Transfer ppc pragmas to the declarations of the wrapper
1623
1624          while Present (P) loop
1625             if Pragma_Name (P) = Name_Precondition
1626               or else Pragma_Name (P) = Name_Postcondition
1627             then
1628                Append (Relocate_Node (P), Decls);
1629                Set_Analyzed (Last (Decls), False);
1630             end if;
1631
1632             P := Next_Pragma (P);
1633          end loop;
1634       end;
1635
1636       --  First formal is synchronized object
1637
1638       Specs := New_List (
1639         Make_Parameter_Specification (Loc,
1640           Defining_Identifier => Synch_Id,
1641           Out_Present         =>  True,
1642           In_Present          =>  True,
1643           Parameter_Type      => New_Occurrence_Of (Scope (E), Loc)));
1644
1645       Entry_Name :=
1646         Make_Selected_Component (Loc,
1647           Prefix        => New_Occurrence_Of (Synch_Id, Loc),
1648           Selector_Name => New_Occurrence_Of (E, Loc));
1649
1650       --  If entity is entry family, second formal is the corresponding index,
1651       --  and entry name is an indexed component.
1652
1653       if Ekind (E) = E_Entry_Family then
1654          declare
1655             Index : constant Entity_Id :=
1656                       Make_Defining_Identifier (Loc, Name_I);
1657          begin
1658             Append_To (Specs,
1659               Make_Parameter_Specification (Loc,
1660                 Defining_Identifier => Index,
1661                 Parameter_Type      =>
1662                   New_Occurrence_Of (Entry_Index_Type (E), Loc)));
1663
1664             Entry_Name :=
1665               Make_Indexed_Component (Loc,
1666                 Prefix      => Entry_Name,
1667                 Expressions => New_List (New_Occurrence_Of (Index, Loc)));
1668          end;
1669       end if;
1670
1671       Entry_Call :=
1672         Make_Procedure_Call_Statement (Loc,
1673           Name                   => Entry_Name,
1674           Parameter_Associations => Actuals);
1675
1676       --  Now add formals that match those of the entry, and build actuals for
1677       --  the nested entry call.
1678
1679       declare
1680          Form      : Entity_Id;
1681          New_Form  : Entity_Id;
1682          Parm_Spec : Node_Id;
1683
1684       begin
1685          Form := First_Formal (E);
1686          while Present (Form) loop
1687             New_Form := Make_Defining_Identifier (Loc, Chars (Form));
1688             Parm_Spec :=
1689               Make_Parameter_Specification (Loc,
1690                 Defining_Identifier => New_Form,
1691                 Out_Present         => Out_Present (Parent (Form)),
1692                 In_Present          => In_Present  (Parent (Form)),
1693                 Parameter_Type      => New_Occurrence_Of (Etype (Form), Loc));
1694
1695             Append (Parm_Spec, Specs);
1696             Append (New_Occurrence_Of (New_Form, Loc), Actuals);
1697             Next_Formal (Form);
1698          end loop;
1699       end;
1700
1701       --  Add renaming declarations for the discriminants of the enclosing
1702       --  type, which may be visible in the preconditions.
1703
1704       if Has_Discriminants (Synch_Type) then
1705          declare
1706             D : Entity_Id;
1707             Decl : Node_Id;
1708
1709          begin
1710             D := First_Discriminant (Synch_Type);
1711             while Present (D) loop
1712                Decl :=
1713                  Make_Object_Renaming_Declaration (Loc,
1714                    Defining_Identifier =>
1715                      Make_Defining_Identifier (Loc, Chars (D)),
1716                    Subtype_Mark        => New_Reference_To (Etype (D), Loc),
1717                    Name                =>
1718                      Make_Selected_Component (Loc,
1719                        Prefix        => New_Reference_To (Synch_Id, Loc),
1720                        Selector_Name => Make_Identifier (Loc, Chars (D))));
1721                Prepend (Decl, Decls);
1722                Next_Discriminant (D);
1723             end loop;
1724          end;
1725       end if;
1726
1727       Set_PPC_Wrapper (E, Wrapper_Id);
1728       Wrapper_Body :=
1729         Make_Subprogram_Body (Loc,
1730           Specification              =>
1731             Make_Procedure_Specification (Loc,
1732               Defining_Unit_Name       => Wrapper_Id,
1733               Parameter_Specifications => Specs),
1734           Declarations               => Decls,
1735           Handled_Statement_Sequence =>
1736             Make_Handled_Sequence_Of_Statements (Loc,
1737               Statements => New_List (Entry_Call)));
1738
1739       --  The wrapper body is analyzed when the enclosing type is frozen
1740
1741       Append_Freeze_Action (Defining_Entity (Decl), Wrapper_Body);
1742    end Build_PPC_Wrapper;
1743
1744    --------------------------
1745    -- Build_Wrapper_Bodies --
1746    --------------------------
1747
1748    procedure Build_Wrapper_Bodies
1749      (Loc : Source_Ptr;
1750       Typ : Entity_Id;
1751       N   : Node_Id)
1752    is
1753       Rec_Typ : Entity_Id;
1754
1755       function Build_Wrapper_Body
1756         (Loc     : Source_Ptr;
1757          Subp_Id : Entity_Id;
1758          Obj_Typ : Entity_Id;
1759          Formals : List_Id) return Node_Id;
1760       --  Ada 2005 (AI-345): Build the body that wraps a primitive operation
1761       --  associated with a protected or task type. Subp_Id is the subprogram
1762       --  name which will be wrapped. Obj_Typ is the type of the new formal
1763       --  parameter which handles dispatching and object notation. Formals are
1764       --  the original formals of Subp_Id which will be explicitly replicated.
1765
1766       ------------------------
1767       -- Build_Wrapper_Body --
1768       ------------------------
1769
1770       function Build_Wrapper_Body
1771         (Loc     : Source_Ptr;
1772          Subp_Id : Entity_Id;
1773          Obj_Typ : Entity_Id;
1774          Formals : List_Id) return Node_Id
1775       is
1776          Body_Spec : Node_Id;
1777
1778       begin
1779          Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals);
1780
1781          --  The subprogram is not overriding or is not a primitive declared
1782          --  between two views.
1783
1784          if No (Body_Spec) then
1785             return Empty;
1786          end if;
1787
1788          declare
1789             Actuals    : List_Id := No_List;
1790             Conv_Id    : Node_Id;
1791             First_Form : Node_Id;
1792             Formal     : Node_Id;
1793             Nam        : Node_Id;
1794
1795          begin
1796             --  Map formals to actuals. Use the list built for the wrapper
1797             --  spec, skipping the object notation parameter.
1798
1799             First_Form := First (Parameter_Specifications (Body_Spec));
1800
1801             Formal := First_Form;
1802             Next (Formal);
1803
1804             if Present (Formal) then
1805                Actuals := New_List;
1806                while Present (Formal) loop
1807                   Append_To (Actuals,
1808                     Make_Identifier (Loc,
1809                       Chars => Chars (Defining_Identifier (Formal))));
1810                   Next (Formal);
1811                end loop;
1812             end if;
1813
1814             --  Special processing for primitives declared between a private
1815             --  type and its completion: the wrapper needs a properly typed
1816             --  parameter if the wrapped operation has a controlling first
1817             --  parameter. Note that this might not be the case for a function
1818             --  with a controlling result.
1819
1820             if Is_Private_Primitive_Subprogram (Subp_Id) then
1821                if No (Actuals) then
1822                   Actuals := New_List;
1823                end if;
1824
1825                if Is_Controlling_Formal (First_Formal (Subp_Id)) then
1826                   Prepend_To (Actuals,
1827                     Unchecked_Convert_To
1828                       (Corresponding_Concurrent_Type (Obj_Typ),
1829                        Make_Identifier (Loc, Name_uO)));
1830
1831                else
1832                   Prepend_To (Actuals,
1833                     Make_Identifier (Loc,
1834                       Chars => Chars (Defining_Identifier (First_Form))));
1835                end if;
1836
1837                Nam := New_Reference_To (Subp_Id, Loc);
1838             else
1839                --  An access-to-variable object parameter requires an explicit
1840                --  dereference in the unchecked conversion. This case occurs
1841                --  when a protected entry wrapper must override an interface
1842                --  level procedure with interface access as first parameter.
1843
1844                --     O.all.Subp_Id (Formal_1, ..., Formal_N)
1845
1846                if Nkind (Parameter_Type (First_Form)) =
1847                     N_Access_Definition
1848                then
1849                   Conv_Id :=
1850                     Make_Explicit_Dereference (Loc,
1851                       Prefix => Make_Identifier (Loc, Name_uO));
1852                else
1853                   Conv_Id := Make_Identifier (Loc, Name_uO);
1854                end if;
1855
1856                Nam :=
1857                  Make_Selected_Component (Loc,
1858                    Prefix        =>
1859                      Unchecked_Convert_To
1860                        (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id),
1861                    Selector_Name => New_Reference_To (Subp_Id, Loc));
1862             end if;
1863
1864             --  Create the subprogram body. For a function, the call to the
1865             --  actual subprogram has to be converted to the corresponding
1866             --  record if it is a controlling result.
1867
1868             if Ekind (Subp_Id) = E_Function then
1869                declare
1870                   Res : Node_Id;
1871
1872                begin
1873                   Res :=
1874                      Make_Function_Call (Loc,
1875                        Name                   => Nam,
1876                        Parameter_Associations => Actuals);
1877
1878                   if Has_Controlling_Result (Subp_Id) then
1879                      Res :=
1880                        Unchecked_Convert_To
1881                          (Corresponding_Record_Type (Etype (Subp_Id)), Res);
1882                   end if;
1883
1884                   return
1885                     Make_Subprogram_Body (Loc,
1886                       Specification              => Body_Spec,
1887                       Declarations               => Empty_List,
1888                       Handled_Statement_Sequence =>
1889                         Make_Handled_Sequence_Of_Statements (Loc,
1890                           Statements => New_List (
1891                             Make_Simple_Return_Statement (Loc, Res))));
1892                end;
1893
1894             else
1895                return
1896                  Make_Subprogram_Body (Loc,
1897                    Specification              => Body_Spec,
1898                    Declarations               => Empty_List,
1899                    Handled_Statement_Sequence =>
1900                      Make_Handled_Sequence_Of_Statements (Loc,
1901                        Statements => New_List (
1902                          Make_Procedure_Call_Statement (Loc,
1903                            Name                   => Nam,
1904                            Parameter_Associations => Actuals))));
1905             end if;
1906          end;
1907       end Build_Wrapper_Body;
1908
1909    --  Start of processing for Build_Wrapper_Bodies
1910
1911    begin
1912       if Is_Concurrent_Type (Typ) then
1913          Rec_Typ := Corresponding_Record_Type (Typ);
1914       else
1915          Rec_Typ := Typ;
1916       end if;
1917
1918       --  Generate wrapper bodies for a concurrent type which implements an
1919       --  interface.
1920
1921       if Present (Interfaces (Rec_Typ)) then
1922          declare
1923             Insert_Nod : Node_Id;
1924             Prim       : Entity_Id;
1925             Prim_Elmt  : Elmt_Id;
1926             Prim_Decl  : Node_Id;
1927             Subp       : Entity_Id;
1928             Wrap_Body  : Node_Id;
1929             Wrap_Id    : Entity_Id;
1930
1931          begin
1932             Insert_Nod := N;
1933
1934             --  Examine all primitive operations of the corresponding record
1935             --  type, looking for wrapper specs. Generate bodies in order to
1936             --  complete them.
1937
1938             Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ));
1939             while Present (Prim_Elmt) loop
1940                Prim := Node (Prim_Elmt);
1941
1942                if (Ekind (Prim) = E_Function
1943                      or else Ekind (Prim) = E_Procedure)
1944                  and then Is_Primitive_Wrapper (Prim)
1945                then
1946                   Subp := Wrapped_Entity (Prim);
1947                   Prim_Decl := Parent (Parent (Prim));
1948
1949                   Wrap_Body :=
1950                     Build_Wrapper_Body (Loc,
1951                       Subp_Id => Subp,
1952                       Obj_Typ => Rec_Typ,
1953                       Formals => Parameter_Specifications (Parent (Subp)));
1954                   Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body));
1955
1956                   Set_Corresponding_Spec (Wrap_Body, Prim);
1957                   Set_Corresponding_Body (Prim_Decl, Wrap_Id);
1958
1959                   Insert_After (Insert_Nod, Wrap_Body);
1960                   Insert_Nod := Wrap_Body;
1961
1962                   Analyze (Wrap_Body);
1963                end if;
1964
1965                Next_Elmt (Prim_Elmt);
1966             end loop;
1967          end;
1968       end if;
1969    end Build_Wrapper_Bodies;
1970
1971    ------------------------
1972    -- Build_Wrapper_Spec --
1973    ------------------------
1974
1975    function Build_Wrapper_Spec
1976      (Subp_Id : Entity_Id;
1977       Obj_Typ : Entity_Id;
1978       Formals : List_Id) return Node_Id
1979    is
1980       Loc           : constant Source_Ptr := Sloc (Subp_Id);
1981       First_Param   : Node_Id;
1982       Iface         : Entity_Id;
1983       Iface_Elmt    : Elmt_Id;
1984       Iface_Op      : Entity_Id;
1985       Iface_Op_Elmt : Elmt_Id;
1986
1987       function Overriding_Possible
1988         (Iface_Op : Entity_Id;
1989          Wrapper  : Entity_Id) return Boolean;
1990       --  Determine whether a primitive operation can be overridden by Wrapper.
1991       --  Iface_Op is the candidate primitive operation of an interface type,
1992       --  Wrapper is the generated entry wrapper.
1993
1994       function Replicate_Formals
1995         (Loc     : Source_Ptr;
1996          Formals : List_Id) return List_Id;
1997       --  An explicit parameter replication is required due to the Is_Entry_
1998       --  Formal flag being set for all the formals of an entry. The explicit
1999       --  replication removes the flag that would otherwise cause a different
2000       --  path of analysis.
2001
2002       -------------------------
2003       -- Overriding_Possible --
2004       -------------------------
2005
2006       function Overriding_Possible
2007         (Iface_Op : Entity_Id;
2008          Wrapper  : Entity_Id) return Boolean
2009       is
2010          Iface_Op_Spec : constant Node_Id := Parent (Iface_Op);
2011          Wrapper_Spec  : constant Node_Id := Parent (Wrapper);
2012
2013          function Type_Conformant_Parameters
2014            (Iface_Op_Params : List_Id;
2015             Wrapper_Params  : List_Id) return Boolean;
2016          --  Determine whether the parameters of the generated entry wrapper
2017          --  and those of a primitive operation are type conformant. During
2018          --  this check, the first parameter of the primitive operation is
2019          --  skipped if it is a controlling argument: protected functions
2020          --  may have a controlling result.
2021
2022          --------------------------------
2023          -- Type_Conformant_Parameters --
2024          --------------------------------
2025
2026          function Type_Conformant_Parameters
2027            (Iface_Op_Params : List_Id;
2028             Wrapper_Params  : List_Id) return Boolean
2029          is
2030             Iface_Op_Param : Node_Id;
2031             Iface_Op_Typ   : Entity_Id;
2032             Wrapper_Param  : Node_Id;
2033             Wrapper_Typ    : Entity_Id;
2034
2035          begin
2036             --  Skip the first (controlling) parameter of primitive operation
2037
2038             Iface_Op_Param := First (Iface_Op_Params);
2039
2040             if Present (First_Formal (Iface_Op))
2041               and then Is_Controlling_Formal (First_Formal (Iface_Op))
2042             then
2043                Iface_Op_Param := Next (Iface_Op_Param);
2044             end if;
2045
2046             Wrapper_Param  := First (Wrapper_Params);
2047             while Present (Iface_Op_Param)
2048               and then Present (Wrapper_Param)
2049             loop
2050                Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param);
2051                Wrapper_Typ  := Find_Parameter_Type (Wrapper_Param);
2052
2053                --  The two parameters must be mode conformant
2054
2055                if not Conforming_Types
2056                         (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant)
2057                then
2058                   return False;
2059                end if;
2060
2061                Next (Iface_Op_Param);
2062                Next (Wrapper_Param);
2063             end loop;
2064
2065             --  One of the lists is longer than the other
2066
2067             if Present (Iface_Op_Param) or else Present (Wrapper_Param) then
2068                return False;
2069             end if;
2070
2071             return True;
2072          end Type_Conformant_Parameters;
2073
2074       --  Start of processing for Overriding_Possible
2075
2076       begin
2077          if Chars (Iface_Op) /= Chars (Wrapper) then
2078             return False;
2079          end if;
2080
2081          --  If an inherited subprogram is implemented by a protected procedure
2082          --  or an entry, then the first parameter of the inherited subprogram
2083          --  shall be of mode OUT or IN OUT, or access-to-variable parameter.
2084
2085          if Ekind (Iface_Op) = E_Procedure
2086            and then Present (Parameter_Specifications (Iface_Op_Spec))
2087          then
2088             declare
2089                Obj_Param : constant Node_Id :=
2090                              First (Parameter_Specifications (Iface_Op_Spec));
2091             begin
2092                if not Out_Present (Obj_Param)
2093                  and then Nkind (Parameter_Type (Obj_Param)) /=
2094                                                          N_Access_Definition
2095                then
2096                   return False;
2097                end if;
2098             end;
2099          end if;
2100
2101          return
2102            Type_Conformant_Parameters (
2103              Parameter_Specifications (Iface_Op_Spec),
2104              Parameter_Specifications (Wrapper_Spec));
2105       end Overriding_Possible;
2106
2107       -----------------------
2108       -- Replicate_Formals --
2109       -----------------------
2110
2111       function Replicate_Formals
2112         (Loc     : Source_Ptr;
2113          Formals : List_Id) return List_Id
2114       is
2115          New_Formals : constant List_Id := New_List;
2116          Formal      : Node_Id;
2117          Param_Type  : Node_Id;
2118
2119       begin
2120          Formal := First (Formals);
2121
2122          --  Skip the object parameter when dealing with primitives declared
2123          --  between two views.
2124
2125          if Is_Private_Primitive_Subprogram (Subp_Id)
2126            and then not Has_Controlling_Result (Subp_Id)
2127          then
2128             Formal := Next (Formal);
2129          end if;
2130
2131          while Present (Formal) loop
2132
2133             --  Create an explicit copy of the entry parameter
2134
2135             --  When creating the wrapper subprogram for a primitive operation
2136             --  of a protected interface we must construct an equivalent
2137             --  signature to that of the overriding operation. For regular
2138             --  parameters we can just use the type of the formal, but for
2139             --  access to subprogram parameters we need to reanalyze the
2140             --  parameter type to create local entities for the signature of
2141             --  the subprogram type. Using the entities of the overriding
2142             --  subprogram will result in out-of-scope errors in the back-end.
2143
2144             if Nkind (Parameter_Type (Formal)) = N_Access_Definition then
2145                Param_Type := Copy_Separate_Tree (Parameter_Type (Formal));
2146             else
2147                Param_Type :=
2148                  New_Reference_To (Etype (Parameter_Type (Formal)), Loc);
2149             end if;
2150
2151             Append_To (New_Formals,
2152               Make_Parameter_Specification (Loc,
2153                 Defining_Identifier =>
2154                   Make_Defining_Identifier (Loc,
2155                     Chars          => Chars (Defining_Identifier (Formal))),
2156                     In_Present     => In_Present  (Formal),
2157                     Out_Present    => Out_Present (Formal),
2158                     Parameter_Type => Param_Type));
2159
2160             Next (Formal);
2161          end loop;
2162
2163          return New_Formals;
2164       end Replicate_Formals;
2165
2166    --  Start of processing for Build_Wrapper_Spec
2167
2168    begin
2169       --  There is no point in building wrappers for non-tagged concurrent
2170       --  types.
2171
2172       pragma Assert (Is_Tagged_Type (Obj_Typ));
2173
2174       --  An entry or a protected procedure can override a routine where the
2175       --  controlling formal is either IN OUT, OUT or is of access-to-variable
2176       --  type. Since the wrapper must have the exact same signature as that of
2177       --  the overridden subprogram, we try to find the overriding candidate
2178       --  and use its controlling formal.
2179
2180       First_Param := Empty;
2181
2182       --  Check every implemented interface
2183
2184       if Present (Interfaces (Obj_Typ)) then
2185          Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
2186          Search : while Present (Iface_Elmt) loop
2187             Iface := Node (Iface_Elmt);
2188
2189             --  Check every interface primitive
2190
2191             if Present (Primitive_Operations (Iface)) then
2192                Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
2193                while Present (Iface_Op_Elmt) loop
2194                   Iface_Op := Node (Iface_Op_Elmt);
2195
2196                   --  Ignore predefined primitives
2197
2198                   if not Is_Predefined_Dispatching_Operation (Iface_Op) then
2199                      Iface_Op := Ultimate_Alias (Iface_Op);
2200
2201                      --  The current primitive operation can be overridden by
2202                      --  the generated entry wrapper.
2203
2204                      if Overriding_Possible (Iface_Op, Subp_Id) then
2205                         First_Param :=
2206                           First (Parameter_Specifications (Parent (Iface_Op)));
2207
2208                         exit Search;
2209                      end if;
2210                   end if;
2211
2212                   Next_Elmt (Iface_Op_Elmt);
2213                end loop;
2214             end if;
2215
2216             Next_Elmt (Iface_Elmt);
2217          end loop Search;
2218       end if;
2219
2220       --  If the subprogram to be wrapped is not overriding anything or is not
2221       --  a primitive declared between two views, do not produce anything. This
2222       --  avoids spurious errors involving overriding.
2223
2224       if No (First_Param)
2225         and then not Is_Private_Primitive_Subprogram (Subp_Id)
2226       then
2227          return Empty;
2228       end if;
2229
2230       declare
2231          Wrapper_Id    : constant Entity_Id :=
2232                            Make_Defining_Identifier (Loc, Chars (Subp_Id));
2233          New_Formals   : List_Id;
2234          Obj_Param     : Node_Id;
2235          Obj_Param_Typ : Entity_Id;
2236
2237       begin
2238          --  Minimum decoration is needed to catch the entity in
2239          --  Sem_Ch6.Override_Dispatching_Operation.
2240
2241          if Ekind (Subp_Id) = E_Function then
2242             Set_Ekind (Wrapper_Id, E_Function);
2243          else
2244             Set_Ekind (Wrapper_Id, E_Procedure);
2245          end if;
2246
2247          Set_Is_Primitive_Wrapper (Wrapper_Id);
2248          Set_Wrapped_Entity       (Wrapper_Id, Subp_Id);
2249          Set_Is_Private_Primitive (Wrapper_Id,
2250            Is_Private_Primitive_Subprogram (Subp_Id));
2251
2252          --  Process the formals
2253
2254          New_Formals := Replicate_Formals (Loc, Formals);
2255
2256          --  A function with a controlling result and no first controlling
2257          --  formal needs no additional parameter.
2258
2259          if Has_Controlling_Result (Subp_Id)
2260            and then
2261              (No (First_Formal (Subp_Id))
2262                or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
2263          then
2264             null;
2265
2266          --  Routine Subp_Id has been found to override an interface primitive.
2267          --  If the interface operation has an access parameter, create a copy
2268          --  of it, with the same null exclusion indicator if present.
2269
2270          elsif Present (First_Param) then
2271             if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
2272                Obj_Param_Typ :=
2273                  Make_Access_Definition (Loc,
2274                    Subtype_Mark =>
2275                      New_Reference_To (Obj_Typ, Loc));
2276                Set_Null_Exclusion_Present (Obj_Param_Typ,
2277                  Null_Exclusion_Present (Parameter_Type (First_Param)));
2278
2279             else
2280                Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc);
2281             end if;
2282
2283             Obj_Param :=
2284               Make_Parameter_Specification (Loc,
2285                 Defining_Identifier =>
2286                   Make_Defining_Identifier (Loc,
2287                     Chars => Name_uO),
2288                 In_Present          => In_Present  (First_Param),
2289                 Out_Present         => Out_Present (First_Param),
2290                 Parameter_Type      => Obj_Param_Typ);
2291
2292             Prepend_To (New_Formals, Obj_Param);
2293
2294          --  If we are dealing with a primitive declared between two views,
2295          --  implemented by a synchronized operation, we need to create
2296          --  a default parameter. The mode of the parameter must match that
2297          --  of the primitive operation.
2298
2299          else
2300             pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
2301             Obj_Param :=
2302               Make_Parameter_Specification (Loc,
2303                 Defining_Identifier =>
2304                   Make_Defining_Identifier (Loc, Name_uO),
2305                 In_Present  => In_Present (Parent (First_Entity (Subp_Id))),
2306                 Out_Present => Ekind (Subp_Id) /= E_Function,
2307                   Parameter_Type => New_Reference_To (Obj_Typ, Loc));
2308             Prepend_To (New_Formals, Obj_Param);
2309          end if;
2310
2311          --  Build the final spec. If it is a function with a controlling
2312          --  result, it is a primitive operation of the corresponding
2313          --  record type, so mark the spec accordingly.
2314
2315          if Ekind (Subp_Id) = E_Function then
2316             declare
2317                Res_Def : Node_Id;
2318
2319             begin
2320                if Has_Controlling_Result (Subp_Id) then
2321                   Res_Def :=
2322                     New_Occurrence_Of
2323                       (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
2324                else
2325                   Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
2326                end if;
2327
2328                return
2329                  Make_Function_Specification (Loc,
2330                    Defining_Unit_Name       => Wrapper_Id,
2331                    Parameter_Specifications => New_Formals,
2332                    Result_Definition        => Res_Def);
2333             end;
2334          else
2335             return
2336               Make_Procedure_Specification (Loc,
2337                 Defining_Unit_Name       => Wrapper_Id,
2338                 Parameter_Specifications => New_Formals);
2339          end if;
2340       end;
2341    end Build_Wrapper_Spec;
2342
2343    -------------------------
2344    -- Build_Wrapper_Specs --
2345    -------------------------
2346
2347    procedure Build_Wrapper_Specs
2348      (Loc : Source_Ptr;
2349       Typ : Entity_Id;
2350       N   : in out Node_Id)
2351    is
2352       Def     : Node_Id;
2353       Rec_Typ : Entity_Id;
2354       procedure Scan_Declarations (L : List_Id);
2355       --  Common processing for visible and private declarations
2356       --  of a protected type.
2357
2358       procedure Scan_Declarations (L : List_Id) is
2359          Decl      : Node_Id;
2360          Wrap_Decl : Node_Id;
2361          Wrap_Spec : Node_Id;
2362
2363       begin
2364          if No (L) then
2365             return;
2366          end if;
2367
2368          Decl := First (L);
2369          while Present (Decl) loop
2370             Wrap_Spec := Empty;
2371
2372             if Nkind (Decl) = N_Entry_Declaration
2373               and then Ekind (Defining_Identifier (Decl)) = E_Entry
2374             then
2375                Wrap_Spec :=
2376                  Build_Wrapper_Spec
2377                    (Subp_Id => Defining_Identifier (Decl),
2378                     Obj_Typ => Rec_Typ,
2379                     Formals => Parameter_Specifications (Decl));
2380
2381             elsif Nkind (Decl) = N_Subprogram_Declaration then
2382                Wrap_Spec :=
2383                  Build_Wrapper_Spec
2384                    (Subp_Id => Defining_Unit_Name (Specification (Decl)),
2385                     Obj_Typ => Rec_Typ,
2386                     Formals =>
2387                       Parameter_Specifications (Specification (Decl)));
2388             end if;
2389
2390             if Present (Wrap_Spec) then
2391                Wrap_Decl :=
2392                  Make_Subprogram_Declaration (Loc,
2393                    Specification => Wrap_Spec);
2394
2395                Insert_After (N, Wrap_Decl);
2396                N := Wrap_Decl;
2397
2398                Analyze (Wrap_Decl);
2399             end if;
2400
2401             Next (Decl);
2402          end loop;
2403       end Scan_Declarations;
2404
2405       --  start of processing for Build_Wrapper_Specs
2406
2407    begin
2408       if Is_Protected_Type (Typ) then
2409          Def := Protected_Definition (Parent (Typ));
2410       else pragma Assert (Is_Task_Type (Typ));
2411          Def := Task_Definition (Parent (Typ));
2412       end if;
2413
2414       Rec_Typ := Corresponding_Record_Type (Typ);
2415
2416       --  Generate wrapper specs for a concurrent type which implements an
2417       --  interface. Operations in both the visible and private parts may
2418       --  implement progenitor operations.
2419
2420       if Present (Interfaces (Rec_Typ))
2421         and then Present (Def)
2422       then
2423          Scan_Declarations (Visible_Declarations (Def));
2424          Scan_Declarations (Private_Declarations (Def));
2425       end if;
2426    end Build_Wrapper_Specs;
2427
2428    ---------------------------
2429    -- Build_Find_Body_Index --
2430    ---------------------------
2431
2432    function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
2433       Loc   : constant Source_Ptr := Sloc (Typ);
2434       Ent   : Entity_Id;
2435       E_Typ : Entity_Id;
2436       Has_F : Boolean := False;
2437       Index : Nat;
2438       If_St : Node_Id := Empty;
2439       Lo    : Node_Id;
2440       Hi    : Node_Id;
2441       Decls : List_Id := New_List;
2442       Ret   : Node_Id;
2443       Spec  : Node_Id;
2444       Siz   : Node_Id := Empty;
2445
2446       procedure Add_If_Clause (Expr : Node_Id);
2447       --  Add test for range of current entry
2448
2449       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
2450       --  If a bound of an entry is given by a discriminant, retrieve the
2451       --  actual value of the discriminant from the enclosing object.
2452
2453       -------------------
2454       -- Add_If_Clause --
2455       -------------------
2456
2457       procedure Add_If_Clause (Expr : Node_Id) is
2458          Cond  : Node_Id;
2459          Stats : constant List_Id :=
2460                    New_List (
2461                      Make_Simple_Return_Statement (Loc,
2462                        Expression => Make_Integer_Literal (Loc, Index + 1)));
2463
2464       begin
2465          --  Index for current entry body
2466
2467          Index := Index + 1;
2468
2469          --  Compute total length of entry queues so far
2470
2471          if No (Siz) then
2472             Siz := Expr;
2473          else
2474             Siz :=
2475               Make_Op_Add (Loc,
2476                 Left_Opnd => Siz,
2477                 Right_Opnd => Expr);
2478          end if;
2479
2480          Cond :=
2481            Make_Op_Le (Loc,
2482              Left_Opnd  => Make_Identifier (Loc, Name_uE),
2483              Right_Opnd => Siz);
2484
2485          --  Map entry queue indexes in the range of the current family
2486          --  into the current index, that designates the entry body.
2487
2488          if No (If_St) then
2489             If_St :=
2490               Make_Implicit_If_Statement (Typ,
2491                 Condition => Cond,
2492                 Then_Statements => Stats,
2493                 Elsif_Parts   => New_List);
2494
2495             Ret := If_St;
2496
2497          else
2498             Append (
2499               Make_Elsif_Part (Loc,
2500                 Condition => Cond,
2501                 Then_Statements => Stats),
2502               Elsif_Parts (If_St));
2503          end if;
2504       end Add_If_Clause;
2505
2506       ------------------------------
2507       -- Convert_Discriminant_Ref --
2508       ------------------------------
2509
2510       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
2511          B   : Node_Id;
2512
2513       begin
2514          if Is_Entity_Name (Bound)
2515            and then Ekind (Entity (Bound)) = E_Discriminant
2516          then
2517             B :=
2518               Make_Selected_Component (Loc,
2519                Prefix =>
2520                  Unchecked_Convert_To (Corresponding_Record_Type (Typ),
2521                    Make_Explicit_Dereference (Loc,
2522                      Make_Identifier (Loc, Name_uObject))),
2523                Selector_Name => Make_Identifier (Loc, Chars (Bound)));
2524             Set_Etype (B, Etype (Entity (Bound)));
2525          else
2526             B := New_Copy_Tree (Bound);
2527          end if;
2528
2529          return B;
2530       end Convert_Discriminant_Ref;
2531
2532    --  Start of processing for Build_Find_Body_Index
2533
2534    begin
2535       Spec := Build_Find_Body_Index_Spec (Typ);
2536
2537       Ent := First_Entity (Typ);
2538       while Present (Ent) loop
2539          if Ekind (Ent) = E_Entry_Family then
2540             Has_F := True;
2541             exit;
2542          end if;
2543
2544          Next_Entity (Ent);
2545       end loop;
2546
2547       if not Has_F then
2548
2549          --  If the protected type has no entry families, there is a one-one
2550          --  correspondence between entry queue and entry body.
2551
2552          Ret :=
2553            Make_Simple_Return_Statement (Loc,
2554              Expression => Make_Identifier (Loc, Name_uE));
2555
2556       else
2557          --  Suppose entries e1, e2, ... have size l1, l2, ... we generate
2558          --  the following:
2559          --
2560          --  if E <= l1 then return 1;
2561          --  elsif E <= l1 + l2 then return 2;
2562          --  ...
2563
2564          Index := 0;
2565          Siz   := Empty;
2566          Ent   := First_Entity (Typ);
2567
2568          Add_Object_Pointer (Loc, Typ, Decls);
2569
2570          while Present (Ent) loop
2571             if Ekind (Ent) = E_Entry then
2572                Add_If_Clause (Make_Integer_Literal (Loc, 1));
2573
2574             elsif Ekind (Ent) = E_Entry_Family then
2575                E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
2576                Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
2577                Lo := Convert_Discriminant_Ref (Type_Low_Bound  (E_Typ));
2578                Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
2579             end if;
2580
2581             Next_Entity (Ent);
2582          end loop;
2583
2584          if Index = 1 then
2585             Decls := New_List;
2586             Ret :=
2587               Make_Simple_Return_Statement (Loc,
2588                 Expression => Make_Integer_Literal (Loc, 1));
2589
2590          elsif Nkind (Ret) = N_If_Statement then
2591
2592             --  Ranges are in increasing order, so last one doesn't need guard
2593
2594             declare
2595                Nod : constant Node_Id := Last (Elsif_Parts (Ret));
2596             begin
2597                Remove (Nod);
2598                Set_Else_Statements (Ret, Then_Statements (Nod));
2599             end;
2600          end if;
2601       end if;
2602
2603       return
2604         Make_Subprogram_Body (Loc,
2605           Specification => Spec,
2606           Declarations  => Decls,
2607           Handled_Statement_Sequence =>
2608             Make_Handled_Sequence_Of_Statements (Loc,
2609               Statements => New_List (Ret)));
2610    end Build_Find_Body_Index;
2611
2612    --------------------------------
2613    -- Build_Find_Body_Index_Spec --
2614    --------------------------------
2615
2616    function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
2617       Loc   : constant Source_Ptr := Sloc (Typ);
2618       Id    : constant Entity_Id :=
2619                Make_Defining_Identifier (Loc,
2620                  Chars => New_External_Name (Chars (Typ), 'F'));
2621       Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
2622       Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
2623
2624    begin
2625       return
2626         Make_Function_Specification (Loc,
2627           Defining_Unit_Name => Id,
2628           Parameter_Specifications => New_List (
2629             Make_Parameter_Specification (Loc,
2630               Defining_Identifier => Parm1,
2631               Parameter_Type =>
2632                 New_Reference_To (RTE (RE_Address), Loc)),
2633
2634             Make_Parameter_Specification (Loc,
2635               Defining_Identifier => Parm2,
2636               Parameter_Type =>
2637                 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
2638           Result_Definition => New_Occurrence_Of (
2639             RTE (RE_Protected_Entry_Index), Loc));
2640    end Build_Find_Body_Index_Spec;
2641
2642    -------------------------
2643    -- Build_Master_Entity --
2644    -------------------------
2645
2646    procedure Build_Master_Entity (E : Entity_Id) is
2647       Loc  : constant Source_Ptr := Sloc (E);
2648       P    : Node_Id;
2649       Decl : Node_Id;
2650       S    : Entity_Id;
2651
2652    begin
2653       S := Find_Master_Scope (E);
2654
2655       --  Nothing to do if we already built a master entity for this scope
2656       --  or if there is no task hierarchy.
2657
2658       if Has_Master_Entity (S)
2659         or else Restriction_Active (No_Task_Hierarchy)
2660       then
2661          return;
2662       end if;
2663
2664       --  Otherwise first build the master entity
2665       --    _Master : constant Master_Id := Current_Master.all;
2666       --  and insert it just before the current declaration
2667
2668       Decl :=
2669         Make_Object_Declaration (Loc,
2670           Defining_Identifier =>
2671             Make_Defining_Identifier (Loc, Name_uMaster),
2672           Constant_Present => True,
2673           Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc),
2674           Expression =>
2675             Make_Explicit_Dereference (Loc,
2676               New_Reference_To (RTE (RE_Current_Master), Loc)));
2677
2678       P := Parent (E);
2679       Insert_Before (P, Decl);
2680       Analyze (Decl);
2681
2682       Set_Has_Master_Entity (S);
2683
2684       --  Now mark the containing scope as a task master
2685
2686       while Nkind (P) /= N_Compilation_Unit loop
2687          P := Parent (P);
2688
2689          --  If we fall off the top, we are at the outer level, and the
2690          --  environment task is our effective master, so nothing to mark.
2691
2692          if Nkind_In
2693               (P, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
2694          then
2695             Set_Is_Task_Master (P, True);
2696             return;
2697
2698          elsif Nkind (Parent (P)) = N_Subunit then
2699             P := Corresponding_Stub (Parent (P));
2700          end if;
2701       end loop;
2702    end Build_Master_Entity;
2703
2704    -----------------------------------------
2705    -- Build_Private_Protected_Declaration --
2706    -----------------------------------------
2707
2708    function Build_Private_Protected_Declaration
2709      (N : Node_Id) return Entity_Id
2710    is
2711       Loc      : constant Source_Ptr := Sloc (N);
2712       Body_Id  : constant Entity_Id := Defining_Entity (N);
2713       Decl     : Node_Id;
2714       Plist    : List_Id;
2715       Formal   : Entity_Id;
2716       New_Spec : Node_Id;
2717       Spec_Id  : Entity_Id;
2718
2719    begin
2720       Formal := First_Formal (Body_Id);
2721
2722       --  The protected operation always has at least one formal, namely the
2723       --  object itself, but it is only placed in the parameter list if
2724       --  expansion is enabled.
2725
2726       if Present (Formal) or else Expander_Active then
2727          Plist := Copy_Parameter_List (Body_Id);
2728       else
2729          Plist := No_List;
2730       end if;
2731
2732       if Nkind (Specification (N)) = N_Procedure_Specification then
2733          New_Spec :=
2734            Make_Procedure_Specification (Loc,
2735               Defining_Unit_Name       =>
2736                 Make_Defining_Identifier (Sloc (Body_Id),
2737                   Chars => Chars (Body_Id)),
2738               Parameter_Specifications =>
2739                 Plist);
2740       else
2741          New_Spec :=
2742            Make_Function_Specification (Loc,
2743              Defining_Unit_Name       =>
2744                Make_Defining_Identifier (Sloc (Body_Id),
2745                  Chars => Chars (Body_Id)),
2746              Parameter_Specifications => Plist,
2747              Result_Definition        =>
2748                New_Occurrence_Of (Etype (Body_Id), Loc));
2749       end if;
2750
2751       Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec);
2752       Insert_Before (N, Decl);
2753       Spec_Id := Defining_Unit_Name (New_Spec);
2754
2755       --  Indicate that the entity comes from source, to ensure that cross-
2756       --  reference information is properly generated. The body itself is
2757       --  rewritten during expansion, and the body entity will not appear in
2758       --  calls to the operation.
2759
2760       Set_Comes_From_Source (Spec_Id, True);
2761       Analyze (Decl);
2762       Set_Has_Completion (Spec_Id);
2763       Set_Convention (Spec_Id, Convention_Protected);
2764       return Spec_Id;
2765    end Build_Private_Protected_Declaration;
2766
2767    ---------------------------
2768    -- Build_Protected_Entry --
2769    ---------------------------
2770
2771    function Build_Protected_Entry
2772      (N   : Node_Id;
2773       Ent : Entity_Id;
2774       Pid : Node_Id) return Node_Id
2775    is
2776       Loc : constant Source_Ptr := Sloc (N);
2777
2778       Decls   : constant List_Id := Declarations (N);
2779       End_Lab : constant Node_Id :=
2780                   End_Label (Handled_Statement_Sequence (N));
2781       End_Loc : constant Source_Ptr :=
2782                   Sloc (Last (Statements (Handled_Statement_Sequence (N))));
2783       --  Used for the generated call to Complete_Entry_Body
2784
2785       Han_Loc : Source_Ptr;
2786       --  Used for the exception handler, inserted at end of the body
2787
2788       Op_Decls : constant List_Id := New_List;
2789       Complete : Node_Id;
2790       Edef     : Entity_Id;
2791       Espec    : Node_Id;
2792       Ohandle  : Node_Id;
2793       Op_Stats : List_Id;
2794
2795    begin
2796       --  Set the source location on the exception handler only when debugging
2797       --  the expanded code (see Make_Implicit_Exception_Handler).
2798
2799       if Debug_Generated_Code then
2800          Han_Loc := End_Loc;
2801
2802       --  Otherwise the inserted code should not be visible to the debugger
2803
2804       else
2805          Han_Loc := No_Location;
2806       end if;
2807
2808       Edef :=
2809         Make_Defining_Identifier (Loc,
2810           Chars => Chars (Protected_Body_Subprogram (Ent)));
2811       Espec :=
2812         Build_Protected_Entry_Specification (Loc, Edef, Empty);
2813
2814       --  Add the following declarations:
2815       --    type poVP is access poV;
2816       --    _object : poVP := poVP (_O);
2817       --
2818       --  where _O is the formal parameter associated with the concurrent
2819       --  object. These declarations are needed for Complete_Entry_Body.
2820
2821       Add_Object_Pointer (Loc, Pid, Op_Decls);
2822
2823       --  Add renamings for all formals, the Protection object, discriminals,
2824       --  privals and the entry index constant for use by debugger.
2825
2826       Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc);
2827       Debug_Private_Data_Declarations (Decls);
2828
2829       case Corresponding_Runtime_Package (Pid) is
2830          when System_Tasking_Protected_Objects_Entries =>
2831             Complete :=
2832               New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
2833
2834          when System_Tasking_Protected_Objects_Single_Entry =>
2835             Complete :=
2836               New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc);
2837
2838          when others =>
2839             raise Program_Error;
2840       end case;
2841
2842       Op_Stats := New_List (
2843         Make_Block_Statement (Loc,
2844           Declarations => Decls,
2845           Handled_Statement_Sequence =>
2846             Handled_Statement_Sequence (N)),
2847
2848         Make_Procedure_Call_Statement (End_Loc,
2849           Name => Complete,
2850           Parameter_Associations => New_List (
2851             Make_Attribute_Reference (End_Loc,
2852               Prefix =>
2853                 Make_Selected_Component (End_Loc,
2854                   Prefix        => Make_Identifier (End_Loc, Name_uObject),
2855                   Selector_Name => Make_Identifier (End_Loc, Name_uObject)),
2856               Attribute_Name => Name_Unchecked_Access))));
2857
2858       --  When exceptions can not be propagated, we never need to call
2859       --  Exception_Complete_Entry_Body
2860
2861       if No_Exception_Handlers_Set then
2862          return
2863            Make_Subprogram_Body (Loc,
2864              Specification => Espec,
2865              Declarations => Op_Decls,
2866              Handled_Statement_Sequence =>
2867                Make_Handled_Sequence_Of_Statements (Loc,
2868                  Statements => Op_Stats,
2869                  End_Label  => End_Lab));
2870
2871       else
2872          Ohandle := Make_Others_Choice (Loc);
2873          Set_All_Others (Ohandle);
2874
2875          case Corresponding_Runtime_Package (Pid) is
2876             when System_Tasking_Protected_Objects_Entries =>
2877                Complete :=
2878                  New_Reference_To
2879                    (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
2880
2881             when System_Tasking_Protected_Objects_Single_Entry =>
2882                Complete :=
2883                  New_Reference_To
2884                    (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
2885
2886             when others =>
2887                raise Program_Error;
2888          end case;
2889
2890          --  Establish link between subprogram body entity and source entry.
2891
2892          Set_Corresponding_Protected_Entry (Edef, Ent);
2893
2894          --  Create body of entry procedure. The renaming declarations are
2895          --  placed ahead of the block that contains the actual entry body.
2896
2897          return
2898            Make_Subprogram_Body (Loc,
2899              Specification => Espec,
2900              Declarations => Op_Decls,
2901              Handled_Statement_Sequence =>
2902                Make_Handled_Sequence_Of_Statements (Loc,
2903                  Statements => Op_Stats,
2904                  End_Label  => End_Lab,
2905                  Exception_Handlers => New_List (
2906                    Make_Implicit_Exception_Handler (Han_Loc,
2907                      Exception_Choices => New_List (Ohandle),
2908
2909                      Statements =>  New_List (
2910                        Make_Procedure_Call_Statement (Han_Loc,
2911                          Name => Complete,
2912                          Parameter_Associations => New_List (
2913                            Make_Attribute_Reference (Han_Loc,
2914                              Prefix =>
2915                                Make_Selected_Component (Han_Loc,
2916                                  Prefix        =>
2917                                    Make_Identifier (Han_Loc, Name_uObject),
2918                                  Selector_Name =>
2919                                    Make_Identifier (Han_Loc, Name_uObject)),
2920                                Attribute_Name => Name_Unchecked_Access),
2921
2922                            Make_Function_Call (Han_Loc,
2923                              Name => New_Reference_To (
2924                                RTE (RE_Get_GNAT_Exception), Loc)))))))));
2925       end if;
2926    end Build_Protected_Entry;
2927
2928    -----------------------------------------
2929    -- Build_Protected_Entry_Specification --
2930    -----------------------------------------
2931
2932    function Build_Protected_Entry_Specification
2933      (Loc    : Source_Ptr;
2934       Def_Id : Entity_Id;
2935       Ent_Id : Entity_Id) return Node_Id
2936    is
2937       P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP);
2938
2939    begin
2940       Set_Debug_Info_Needed (Def_Id);
2941
2942       if Present (Ent_Id) then
2943          Append_Elmt (P, Accept_Address (Ent_Id));
2944       end if;
2945
2946       return
2947         Make_Procedure_Specification (Loc,
2948           Defining_Unit_Name => Def_Id,
2949           Parameter_Specifications => New_List (
2950             Make_Parameter_Specification (Loc,
2951               Defining_Identifier =>
2952                 Make_Defining_Identifier (Loc, Name_uO),
2953               Parameter_Type =>
2954                 New_Reference_To (RTE (RE_Address), Loc)),
2955
2956             Make_Parameter_Specification (Loc,
2957               Defining_Identifier => P,
2958               Parameter_Type =>
2959                 New_Reference_To (RTE (RE_Address), Loc)),
2960
2961             Make_Parameter_Specification (Loc,
2962               Defining_Identifier =>
2963                 Make_Defining_Identifier (Loc, Name_uE),
2964               Parameter_Type =>
2965                 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))));
2966    end Build_Protected_Entry_Specification;
2967
2968    --------------------------
2969    -- Build_Protected_Spec --
2970    --------------------------
2971
2972    function Build_Protected_Spec
2973      (N           : Node_Id;
2974       Obj_Type    : Entity_Id;
2975       Ident       : Entity_Id;
2976       Unprotected : Boolean := False) return List_Id
2977    is
2978       Loc       : constant Source_Ptr := Sloc (N);
2979       Decl      : Node_Id;
2980       Formal    : Entity_Id;
2981       New_Plist : List_Id;
2982       New_Param : Node_Id;
2983
2984    begin
2985       New_Plist := New_List;
2986
2987       Formal := First_Formal (Ident);
2988       while Present (Formal) loop
2989          New_Param :=
2990            Make_Parameter_Specification (Loc,
2991              Defining_Identifier =>
2992                Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
2993              In_Present          => In_Present (Parent (Formal)),
2994              Out_Present         => Out_Present (Parent (Formal)),
2995              Parameter_Type      => New_Reference_To (Etype (Formal), Loc));
2996
2997          if Unprotected then
2998             Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
2999          end if;
3000
3001          Append (New_Param, New_Plist);
3002          Next_Formal (Formal);
3003       end loop;
3004
3005       --  If the subprogram is a procedure and the context is not an access
3006       --  to protected subprogram, the parameter is in-out. Otherwise it is
3007       --  an in parameter.
3008
3009       Decl :=
3010         Make_Parameter_Specification (Loc,
3011           Defining_Identifier =>
3012             Make_Defining_Identifier (Loc, Name_uObject),
3013           In_Present => True,
3014           Out_Present =>
3015             (Etype (Ident) = Standard_Void_Type
3016                and then not Is_RTE (Obj_Type, RE_Address)),
3017           Parameter_Type =>
3018             New_Reference_To (Obj_Type, Loc));
3019       Set_Debug_Info_Needed (Defining_Identifier (Decl));
3020       Prepend_To (New_Plist, Decl);
3021
3022       return New_Plist;
3023    end Build_Protected_Spec;
3024
3025    ---------------------------------------
3026    -- Build_Protected_Sub_Specification --
3027    ---------------------------------------
3028
3029    function Build_Protected_Sub_Specification
3030      (N        : Node_Id;
3031       Prot_Typ : Entity_Id;
3032       Mode     : Subprogram_Protection_Mode) return Node_Id
3033    is
3034       Loc       : constant Source_Ptr := Sloc (N);
3035       Decl      : Node_Id;
3036       Def_Id    : Entity_Id;
3037       New_Id    : Entity_Id;
3038       New_Plist : List_Id;
3039       New_Spec  : Node_Id;
3040
3041       Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
3042                      (Dispatching_Mode => ' ',
3043                       Protected_Mode   => 'P',
3044                       Unprotected_Mode => 'N');
3045
3046    begin
3047       if Ekind (Defining_Unit_Name (Specification (N))) =
3048            E_Subprogram_Body
3049       then
3050          Decl := Unit_Declaration_Node (Corresponding_Spec (N));
3051       else
3052          Decl := N;
3053       end if;
3054
3055       Def_Id := Defining_Unit_Name (Specification (Decl));
3056
3057       New_Plist :=
3058         Build_Protected_Spec
3059           (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id,
3060            Mode = Unprotected_Mode);
3061       New_Id :=
3062         Make_Defining_Identifier (Loc,
3063           Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
3064
3065       --  The unprotected operation carries the user code, and debugging
3066       --  information must be generated for it, even though this spec does
3067       --  not come from source. It is also convenient to allow gdb to step
3068       --  into the protected operation, even though it only contains lock/
3069       --  unlock calls.
3070
3071       Set_Debug_Info_Needed (New_Id);
3072
3073       --  If a pragma Eliminate applies to the source entity, the internal
3074       --  subprograms will be eliminated as well.
3075
3076       Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
3077
3078       if Nkind (Specification (Decl)) = N_Procedure_Specification then
3079          New_Spec :=
3080            Make_Procedure_Specification (Loc,
3081              Defining_Unit_Name => New_Id,
3082              Parameter_Specifications => New_Plist);
3083
3084       --  Create a new specification for the anonymous subprogram type
3085
3086       else
3087          New_Spec :=
3088            Make_Function_Specification (Loc,
3089              Defining_Unit_Name => New_Id,
3090              Parameter_Specifications => New_Plist,
3091              Result_Definition =>
3092                Copy_Result_Type (Result_Definition (Specification (Decl))));
3093
3094          Set_Return_Present (Defining_Unit_Name (New_Spec));
3095       end if;
3096
3097       return New_Spec;
3098    end Build_Protected_Sub_Specification;
3099
3100    -------------------------------------
3101    -- Build_Protected_Subprogram_Body --
3102    -------------------------------------
3103
3104    function Build_Protected_Subprogram_Body
3105      (N         : Node_Id;
3106       Pid       : Node_Id;
3107       N_Op_Spec : Node_Id) return Node_Id
3108    is
3109       Loc          : constant Source_Ptr := Sloc (N);
3110       Op_Spec      : Node_Id;
3111       P_Op_Spec    : Node_Id;
3112       Uactuals     : List_Id;
3113       Pformal      : Node_Id;
3114       Unprot_Call  : Node_Id;
3115       Sub_Body     : Node_Id;
3116       Lock_Name    : Node_Id;
3117       Lock_Stmt    : Node_Id;
3118       Service_Name : Node_Id;
3119       R            : Node_Id;
3120       Return_Stmt  : Node_Id := Empty;    -- init to avoid gcc 3 warning
3121       Pre_Stmts    : List_Id := No_List;  -- init to avoid gcc 3 warning
3122       Stmts        : List_Id;
3123       Object_Parm  : Node_Id;
3124       Exc_Safe     : Boolean;
3125
3126       function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
3127       --  Tell whether a given subprogram cannot raise an exception
3128
3129       -----------------------
3130       -- Is_Exception_Safe --
3131       -----------------------
3132
3133       function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
3134
3135          function Has_Side_Effect (N : Node_Id) return Boolean;
3136          --  Return True whenever encountering a subprogram call or raise
3137          --  statement of any kind in the sequence of statements
3138
3139          ---------------------
3140          -- Has_Side_Effect --
3141          ---------------------
3142
3143          --  What is this doing buried two levels down in exp_ch9. It seems
3144          --  like a generally useful function, and indeed there may be code
3145          --  duplication going on here ???
3146
3147          function Has_Side_Effect (N : Node_Id) return Boolean is
3148             Stmt : Node_Id;
3149             Expr : Node_Id;
3150
3151             function Is_Call_Or_Raise (N : Node_Id) return Boolean;
3152             --  Indicate whether N is a subprogram call or a raise statement
3153
3154             ----------------------
3155             -- Is_Call_Or_Raise --
3156             ----------------------
3157
3158             function Is_Call_Or_Raise (N : Node_Id) return Boolean is
3159             begin
3160                return Nkind_In (N, N_Procedure_Call_Statement,
3161                                    N_Function_Call,
3162                                    N_Raise_Statement,
3163                                    N_Raise_Constraint_Error,
3164                                    N_Raise_Program_Error,
3165                                    N_Raise_Storage_Error);
3166             end Is_Call_Or_Raise;
3167
3168          --  Start of processing for Has_Side_Effect
3169
3170          begin
3171             Stmt := N;
3172             while Present (Stmt) loop
3173                if Is_Call_Or_Raise (Stmt) then
3174                   return True;
3175                end if;
3176
3177                --  An object declaration can also contain a function call
3178                --  or a raise statement
3179
3180                if Nkind (Stmt) = N_Object_Declaration then
3181                   Expr := Expression (Stmt);
3182
3183                   if Present (Expr) and then Is_Call_Or_Raise (Expr) then
3184                      return True;
3185                   end if;
3186                end if;
3187
3188                Next (Stmt);
3189             end loop;
3190
3191             return False;
3192          end Has_Side_Effect;
3193
3194       --  Start of processing for Is_Exception_Safe
3195
3196       begin
3197          --  If the checks handled by the back end are not disabled, we cannot
3198          --  ensure that no exception will be raised.
3199
3200          if not Access_Checks_Suppressed (Empty)
3201            or else not Discriminant_Checks_Suppressed (Empty)
3202            or else not Range_Checks_Suppressed (Empty)
3203            or else not Index_Checks_Suppressed (Empty)
3204            or else Opt.Stack_Checking_Enabled
3205          then
3206             return False;
3207          end if;
3208
3209          if Has_Side_Effect (First (Declarations (Subprogram)))
3210            or else
3211               Has_Side_Effect (
3212                 First (Statements (Handled_Statement_Sequence (Subprogram))))
3213          then
3214             return False;
3215          else
3216             return True;
3217          end if;
3218       end Is_Exception_Safe;
3219
3220    --  Start of processing for Build_Protected_Subprogram_Body
3221
3222    begin
3223       Op_Spec := Specification (N);
3224       Exc_Safe := Is_Exception_Safe (N);
3225
3226       P_Op_Spec :=
3227         Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
3228
3229       --  Build a list of the formal parameters of the protected version of
3230       --  the subprogram to use as the actual parameters of the unprotected
3231       --  version.
3232
3233       Uactuals := New_List;
3234       Pformal := First (Parameter_Specifications (P_Op_Spec));
3235       while Present (Pformal) loop
3236          Append_To (Uactuals,
3237            Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
3238          Next (Pformal);
3239       end loop;
3240
3241       --  Make a call to the unprotected version of the subprogram built above
3242       --  for use by the protected version built below.
3243
3244       if Nkind (Op_Spec) = N_Function_Specification then
3245          if Exc_Safe then
3246             R := Make_Temporary (Loc, 'R');
3247             Unprot_Call :=
3248               Make_Object_Declaration (Loc,
3249                 Defining_Identifier => R,
3250                 Constant_Present => True,
3251                 Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
3252                 Expression =>
3253                   Make_Function_Call (Loc,
3254                     Name => Make_Identifier (Loc,
3255                       Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
3256                     Parameter_Associations => Uactuals));
3257
3258             Return_Stmt :=
3259               Make_Simple_Return_Statement (Loc,
3260                 Expression => New_Reference_To (R, Loc));
3261
3262          else
3263             Unprot_Call := Make_Simple_Return_Statement (Loc,
3264               Expression => Make_Function_Call (Loc,
3265                 Name =>
3266                   Make_Identifier (Loc,
3267                     Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
3268                 Parameter_Associations => Uactuals));
3269          end if;
3270
3271       else
3272          Unprot_Call :=
3273            Make_Procedure_Call_Statement (Loc,
3274              Name =>
3275                Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
3276              Parameter_Associations => Uactuals);
3277       end if;
3278
3279       --  Wrap call in block that will be covered by an at_end handler
3280
3281       if not Exc_Safe then
3282          Unprot_Call := Make_Block_Statement (Loc,
3283            Handled_Statement_Sequence =>
3284              Make_Handled_Sequence_Of_Statements (Loc,
3285                Statements => New_List (Unprot_Call)));
3286       end if;
3287
3288       --  Make the protected subprogram body. This locks the protected
3289       --  object and calls the unprotected version of the subprogram.
3290
3291       case Corresponding_Runtime_Package (Pid) is
3292          when System_Tasking_Protected_Objects_Entries =>
3293             Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
3294             Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
3295
3296          when System_Tasking_Protected_Objects_Single_Entry =>
3297             Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc);
3298             Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
3299
3300          when System_Tasking_Protected_Objects =>
3301             Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
3302             Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
3303
3304          when others =>
3305             raise Program_Error;
3306       end case;
3307
3308       Object_Parm :=
3309         Make_Attribute_Reference (Loc,
3310            Prefix =>
3311              Make_Selected_Component (Loc,
3312                Prefix        => Make_Identifier (Loc, Name_uObject),
3313                Selector_Name => Make_Identifier (Loc, Name_uObject)),
3314            Attribute_Name => Name_Unchecked_Access);
3315
3316       Lock_Stmt := Make_Procedure_Call_Statement (Loc,
3317         Name => Lock_Name,
3318         Parameter_Associations => New_List (Object_Parm));
3319
3320       if Abort_Allowed then
3321          Stmts := New_List (
3322            Make_Procedure_Call_Statement (Loc,
3323              Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
3324              Parameter_Associations => Empty_List),
3325            Lock_Stmt);
3326
3327       else
3328          Stmts := New_List (Lock_Stmt);
3329       end if;
3330
3331       if not Exc_Safe then
3332          Append (Unprot_Call, Stmts);
3333       else
3334          if Nkind (Op_Spec) = N_Function_Specification then
3335             Pre_Stmts := Stmts;
3336             Stmts     := Empty_List;
3337          else
3338             Append (Unprot_Call, Stmts);
3339          end if;
3340
3341          Append (
3342            Make_Procedure_Call_Statement (Loc,
3343              Name => Service_Name,
3344              Parameter_Associations =>
3345                New_List (New_Copy_Tree (Object_Parm))),
3346            Stmts);
3347
3348          if Abort_Allowed then
3349             Append (
3350               Make_Procedure_Call_Statement (Loc,
3351                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
3352                 Parameter_Associations => Empty_List),
3353               Stmts);
3354          end if;
3355
3356          if Nkind (Op_Spec) = N_Function_Specification then
3357             Append (Return_Stmt, Stmts);
3358             Append (Make_Block_Statement (Loc,
3359               Declarations => New_List (Unprot_Call),
3360               Handled_Statement_Sequence =>
3361                 Make_Handled_Sequence_Of_Statements (Loc,
3362                   Statements => Stmts)), Pre_Stmts);
3363             Stmts := Pre_Stmts;
3364          end if;
3365       end if;
3366
3367       Sub_Body :=
3368         Make_Subprogram_Body (Loc,
3369           Declarations => Empty_List,
3370           Specification => P_Op_Spec,
3371           Handled_Statement_Sequence =>
3372             Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
3373
3374       if not Exc_Safe then
3375          Set_Is_Protected_Subprogram_Body (Sub_Body);
3376       end if;
3377
3378       return Sub_Body;
3379    end Build_Protected_Subprogram_Body;
3380
3381    -------------------------------------
3382    -- Build_Protected_Subprogram_Call --
3383    -------------------------------------
3384
3385    procedure Build_Protected_Subprogram_Call
3386      (N        : Node_Id;
3387       Name     : Node_Id;
3388       Rec      : Node_Id;
3389       External : Boolean := True)
3390    is
3391       Loc     : constant Source_Ptr := Sloc (N);
3392       Sub     : constant Entity_Id  := Entity (Name);
3393       New_Sub : Node_Id;
3394       Params  : List_Id;
3395
3396    begin
3397       if External then
3398          New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
3399       else
3400          New_Sub :=
3401            New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
3402       end if;
3403
3404       if Present (Parameter_Associations (N)) then
3405          Params := New_Copy_List_Tree (Parameter_Associations (N));
3406       else
3407          Params := New_List;
3408       end if;
3409
3410       --  If the type is an untagged derived type, convert to the root type,
3411       --  which is the one on which the operations are defined.
3412
3413       if Nkind (Rec) = N_Unchecked_Type_Conversion
3414         and then not Is_Tagged_Type (Etype (Rec))
3415         and then Is_Derived_Type (Etype (Rec))
3416       then
3417          Set_Etype (Rec, Root_Type (Etype (Rec)));
3418          Set_Subtype_Mark (Rec,
3419            New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
3420       end if;
3421
3422       Prepend (Rec, Params);
3423
3424       if Ekind (Sub) = E_Procedure then
3425          Rewrite (N,
3426            Make_Procedure_Call_Statement (Loc,
3427              Name => New_Sub,
3428              Parameter_Associations => Params));
3429
3430       else
3431          pragma Assert (Ekind (Sub) = E_Function);
3432          Rewrite (N,
3433            Make_Function_Call (Loc,
3434              Name => New_Sub,
3435              Parameter_Associations => Params));
3436       end if;
3437
3438       if External
3439         and then Nkind (Rec) = N_Unchecked_Type_Conversion
3440         and then Is_Entity_Name (Expression (Rec))
3441         and then Is_Shared_Passive (Entity (Expression (Rec)))
3442       then
3443          Add_Shared_Var_Lock_Procs (N);
3444       end if;
3445    end Build_Protected_Subprogram_Call;
3446
3447    -------------------------
3448    -- Build_Selected_Name --
3449    -------------------------
3450
3451    function Build_Selected_Name
3452      (Prefix      : Entity_Id;
3453       Selector    : Entity_Id;
3454       Append_Char : Character := ' ') return Name_Id
3455    is
3456       Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
3457       Select_Len    : Natural;
3458
3459    begin
3460       Get_Name_String (Chars (Selector));
3461       Select_Len := Name_Len;
3462       Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
3463       Get_Name_String (Chars (Prefix));
3464
3465       --  If scope is anonymous type, discard suffix to recover name of
3466       --  single protected object. Otherwise use protected type name.
3467
3468       if Name_Buffer (Name_Len) = 'T' then
3469          Name_Len := Name_Len - 1;
3470       end if;
3471
3472       Add_Str_To_Name_Buffer ("__");
3473       for J in 1 .. Select_Len loop
3474          Add_Char_To_Name_Buffer (Select_Buffer (J));
3475       end loop;
3476
3477       --  Now add the Append_Char if specified. The encoding to follow
3478       --  depends on the type of entity. If Append_Char is either 'N' or 'P',
3479       --  then the entity is associated to a protected type subprogram.
3480       --  Otherwise, it is a protected type entry. For each case, the
3481       --  encoding to follow for the suffix is documented in exp_dbug.ads.
3482
3483       --  It would be better to encapsulate this as a routine in Exp_Dbug ???
3484
3485       if Append_Char /= ' ' then
3486          if Append_Char = 'P' or Append_Char = 'N' then
3487             Add_Char_To_Name_Buffer (Append_Char);
3488             return Name_Find;
3489          else
3490             Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
3491             return New_External_Name (Name_Find, ' ', -1);
3492          end if;
3493       else
3494          return Name_Find;
3495       end if;
3496    end Build_Selected_Name;
3497
3498    -----------------------------
3499    -- Build_Simple_Entry_Call --
3500    -----------------------------
3501
3502    --  A task entry call is converted to a call to Call_Simple
3503
3504    --    declare
3505    --       P : parms := (parm, parm, parm);
3506    --    begin
3507    --       Call_Simple (acceptor-task, entry-index, P'Address);
3508    --       parm := P.param;
3509    --       parm := P.param;
3510    --       ...
3511    --    end;
3512
3513    --  Here Pnn is an aggregate of the type constructed for the entry to hold
3514    --  the parameters, and the constructed aggregate value contains either the
3515    --  parameters or, in the case of non-elementary types, references to these
3516    --  parameters. Then the address of this aggregate is passed to the runtime
3517    --  routine, along with the task id value and the task entry index value.
3518    --  Pnn is only required if parameters are present.
3519
3520    --  The assignments after the call are present only in the case of in-out
3521    --  or out parameters for elementary types, and are used to assign back the
3522    --  resulting values of such parameters.
3523
3524    --  Note: the reason that we insert a block here is that in the context
3525    --  of selects, conditional entry calls etc. the entry call statement
3526    --  appears on its own, not as an element of a list.
3527
3528    --  A protected entry call is converted to a Protected_Entry_Call:
3529
3530    --  declare
3531    --     P   : E1_Params := (param, param, param);
3532    --     Pnn : Boolean;
3533    --     Bnn : Communications_Block;
3534
3535    --  declare
3536    --     P   : E1_Params := (param, param, param);
3537    --     Bnn : Communications_Block;
3538
3539    --  begin
3540    --     Protected_Entry_Call (
3541    --       Object => po._object'Access,
3542    --       E => <entry index>;
3543    --       Uninterpreted_Data => P'Address;
3544    --       Mode => Simple_Call;
3545    --       Block => Bnn);
3546    --     parm := P.param;
3547    --     parm := P.param;
3548    --       ...
3549    --  end;
3550
3551    procedure Build_Simple_Entry_Call
3552      (N       : Node_Id;
3553       Concval : Node_Id;
3554       Ename   : Node_Id;
3555       Index   : Node_Id)
3556    is
3557    begin
3558       Expand_Call (N);
3559
3560       --  If call has been inlined, nothing left to do
3561
3562       if Nkind (N) = N_Block_Statement then
3563          return;
3564       end if;
3565
3566       --  Convert entry call to Call_Simple call
3567
3568       declare
3569          Loc       : constant Source_Ptr := Sloc (N);
3570          Parms     : constant List_Id    := Parameter_Associations (N);
3571          Stats     : constant List_Id    := New_List;
3572          Actual    : Node_Id;
3573          Call      : Node_Id;
3574          Comm_Name : Entity_Id;
3575          Conctyp   : Node_Id;
3576          Decls     : List_Id;
3577          Ent       : Entity_Id;
3578          Ent_Acc   : Entity_Id;
3579          Formal    : Node_Id;
3580          Iface_Tag : Entity_Id;
3581          Iface_Typ : Entity_Id;
3582          N_Node    : Node_Id;
3583          N_Var     : Node_Id;
3584          P         : Entity_Id;
3585          Parm1     : Node_Id;
3586          Parm2     : Node_Id;
3587          Parm3     : Node_Id;
3588          Pdecl     : Node_Id;
3589          Plist     : List_Id;
3590          X         : Entity_Id;
3591          Xdecl     : Node_Id;
3592
3593       begin
3594          --  Simple entry and entry family cases merge here
3595
3596          Ent     := Entity (Ename);
3597          Ent_Acc := Entry_Parameters_Type (Ent);
3598          Conctyp := Etype (Concval);
3599
3600          --  If prefix is an access type, dereference to obtain the task type
3601
3602          if Is_Access_Type (Conctyp) then
3603             Conctyp := Designated_Type (Conctyp);
3604          end if;
3605
3606          --  Special case for protected subprogram calls
3607
3608          if Is_Protected_Type (Conctyp)
3609            and then Is_Subprogram (Entity (Ename))
3610          then
3611             if not Is_Eliminated (Entity (Ename)) then
3612                Build_Protected_Subprogram_Call
3613                  (N, Ename, Convert_Concurrent (Concval, Conctyp));
3614                Analyze (N);
3615             end if;
3616
3617             return;
3618          end if;
3619
3620          --  First parameter is the Task_Id value from the task value or the
3621          --  Object from the protected object value, obtained by selecting
3622          --  the _Task_Id or _Object from the result of doing an unchecked
3623          --  conversion to convert the value to the corresponding record type.
3624
3625          if Nkind (Concval) = N_Function_Call
3626            and then Is_Task_Type (Conctyp)
3627            and then Ada_Version >= Ada_2005
3628          then
3629             declare
3630                ExpR : constant Node_Id   := Relocate_Node (Concval);
3631                Obj  : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR);
3632                Decl : Node_Id;
3633
3634             begin
3635                Decl :=
3636                  Make_Object_Declaration (Loc,
3637                    Defining_Identifier => Obj,
3638                    Object_Definition   => New_Occurrence_Of (Conctyp, Loc),
3639                    Expression          => ExpR);
3640                Set_Etype (Obj, Conctyp);
3641                Decls := New_List (Decl);
3642                Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
3643             end;
3644
3645          else
3646             Decls := New_List;
3647          end if;
3648
3649          Parm1 := Concurrent_Ref (Concval);
3650
3651          --  Second parameter is the entry index, computed by the routine
3652          --  provided for this purpose. The value of this expression is
3653          --  assigned to an intermediate variable to assure that any entry
3654          --  family index expressions are evaluated before the entry
3655          --  parameters.
3656
3657          if Abort_Allowed
3658            or else Restriction_Active (No_Entry_Queue) = False
3659            or else not Is_Protected_Type (Conctyp)
3660            or else Number_Entries (Conctyp) > 1
3661            or else (Has_Attach_Handler (Conctyp)
3662                      and then not Restricted_Profile)
3663          then
3664             X := Make_Defining_Identifier (Loc, Name_uX);
3665
3666             Xdecl :=
3667               Make_Object_Declaration (Loc,
3668                 Defining_Identifier => X,
3669                 Object_Definition =>
3670                   New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3671                 Expression => Actual_Index_Expression (
3672                   Loc, Entity (Ename), Index, Concval));
3673
3674             Append_To (Decls, Xdecl);
3675             Parm2 := New_Reference_To (X, Loc);
3676
3677          else
3678             Xdecl := Empty;
3679             Parm2 := Empty;
3680          end if;
3681
3682          --  The third parameter is the packaged parameters. If there are
3683          --  none, then it is just the null address, since nothing is passed.
3684
3685          if No (Parms) then
3686             Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc);
3687             P := Empty;
3688
3689          --  Case of parameters present, where third argument is the address
3690          --  of a packaged record containing the required parameter values.
3691
3692          else
3693             --  First build a list of parameter values, which are references to
3694             --  objects of the parameter types.
3695
3696             Plist := New_List;
3697
3698             Actual := First_Actual (N);
3699             Formal := First_Formal (Ent);
3700
3701             while Present (Actual) loop
3702
3703                --  If it is a by_copy_type, copy it to a new variable. The
3704                --  packaged record has a field that points to this variable.
3705
3706                if Is_By_Copy_Type (Etype (Actual)) then
3707                   N_Node :=
3708                     Make_Object_Declaration (Loc,
3709                       Defining_Identifier => Make_Temporary (Loc, 'J'),
3710                       Aliased_Present     => True,
3711                       Object_Definition   =>
3712                         New_Reference_To (Etype (Formal), Loc));
3713
3714                   --  Mark the object as not needing initialization since the
3715                   --  initialization is performed separately, avoiding errors
3716                   --  on cases such as formals of null-excluding access types.
3717
3718                   Set_No_Initialization (N_Node);
3719
3720                   --  We must make an assignment statement separate for the
3721                   --  case of limited type. We cannot assign it unless the
3722                   --  Assignment_OK flag is set first. An out formal of an
3723                   --  access type must also be initialized from the actual,
3724                   --  as stated in RM 6.4.1 (13).
3725
3726                   if Ekind (Formal) /= E_Out_Parameter
3727                     or else Is_Access_Type (Etype (Formal))
3728                   then
3729                      N_Var :=
3730                        New_Reference_To (Defining_Identifier (N_Node), Loc);
3731                      Set_Assignment_OK (N_Var);
3732                      Append_To (Stats,
3733                        Make_Assignment_Statement (Loc,
3734                          Name => N_Var,
3735                          Expression => Relocate_Node (Actual)));
3736                   end if;
3737
3738                   Append (N_Node, Decls);
3739
3740                   Append_To (Plist,
3741                     Make_Attribute_Reference (Loc,
3742                       Attribute_Name => Name_Unchecked_Access,
3743                     Prefix =>
3744                       New_Reference_To (Defining_Identifier (N_Node), Loc)));
3745                else
3746                   --  Interface class-wide formal
3747
3748                   if Ada_Version >= Ada_2005
3749                     and then Ekind (Etype (Formal)) = E_Class_Wide_Type
3750                     and then Is_Interface (Etype (Formal))
3751                   then
3752                      Iface_Typ := Etype (Etype (Formal));
3753
3754                      --  Generate:
3755                      --    formal_iface_type! (actual.iface_tag)'reference
3756
3757                      Iface_Tag :=
3758                        Find_Interface_Tag (Etype (Actual), Iface_Typ);
3759                      pragma Assert (Present (Iface_Tag));
3760
3761                      Append_To (Plist,
3762                        Make_Reference (Loc,
3763                          Unchecked_Convert_To (Iface_Typ,
3764                            Make_Selected_Component (Loc,
3765                              Prefix =>
3766                                Relocate_Node (Actual),
3767                              Selector_Name =>
3768                                New_Reference_To (Iface_Tag, Loc)))));
3769                   else
3770                      --  Generate:
3771                      --    actual'reference
3772
3773                      Append_To (Plist,
3774                        Make_Reference (Loc, Relocate_Node (Actual)));
3775                   end if;
3776                end if;
3777
3778                Next_Actual (Actual);
3779                Next_Formal_With_Extras (Formal);
3780             end loop;
3781
3782             --  Now build the declaration of parameters initialized with the
3783             --  aggregate containing this constructed parameter list.
3784
3785             P := Make_Defining_Identifier (Loc, Name_uP);
3786
3787             Pdecl :=
3788               Make_Object_Declaration (Loc,
3789                 Defining_Identifier => P,
3790                 Object_Definition =>
3791                   New_Reference_To (Designated_Type (Ent_Acc), Loc),
3792                 Expression =>
3793                   Make_Aggregate (Loc, Expressions => Plist));
3794
3795             Parm3 :=
3796               Make_Attribute_Reference (Loc,
3797                 Prefix => New_Reference_To (P, Loc),
3798                 Attribute_Name => Name_Address);
3799
3800             Append (Pdecl, Decls);
3801          end if;
3802
3803          --  Now we can create the call, case of protected type
3804
3805          if Is_Protected_Type (Conctyp) then
3806             case Corresponding_Runtime_Package (Conctyp) is
3807                when System_Tasking_Protected_Objects_Entries =>
3808
3809                   --  Change the type of the index declaration
3810
3811                   Set_Object_Definition (Xdecl,
3812                     New_Reference_To (RTE (RE_Protected_Entry_Index), Loc));
3813
3814                   --  Some additional declarations for protected entry calls
3815
3816                   if No (Decls) then
3817                      Decls := New_List;
3818                   end if;
3819
3820                   --  Bnn : Communications_Block;
3821
3822                   Comm_Name := Make_Temporary (Loc, 'B');
3823
3824                   Append_To (Decls,
3825                     Make_Object_Declaration (Loc,
3826                       Defining_Identifier => Comm_Name,
3827                       Object_Definition   =>
3828                         New_Reference_To (RTE (RE_Communication_Block), Loc)));
3829
3830                   --  Some additional statements for protected entry calls
3831
3832                   --     Protected_Entry_Call (
3833                   --       Object => po._object'Access,
3834                   --       E => <entry index>;
3835                   --       Uninterpreted_Data => P'Address;
3836                   --       Mode => Simple_Call;
3837                   --       Block => Bnn);
3838
3839                   Call :=
3840                     Make_Procedure_Call_Statement (Loc,
3841                       Name =>
3842                         New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
3843
3844                       Parameter_Associations => New_List (
3845                         Make_Attribute_Reference (Loc,
3846                           Attribute_Name => Name_Unchecked_Access,
3847                           Prefix         => Parm1),
3848                         Parm2,
3849                         Parm3,
3850                         New_Reference_To (RTE (RE_Simple_Call), Loc),
3851                         New_Occurrence_Of (Comm_Name, Loc)));
3852
3853                when System_Tasking_Protected_Objects_Single_Entry =>
3854                   --     Protected_Single_Entry_Call (
3855                   --       Object => po._object'Access,
3856                   --       Uninterpreted_Data => P'Address;
3857                   --       Mode => Simple_Call);
3858
3859                   Call :=
3860                     Make_Procedure_Call_Statement (Loc,
3861                       Name => New_Reference_To (
3862                         RTE (RE_Protected_Single_Entry_Call), Loc),
3863
3864                       Parameter_Associations => New_List (
3865                         Make_Attribute_Reference (Loc,
3866                           Attribute_Name => Name_Unchecked_Access,
3867                           Prefix         => Parm1),
3868                         Parm3,
3869                         New_Reference_To (RTE (RE_Simple_Call), Loc)));
3870
3871                when others =>
3872                   raise Program_Error;
3873             end case;
3874
3875          --  Case of task type
3876
3877          else
3878             Call :=
3879               Make_Procedure_Call_Statement (Loc,
3880                 Name => New_Reference_To (RTE (RE_Call_Simple), Loc),
3881                 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
3882
3883          end if;
3884
3885          Append_To (Stats, Call);
3886
3887          --  If there are out or in/out parameters by copy add assignment
3888          --  statements for the result values.
3889
3890          if Present (Parms) then
3891             Actual := First_Actual (N);
3892             Formal := First_Formal (Ent);
3893
3894             Set_Assignment_OK (Actual);
3895             while Present (Actual) loop
3896                if Is_By_Copy_Type (Etype (Actual))
3897                  and then Ekind (Formal) /= E_In_Parameter
3898                then
3899                   N_Node :=
3900                     Make_Assignment_Statement (Loc,
3901                       Name => New_Copy (Actual),
3902                       Expression =>
3903                         Make_Explicit_Dereference (Loc,
3904                           Make_Selected_Component (Loc,
3905                             Prefix => New_Reference_To (P, Loc),
3906                             Selector_Name =>
3907                               Make_Identifier (Loc, Chars (Formal)))));
3908
3909                   --  In all cases (including limited private types) we want
3910                   --  the assignment to be valid.
3911
3912                   Set_Assignment_OK (Name (N_Node));
3913
3914                   --  If the call is the triggering alternative in an
3915                   --  asynchronous select, or the entry_call alternative of a
3916                   --  conditional entry call, the assignments for in-out
3917                   --  parameters are incorporated into the statement list that
3918                   --  follows, so that there are executed only if the entry
3919                   --  call succeeds.
3920
3921                   if (Nkind (Parent (N)) = N_Triggering_Alternative
3922                        and then N = Triggering_Statement (Parent (N)))
3923                     or else
3924                      (Nkind (Parent (N)) = N_Entry_Call_Alternative
3925                        and then N = Entry_Call_Statement (Parent (N)))
3926                   then
3927                      if No (Statements (Parent (N))) then
3928                         Set_Statements (Parent (N), New_List);
3929                      end if;
3930
3931                      Prepend (N_Node, Statements (Parent (N)));
3932
3933                   else
3934                      Insert_After (Call, N_Node);
3935                   end if;
3936                end if;
3937
3938                Next_Actual (Actual);
3939                Next_Formal_With_Extras (Formal);
3940             end loop;
3941          end if;
3942
3943          --  Finally, create block and analyze it
3944
3945          Rewrite (N,
3946            Make_Block_Statement (Loc,
3947              Declarations => Decls,
3948              Handled_Statement_Sequence =>
3949                Make_Handled_Sequence_Of_Statements (Loc,
3950                  Statements => Stats)));
3951
3952          Analyze (N);
3953       end;
3954    end Build_Simple_Entry_Call;
3955
3956    --------------------------------
3957    -- Build_Task_Activation_Call --
3958    --------------------------------
3959
3960    procedure Build_Task_Activation_Call (N : Node_Id) is
3961       Loc   : constant Source_Ptr := Sloc (N);
3962       Chain : Entity_Id;
3963       Call  : Node_Id;
3964       Name  : Node_Id;
3965       P     : Node_Id;
3966
3967    begin
3968       --  Get the activation chain entity. Except in the case of a package
3969       --  body, this is in the node that was passed. For a package body, we
3970       --  have to find the corresponding package declaration node.
3971
3972       if Nkind (N) = N_Package_Body then
3973          P := Corresponding_Spec (N);
3974          loop
3975             P := Parent (P);
3976             exit when Nkind (P) = N_Package_Declaration;
3977          end loop;
3978
3979          Chain := Activation_Chain_Entity (P);
3980
3981       else
3982          Chain := Activation_Chain_Entity (N);
3983       end if;
3984
3985       if Present (Chain) then
3986          if Restricted_Profile then
3987             Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc);
3988          else
3989             Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
3990          end if;
3991
3992          Call :=
3993            Make_Procedure_Call_Statement (Loc,
3994              Name => Name,
3995              Parameter_Associations =>
3996                New_List (Make_Attribute_Reference (Loc,
3997                  Prefix => New_Occurrence_Of (Chain, Loc),
3998                  Attribute_Name => Name_Unchecked_Access)));
3999
4000          if Nkind (N) = N_Package_Declaration then
4001             if Present (Corresponding_Body (N)) then
4002                null;
4003
4004             elsif Present (Private_Declarations (Specification (N))) then
4005                Append (Call, Private_Declarations (Specification (N)));
4006
4007             else
4008                Append (Call, Visible_Declarations (Specification (N)));
4009             end if;
4010
4011          else
4012             if Present (Handled_Statement_Sequence (N)) then
4013
4014                --  The call goes at the start of the statement sequence
4015                --  after the start of exception range label if one is present.
4016
4017                declare
4018                   Stm : Node_Id;
4019
4020                begin
4021                   Stm := First (Statements (Handled_Statement_Sequence (N)));
4022
4023                   --  A special case, skip exception range label if one is
4024                   --  present (from front end zcx processing).
4025
4026                   if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
4027                      Next (Stm);
4028                   end if;
4029
4030                   --  Another special case, if the first statement is a block
4031                   --  from optimization of a local raise to a goto, then the
4032                   --  call goes inside this block.
4033
4034                   if Nkind (Stm) = N_Block_Statement
4035                     and then Exception_Junk (Stm)
4036                   then
4037                      Stm :=
4038                        First (Statements (Handled_Statement_Sequence (Stm)));
4039                   end if;
4040
4041                   --  Insertion point is after any exception label pushes,
4042                   --  since we want it covered by any local handlers.
4043
4044                   while Nkind (Stm) in N_Push_xxx_Label loop
4045                      Next (Stm);
4046                   end loop;
4047
4048                   --  Now we have the proper insertion point
4049
4050                   Insert_Before (Stm, Call);
4051                end;
4052
4053             else
4054                Set_Handled_Statement_Sequence (N,
4055                   Make_Handled_Sequence_Of_Statements (Loc,
4056                      Statements => New_List (Call)));
4057             end if;
4058          end if;
4059
4060          Analyze (Call);
4061          Check_Task_Activation (N);
4062       end if;
4063    end Build_Task_Activation_Call;
4064
4065    -------------------------------
4066    -- Build_Task_Allocate_Block --
4067    -------------------------------
4068
4069    procedure Build_Task_Allocate_Block
4070      (Actions : List_Id;
4071       N       : Node_Id;
4072       Args    : List_Id)
4073    is
4074       T      : constant Entity_Id  := Entity (Expression (N));
4075       Init   : constant Entity_Id  := Base_Init_Proc (T);
4076       Loc    : constant Source_Ptr := Sloc (N);
4077       Chain  : constant Entity_Id  :=
4078                  Make_Defining_Identifier (Loc, Name_uChain);
4079       Blkent : constant Entity_Id  := Make_Temporary (Loc, 'A');
4080       Block  : Node_Id;
4081
4082    begin
4083       Block :=
4084         Make_Block_Statement (Loc,
4085           Identifier   => New_Reference_To (Blkent, Loc),
4086           Declarations => New_List (
4087
4088             --  _Chain  : Activation_Chain;
4089
4090             Make_Object_Declaration (Loc,
4091               Defining_Identifier => Chain,
4092               Aliased_Present => True,
4093               Object_Definition   =>
4094                 New_Reference_To (RTE (RE_Activation_Chain), Loc))),
4095
4096           Handled_Statement_Sequence =>
4097             Make_Handled_Sequence_Of_Statements (Loc,
4098
4099               Statements => New_List (
4100
4101                --  Init (Args);
4102
4103                 Make_Procedure_Call_Statement (Loc,
4104                   Name => New_Reference_To (Init, Loc),
4105                   Parameter_Associations => Args),
4106
4107                --  Activate_Tasks (_Chain);
4108
4109                 Make_Procedure_Call_Statement (Loc,
4110                   Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
4111                   Parameter_Associations => New_List (
4112                     Make_Attribute_Reference (Loc,
4113                       Prefix => New_Reference_To (Chain, Loc),
4114                       Attribute_Name => Name_Unchecked_Access))))),
4115
4116           Has_Created_Identifier => True,
4117           Is_Task_Allocation_Block => True);
4118
4119       Append_To (Actions,
4120         Make_Implicit_Label_Declaration (Loc,
4121           Defining_Identifier => Blkent,
4122           Label_Construct     => Block));
4123
4124       Append_To (Actions, Block);
4125
4126       Set_Activation_Chain_Entity (Block, Chain);
4127    end Build_Task_Allocate_Block;
4128
4129    -----------------------------------------------
4130    -- Build_Task_Allocate_Block_With_Init_Stmts --
4131    -----------------------------------------------
4132
4133    procedure Build_Task_Allocate_Block_With_Init_Stmts
4134      (Actions    : List_Id;
4135       N          : Node_Id;
4136       Init_Stmts : List_Id)
4137    is
4138       Loc    : constant Source_Ptr := Sloc (N);
4139       Chain  : constant Entity_Id  :=
4140                  Make_Defining_Identifier (Loc, Name_uChain);
4141       Blkent : constant Entity_Id  := Make_Temporary (Loc, 'A');
4142       Block  : Node_Id;
4143
4144    begin
4145       Append_To (Init_Stmts,
4146         Make_Procedure_Call_Statement (Loc,
4147           Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
4148           Parameter_Associations => New_List (
4149             Make_Attribute_Reference (Loc,
4150               Prefix => New_Reference_To (Chain, Loc),
4151               Attribute_Name => Name_Unchecked_Access))));
4152
4153       Block :=
4154         Make_Block_Statement (Loc,
4155           Identifier => New_Reference_To (Blkent, Loc),
4156           Declarations => New_List (
4157
4158             --  _Chain  : Activation_Chain;
4159
4160             Make_Object_Declaration (Loc,
4161               Defining_Identifier => Chain,
4162               Aliased_Present => True,
4163               Object_Definition   =>
4164                 New_Reference_To (RTE (RE_Activation_Chain), Loc))),
4165
4166           Handled_Statement_Sequence =>
4167             Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
4168
4169           Has_Created_Identifier => True,
4170           Is_Task_Allocation_Block => True);
4171
4172       Append_To (Actions,
4173         Make_Implicit_Label_Declaration (Loc,
4174           Defining_Identifier => Blkent,
4175           Label_Construct     => Block));
4176
4177       Append_To (Actions, Block);
4178
4179       Set_Activation_Chain_Entity (Block, Chain);
4180    end Build_Task_Allocate_Block_With_Init_Stmts;
4181
4182    -----------------------------------
4183    -- Build_Task_Proc_Specification --
4184    -----------------------------------
4185
4186    function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
4187       Loc     : constant Source_Ptr := Sloc (T);
4188       Spec_Id : Entity_Id;
4189
4190    begin
4191       --  Case of explicit task type, suffix TB
4192
4193       if Comes_From_Source (T) then
4194          Spec_Id :=
4195            Make_Defining_Identifier (Loc,
4196              Chars => New_External_Name (Chars (T), "TB"));
4197
4198       --  Case of anonymous task type, suffix B
4199
4200       else
4201          Spec_Id :=
4202            Make_Defining_Identifier (Loc,
4203              Chars => New_External_Name (Chars (T), 'B'));
4204       end if;
4205
4206       Set_Is_Internal (Spec_Id);
4207
4208       --  Associate the procedure with the task, if this is the declaration
4209       --  (and not the body) of the procedure.
4210
4211       if No (Task_Body_Procedure (T)) then
4212          Set_Task_Body_Procedure (T, Spec_Id);
4213       end if;
4214
4215       return
4216         Make_Procedure_Specification (Loc,
4217           Defining_Unit_Name       => Spec_Id,
4218           Parameter_Specifications => New_List (
4219             Make_Parameter_Specification (Loc,
4220               Defining_Identifier =>
4221                 Make_Defining_Identifier (Loc, Name_uTask),
4222               Parameter_Type      =>
4223                 Make_Access_Definition (Loc,
4224                   Subtype_Mark =>
4225                     New_Reference_To (Corresponding_Record_Type (T), Loc)))));
4226    end Build_Task_Proc_Specification;
4227
4228    ---------------------------------------
4229    -- Build_Unprotected_Subprogram_Body --
4230    ---------------------------------------
4231
4232    function Build_Unprotected_Subprogram_Body
4233      (N   : Node_Id;
4234       Pid : Node_Id) return Node_Id
4235    is
4236       Decls : constant List_Id := Declarations (N);
4237
4238    begin
4239       --  Add renamings for the Protection object, discriminals, privals and
4240       --  the entry index constant for use by debugger.
4241
4242       Debug_Private_Data_Declarations (Decls);
4243
4244       --  Make an unprotected version of the subprogram for use within the same
4245       --  object, with a new name and an additional parameter representing the
4246       --  object.
4247
4248       return
4249         Make_Subprogram_Body (Sloc (N),
4250           Specification              =>
4251             Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
4252           Declarations               => Decls,
4253           Handled_Statement_Sequence => Handled_Statement_Sequence (N));
4254    end Build_Unprotected_Subprogram_Body;
4255
4256    ----------------------------
4257    -- Collect_Entry_Families --
4258    ----------------------------
4259
4260    procedure Collect_Entry_Families
4261      (Loc          : Source_Ptr;
4262       Cdecls       : List_Id;
4263       Current_Node : in out Node_Id;
4264       Conctyp      : Entity_Id)
4265    is
4266       Efam      : Entity_Id;
4267       Efam_Decl : Node_Id;
4268       Efam_Type : Entity_Id;
4269
4270    begin
4271       Efam := First_Entity (Conctyp);
4272       while Present (Efam) loop
4273          if Ekind (Efam) = E_Entry_Family then
4274             Efam_Type := Make_Temporary (Loc, 'F');
4275
4276             declare
4277                Bas : Entity_Id :=
4278                        Base_Type
4279                         (Etype (Discrete_Subtype_Definition (Parent (Efam))));
4280
4281                Bas_Decl : Node_Id := Empty;
4282                Lo, Hi   : Node_Id;
4283
4284             begin
4285                Get_Index_Bounds
4286                  (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
4287
4288                if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
4289                   Bas := Make_Temporary (Loc, 'B');
4290
4291                   Bas_Decl :=
4292                     Make_Subtype_Declaration (Loc,
4293                        Defining_Identifier => Bas,
4294                        Subtype_Indication  =>
4295                          Make_Subtype_Indication (Loc,
4296                            Subtype_Mark =>
4297                              New_Occurrence_Of (Standard_Integer, Loc),
4298                            Constraint   =>
4299                              Make_Range_Constraint (Loc,
4300                                Range_Expression => Make_Range (Loc,
4301                                  Make_Integer_Literal
4302                                    (Loc, -Entry_Family_Bound),
4303                                  Make_Integer_Literal
4304                                    (Loc, Entry_Family_Bound - 1)))));
4305
4306                   Insert_After (Current_Node, Bas_Decl);
4307                   Current_Node := Bas_Decl;
4308                   Analyze (Bas_Decl);
4309                end if;
4310
4311                Efam_Decl :=
4312                  Make_Full_Type_Declaration (Loc,
4313                    Defining_Identifier => Efam_Type,
4314                    Type_Definition =>
4315                      Make_Unconstrained_Array_Definition (Loc,
4316                        Subtype_Marks =>
4317                          (New_List (New_Occurrence_Of (Bas, Loc))),
4318
4319                     Component_Definition =>
4320                       Make_Component_Definition (Loc,
4321                         Aliased_Present    => False,
4322                         Subtype_Indication =>
4323                           New_Reference_To (Standard_Character, Loc))));
4324             end;
4325
4326             Insert_After (Current_Node, Efam_Decl);
4327             Current_Node := Efam_Decl;
4328             Analyze (Efam_Decl);
4329
4330             Append_To (Cdecls,
4331               Make_Component_Declaration (Loc,
4332                 Defining_Identifier =>
4333                   Make_Defining_Identifier (Loc, Chars (Efam)),
4334
4335                 Component_Definition =>
4336                   Make_Component_Definition (Loc,
4337                     Aliased_Present    => False,
4338                     Subtype_Indication =>
4339                       Make_Subtype_Indication (Loc,
4340                         Subtype_Mark =>
4341                           New_Occurrence_Of (Efam_Type, Loc),
4342
4343                         Constraint  =>
4344                           Make_Index_Or_Discriminant_Constraint (Loc,
4345                             Constraints => New_List (
4346                               New_Occurrence_Of
4347                                 (Etype (Discrete_Subtype_Definition
4348                                   (Parent (Efam))), Loc)))))));
4349
4350          end if;
4351
4352          Next_Entity (Efam);
4353       end loop;
4354    end Collect_Entry_Families;
4355
4356    -----------------------
4357    -- Concurrent_Object --
4358    -----------------------
4359
4360    function Concurrent_Object
4361      (Spec_Id  : Entity_Id;
4362       Conc_Typ : Entity_Id) return Entity_Id
4363    is
4364    begin
4365       --  Parameter _O or _object
4366
4367       if Is_Protected_Type (Conc_Typ) then
4368          return First_Formal (Protected_Body_Subprogram (Spec_Id));
4369
4370       --  Parameter _task
4371
4372       else
4373          pragma Assert (Is_Task_Type (Conc_Typ));
4374          return First_Formal (Task_Body_Procedure (Conc_Typ));
4375       end if;
4376    end Concurrent_Object;
4377
4378    ----------------------
4379    -- Copy_Result_Type --
4380    ----------------------
4381
4382    function Copy_Result_Type (Res : Node_Id) return Node_Id is
4383       New_Res  : constant Node_Id := New_Copy_Tree (Res);
4384       Par_Spec : Node_Id;
4385       Formal   : Entity_Id;
4386
4387    begin
4388       --  If the result type is an access_to_subprogram, we must create
4389       --  new entities for its spec.
4390
4391       if Nkind (New_Res) = N_Access_Definition
4392         and then Present (Access_To_Subprogram_Definition (New_Res))
4393       then
4394          --  Provide new entities for the formals
4395
4396          Par_Spec := First (Parameter_Specifications
4397                               (Access_To_Subprogram_Definition (New_Res)));
4398          while Present (Par_Spec) loop
4399             Formal := Defining_Identifier (Par_Spec);
4400             Set_Defining_Identifier (Par_Spec,
4401               Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
4402             Next (Par_Spec);
4403          end loop;
4404       end if;
4405
4406       return New_Res;
4407    end Copy_Result_Type;
4408
4409    --------------------
4410    -- Concurrent_Ref --
4411    --------------------
4412
4413    --  The expression returned for a reference to a concurrent object has the
4414    --  form:
4415
4416    --    taskV!(name)._Task_Id
4417
4418    --  for a task, and
4419
4420    --    objectV!(name)._Object
4421
4422    --  for a protected object. For the case of an access to a concurrent
4423    --  object, there is an extra explicit dereference:
4424
4425    --    taskV!(name.all)._Task_Id
4426    --    objectV!(name.all)._Object
4427
4428    --  here taskV and objectV are the types for the associated records, which
4429    --  contain the required _Task_Id and _Object fields for tasks and protected
4430    --  objects, respectively.
4431
4432    --  For the case of a task type name, the expression is
4433
4434    --    Self;
4435
4436    --  i.e. a call to the Self function which returns precisely this Task_Id
4437
4438    --  For the case of a protected type name, the expression is
4439
4440    --    objectR
4441
4442    --  which is a renaming of the _object field of the current object
4443    --  record, passed into protected operations as a parameter.
4444
4445    function Concurrent_Ref (N : Node_Id) return Node_Id is
4446       Loc  : constant Source_Ptr := Sloc (N);
4447       Ntyp : constant Entity_Id  := Etype (N);
4448       Dtyp : Entity_Id;
4449       Sel  : Name_Id;
4450
4451       function Is_Current_Task (T : Entity_Id) return Boolean;
4452       --  Check whether the reference is to the immediately enclosing task
4453       --  type, or to an outer one (rare but legal).
4454
4455       ---------------------
4456       -- Is_Current_Task --
4457       ---------------------
4458
4459       function Is_Current_Task (T : Entity_Id) return Boolean is
4460          Scop : Entity_Id;
4461
4462       begin
4463          Scop := Current_Scope;
4464          while Present (Scop)
4465            and then Scop /= Standard_Standard
4466          loop
4467
4468             if Scop = T then
4469                return True;
4470
4471             elsif Is_Task_Type (Scop) then
4472                return False;
4473
4474             --  If this is a procedure nested within the task type, we must
4475             --  assume that it can be called from an inner task, and therefore
4476             --  cannot treat it as a local reference.
4477
4478             elsif Is_Overloadable (Scop)
4479               and then In_Open_Scopes (T)
4480             then
4481                return False;
4482
4483             else
4484                Scop := Scope (Scop);
4485             end if;
4486          end loop;
4487
4488          --  We know that we are within the task body, so should have found it
4489          --  in scope.
4490
4491          raise Program_Error;
4492       end Is_Current_Task;
4493
4494    --  Start of processing for Concurrent_Ref
4495
4496    begin
4497       if Is_Access_Type (Ntyp) then
4498          Dtyp := Designated_Type (Ntyp);
4499
4500          if Is_Protected_Type (Dtyp) then
4501             Sel := Name_uObject;
4502          else
4503             Sel := Name_uTask_Id;
4504          end if;
4505
4506          return
4507            Make_Selected_Component (Loc,
4508              Prefix =>
4509                Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
4510                  Make_Explicit_Dereference (Loc, N)),
4511              Selector_Name => Make_Identifier (Loc, Sel));
4512
4513       elsif Is_Entity_Name (N)
4514         and then Is_Concurrent_Type (Entity (N))
4515       then
4516          if Is_Task_Type (Entity (N)) then
4517
4518             if Is_Current_Task (Entity (N)) then
4519                return
4520                  Make_Function_Call (Loc,
4521                    Name => New_Reference_To (RTE (RE_Self), Loc));
4522
4523             else
4524                declare
4525                   Decl   : Node_Id;
4526                   T_Self : constant Entity_Id := Make_Temporary (Loc, 'T');
4527                   T_Body : constant Node_Id :=
4528                              Parent (Corresponding_Body (Parent (Entity (N))));
4529
4530                begin
4531                   Decl :=
4532                     Make_Object_Declaration (Loc,
4533                       Defining_Identifier => T_Self,
4534                       Object_Definition   =>
4535                         New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
4536                       Expression          =>
4537                         Make_Function_Call (Loc,
4538                           Name => New_Reference_To (RTE (RE_Self), Loc)));
4539                   Prepend (Decl, Declarations (T_Body));
4540                   Analyze (Decl);
4541                   Set_Scope (T_Self, Entity (N));
4542                   return New_Occurrence_Of (T_Self,  Loc);
4543                end;
4544             end if;
4545
4546          else
4547             pragma Assert (Is_Protected_Type (Entity (N)));
4548
4549             return
4550               New_Reference_To (Find_Protection_Object (Current_Scope), Loc);
4551          end if;
4552
4553       else
4554          if Is_Protected_Type (Ntyp) then
4555             Sel := Name_uObject;
4556
4557          elsif Is_Task_Type (Ntyp) then
4558             Sel := Name_uTask_Id;
4559
4560          else
4561             raise Program_Error;
4562          end if;
4563
4564          return
4565            Make_Selected_Component (Loc,
4566              Prefix        =>
4567                Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
4568                  New_Copy_Tree (N)),
4569              Selector_Name => Make_Identifier (Loc, Sel));
4570       end if;
4571    end Concurrent_Ref;
4572
4573    ------------------------
4574    -- Convert_Concurrent --
4575    ------------------------
4576
4577    function Convert_Concurrent
4578      (N   : Node_Id;
4579       Typ : Entity_Id) return Node_Id
4580    is
4581    begin
4582       if not Is_Concurrent_Type (Typ) then
4583          return N;
4584       else
4585          return
4586            Unchecked_Convert_To
4587              (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
4588       end if;
4589    end Convert_Concurrent;
4590
4591    -------------------------------------
4592    -- Debug_Private_Data_Declarations --
4593    -------------------------------------
4594
4595    procedure Debug_Private_Data_Declarations (Decls : List_Id) is
4596       Debug_Nod : Node_Id;
4597       Decl      : Node_Id;
4598
4599    begin
4600       Decl := First (Decls);
4601       while Present (Decl)
4602         and then not Comes_From_Source (Decl)
4603       loop
4604          --  Declaration for concurrent entity _object and its access type,
4605          --  along with the entry index subtype:
4606          --    type prot_typVP is access prot_typV;
4607          --    _object : prot_typVP := prot_typV (_O);
4608          --    subtype Jnn is <Type of Index> range Low .. High;
4609
4610          if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then
4611             Set_Debug_Info_Needed (Defining_Identifier (Decl));
4612
4613          --  Declaration for the Protection object, discriminals, privals and
4614          --  entry index constant:
4615          --    conc_typR   : protection_typ renames _object._object;
4616          --    discr_nameD : discr_typ renames _object.discr_name;
4617          --    discr_nameD : discr_typ renames _task.discr_name;
4618          --    prival_name : comp_typ  renames _object.comp_name;
4619          --    J : constant Jnn :=
4620          --          Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
4621
4622          elsif Nkind (Decl) = N_Object_Renaming_Declaration then
4623             Set_Debug_Info_Needed (Defining_Identifier (Decl));
4624             Debug_Nod := Debug_Renaming_Declaration (Decl);
4625
4626             if Present (Debug_Nod) then
4627                Insert_After (Decl, Debug_Nod);
4628             end if;
4629          end if;
4630
4631          Next (Decl);
4632       end loop;
4633    end Debug_Private_Data_Declarations;
4634
4635    ----------------------------
4636    -- Entry_Index_Expression --
4637    ----------------------------
4638
4639    function Entry_Index_Expression
4640      (Sloc  : Source_Ptr;
4641       Ent   : Entity_Id;
4642       Index : Node_Id;
4643       Ttyp  : Entity_Id) return Node_Id
4644    is
4645       Expr : Node_Id;
4646       Num  : Node_Id;
4647       Lo   : Node_Id;
4648       Hi   : Node_Id;
4649       Prev : Entity_Id;
4650       S    : Node_Id;
4651
4652    begin
4653       --  The queues of entries and entry families appear in textual order in
4654       --  the associated record. The entry index is computed as the sum of the
4655       --  number of queues for all entries that precede the designated one, to
4656       --  which is added the index expression, if this expression denotes a
4657       --  member of a family.
4658
4659       --  The following is a place holder for the count of simple entries
4660
4661       Num := Make_Integer_Literal (Sloc, 1);
4662
4663       --  We construct an expression which is a series of addition operations.
4664       --  The first operand is the number of single entries that precede this
4665       --  one, the second operand is the index value relative to the start of
4666       --  the referenced family, and the remaining operands are the lengths of
4667       --  the entry families that precede this entry, i.e. the constructed
4668       --  expression is:
4669
4670       --    number_simple_entries +
4671       --      (s'pos (index-value) - s'pos (family'first)) + 1 +
4672       --      family'length + ...
4673
4674       --  where index-value is the given index value, and s is the index
4675       --  subtype (we have to use pos because the subtype might be an
4676       --  enumeration type preventing direct subtraction). Note that the task
4677       --  entry array is one-indexed.
4678
4679       --  The upper bound of the entry family may be a discriminant, so we
4680       --  retrieve the lower bound explicitly to compute offset, rather than
4681       --  using the index subtype which may mention a discriminant.
4682
4683       if Present (Index) then
4684          S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
4685
4686          Expr :=
4687            Make_Op_Add (Sloc,
4688              Left_Opnd  => Num,
4689
4690              Right_Opnd =>
4691                Family_Offset (
4692                  Sloc,
4693                  Make_Attribute_Reference (Sloc,
4694                    Attribute_Name => Name_Pos,
4695                    Prefix => New_Reference_To (Base_Type (S), Sloc),
4696                    Expressions => New_List (Relocate_Node (Index))),
4697                  Type_Low_Bound (S),
4698                  Ttyp,
4699                  False));
4700       else
4701          Expr := Num;
4702       end if;
4703
4704       --  Now add lengths of preceding entries and entry families
4705
4706       Prev := First_Entity (Ttyp);
4707
4708       while Chars (Prev) /= Chars (Ent)
4709         or else (Ekind (Prev) /= Ekind (Ent))
4710         or else not Sem_Ch6.Type_Conformant (Ent, Prev)
4711       loop
4712          if Ekind (Prev) = E_Entry then
4713             Set_Intval (Num, Intval (Num) + 1);
4714
4715          elsif Ekind (Prev) = E_Entry_Family then
4716             S :=
4717               Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
4718             Lo := Type_Low_Bound  (S);
4719             Hi := Type_High_Bound (S);
4720
4721             Expr :=
4722               Make_Op_Add (Sloc,
4723               Left_Opnd  => Expr,
4724               Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
4725
4726          --  Other components are anonymous types to be ignored
4727
4728          else
4729             null;
4730          end if;
4731
4732          Next_Entity (Prev);
4733       end loop;
4734
4735       return Expr;
4736    end Entry_Index_Expression;
4737
4738    ---------------------------
4739    -- Establish_Task_Master --
4740    ---------------------------
4741
4742    procedure Establish_Task_Master (N : Node_Id) is
4743       Call : Node_Id;
4744    begin
4745       if Restriction_Active (No_Task_Hierarchy) = False then
4746          Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
4747          Prepend_To (Declarations (N), Call);
4748          Analyze (Call);
4749       end if;
4750    end Establish_Task_Master;
4751
4752    --------------------------------
4753    -- Expand_Accept_Declarations --
4754    --------------------------------
4755
4756    --  Part of the expansion of an accept statement involves the creation of
4757    --  a declaration that can be referenced from the statement sequence of
4758    --  the accept:
4759
4760    --    Ann : Address;
4761
4762    --  This declaration is inserted immediately before the accept statement
4763    --  and it is important that it be inserted before the statements of the
4764    --  statement sequence are analyzed. Thus it would be too late to create
4765    --  this declaration in the Expand_N_Accept_Statement routine, which is
4766    --  why there is a separate procedure to be called directly from Sem_Ch9.
4767
4768    --  Ann is used to hold the address of the record containing the parameters
4769    --  (see Expand_N_Entry_Call for more details on how this record is built).
4770    --  References to the parameters do an unchecked conversion of this address
4771    --  to a pointer to the required record type, and then access the field that
4772    --  holds the value of the required parameter. The entity for the address
4773    --  variable is held as the top stack element (i.e. the last element) of the
4774    --  Accept_Address stack in the corresponding entry entity, and this element
4775    --  must be set in place  before the statements are processed.
4776
4777    --  The above description applies to the case of a stand alone accept
4778    --  statement, i.e. one not appearing as part of a select alternative.
4779
4780    --  For the case of an accept that appears as part of a select alternative
4781    --  of a selective accept, we must still create the declaration right away,
4782    --  since Ann is needed immediately, but there is an important difference:
4783
4784    --    The declaration is inserted before the selective accept, not before
4785    --    the accept statement (which is not part of a list anyway, and so would
4786    --    not accommodate inserted declarations)
4787
4788    --    We only need one address variable for the entire selective accept. So
4789    --    the Ann declaration is created only for the first accept alternative,
4790    --    and subsequent accept alternatives reference the same Ann variable.
4791
4792    --  We can distinguish the two cases by seeing whether the accept statement
4793    --  is part of a list. If not, then it must be in an accept alternative.
4794
4795    --  To expand the requeue statement, a label is provided at the end of the
4796    --  accept statement or alternative of which it is a part, so that the
4797    --  statement can be skipped after the requeue is complete. This label is
4798    --  created here rather than during the expansion of the accept statement,
4799    --  because it will be needed by any requeue statements within the accept,
4800    --  which are expanded before the accept.
4801
4802    procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
4803       Loc    : constant Source_Ptr := Sloc (N);
4804       Stats  : constant Node_Id    := Handled_Statement_Sequence (N);
4805       Ann    : Entity_Id           := Empty;
4806       Adecl  : Node_Id;
4807       Lab_Id : Node_Id;
4808       Lab    : Node_Id;
4809       Ldecl  : Node_Id;
4810       Ldecl2 : Node_Id;
4811
4812    begin
4813       if Expander_Active then
4814
4815          --  If we have no handled statement sequence, we may need to build
4816          --  a dummy sequence consisting of a null statement. This can be
4817          --  skipped if the trivial accept optimization is permitted.
4818
4819          if not Trivial_Accept_OK
4820            and then
4821              (No (Stats) or else Null_Statements (Statements (Stats)))
4822          then
4823             Set_Handled_Statement_Sequence (N,
4824               Make_Handled_Sequence_Of_Statements (Loc,
4825                 New_List (Make_Null_Statement (Loc))));
4826          end if;
4827
4828          --  Create and declare two labels to be placed at the end of the
4829          --  accept statement. The first label is used to allow requeues to
4830          --  skip the remainder of entry processing. The second label is used
4831          --  to skip the remainder of entry processing if the rendezvous
4832          --  completes in the middle of the accept body.
4833
4834          if Present (Handled_Statement_Sequence (N)) then
4835             declare
4836                Ent : Entity_Id;
4837
4838             begin
4839                Ent := Make_Temporary (Loc, 'L');
4840                Lab_Id := New_Reference_To (Ent, Loc);
4841                Lab := Make_Label (Loc, Lab_Id);
4842                Ldecl :=
4843                  Make_Implicit_Label_Declaration (Loc,
4844                    Defining_Identifier  => Ent,
4845                    Label_Construct      => Lab);
4846                Append (Lab, Statements (Handled_Statement_Sequence (N)));
4847
4848                Ent := Make_Temporary (Loc, 'L');
4849                Lab_Id := New_Reference_To (Ent, Loc);
4850                Lab := Make_Label (Loc, Lab_Id);
4851                Ldecl2 :=
4852                  Make_Implicit_Label_Declaration (Loc,
4853                    Defining_Identifier  => Ent,
4854                    Label_Construct      => Lab);
4855                Append (Lab, Statements (Handled_Statement_Sequence (N)));
4856             end;
4857
4858          else
4859             Ldecl := Empty;
4860             Ldecl2 := Empty;
4861          end if;
4862
4863          --  Case of stand alone accept statement
4864
4865          if Is_List_Member (N) then
4866
4867             if Present (Handled_Statement_Sequence (N)) then
4868                Ann := Make_Temporary (Loc, 'A');
4869
4870                Adecl :=
4871                  Make_Object_Declaration (Loc,
4872                    Defining_Identifier => Ann,
4873                    Object_Definition =>
4874                      New_Reference_To (RTE (RE_Address), Loc));
4875
4876                Insert_Before (N, Adecl);
4877                Analyze (Adecl);
4878
4879                Insert_Before (N, Ldecl);
4880                Analyze (Ldecl);
4881
4882                Insert_Before (N, Ldecl2);
4883                Analyze (Ldecl2);
4884             end if;
4885
4886          --  Case of accept statement which is in an accept alternative
4887
4888          else
4889             declare
4890                Acc_Alt : constant Node_Id := Parent (N);
4891                Sel_Acc : constant Node_Id := Parent (Acc_Alt);
4892                Alt     : Node_Id;
4893
4894             begin
4895                pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
4896                pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
4897
4898                --  ??? Consider a single label for select statements
4899
4900                if Present (Handled_Statement_Sequence (N)) then
4901                   Prepend (Ldecl2,
4902                      Statements (Handled_Statement_Sequence (N)));
4903                   Analyze (Ldecl2);
4904
4905                   Prepend (Ldecl,
4906                      Statements (Handled_Statement_Sequence (N)));
4907                   Analyze (Ldecl);
4908                end if;
4909
4910                --  Find first accept alternative of the selective accept. A
4911                --  valid selective accept must have at least one accept in it.
4912
4913                Alt := First (Select_Alternatives (Sel_Acc));
4914
4915                while Nkind (Alt) /= N_Accept_Alternative loop
4916                   Next (Alt);
4917                end loop;
4918
4919                --  If we are the first accept statement, then we have to create
4920                --  the Ann variable, as for the stand alone case, except that
4921                --  it is inserted before the selective accept. Similarly, a
4922                --  label for requeue expansion must be declared.
4923
4924                if N = Accept_Statement (Alt) then
4925                   Ann := Make_Temporary (Loc, 'A');
4926                   Adecl :=
4927                     Make_Object_Declaration (Loc,
4928                       Defining_Identifier => Ann,
4929                       Object_Definition =>
4930                         New_Reference_To (RTE (RE_Address), Loc));
4931
4932                   Insert_Before (Sel_Acc, Adecl);
4933                   Analyze (Adecl);
4934
4935                --  If we are not the first accept statement, then find the Ann
4936                --  variable allocated by the first accept and use it.
4937
4938                else
4939                   Ann :=
4940                     Node (Last_Elmt (Accept_Address
4941                       (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
4942                end if;
4943             end;
4944          end if;
4945
4946          --  Merge here with Ann either created or referenced, and Adecl
4947          --  pointing to the corresponding declaration. Remaining processing
4948          --  is the same for the two cases.
4949
4950          if Present (Ann) then
4951             Append_Elmt (Ann, Accept_Address (Ent));
4952             Set_Debug_Info_Needed (Ann);
4953          end if;
4954
4955          --  Create renaming declarations for the entry formals. Each reference
4956          --  to a formal becomes a dereference of a component of the parameter
4957          --  block, whose address is held in Ann. These declarations are
4958          --  eventually inserted into the accept block, and analyzed there so
4959          --  that they have the proper scope for gdb and do not conflict with
4960          --  other declarations.
4961
4962          if Present (Parameter_Specifications (N))
4963            and then Present (Handled_Statement_Sequence (N))
4964          then
4965             declare
4966                Comp   : Entity_Id;
4967                Decl   : Node_Id;
4968                Formal : Entity_Id;
4969                New_F  : Entity_Id;
4970
4971             begin
4972                Push_Scope (Ent);
4973                Formal := First_Formal (Ent);
4974
4975                while Present (Formal) loop
4976                   Comp  := Entry_Component (Formal);
4977                   New_F :=
4978                     Make_Defining_Identifier (Loc, Chars (Formal));
4979
4980                   Set_Etype (New_F, Etype (Formal));
4981                   Set_Scope (New_F, Ent);
4982
4983                   --  Now we set debug info needed on New_F even though it does
4984                   --  not come from source, so that the debugger will get the
4985                   --  right information for these generated names.
4986
4987                   Set_Debug_Info_Needed (New_F);
4988
4989                   if Ekind (Formal) = E_In_Parameter then
4990                      Set_Ekind (New_F, E_Constant);
4991                   else
4992                      Set_Ekind (New_F, E_Variable);
4993                      Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
4994                   end if;
4995
4996                   Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
4997
4998                   Decl :=
4999                     Make_Object_Renaming_Declaration (Loc,
5000                       Defining_Identifier =>
5001                         New_F,
5002                       Subtype_Mark =>
5003                         New_Reference_To (Etype (Formal), Loc),
5004                       Name =>
5005                         Make_Explicit_Dereference (Loc,
5006                           Make_Selected_Component (Loc,
5007                             Prefix =>
5008                               Unchecked_Convert_To (
5009                                 Entry_Parameters_Type (Ent),
5010                                 New_Reference_To (Ann, Loc)),
5011                             Selector_Name =>
5012                               New_Reference_To (Comp, Loc))));
5013
5014                   if No (Declarations (N)) then
5015                      Set_Declarations (N, New_List);
5016                   end if;
5017
5018                   Append (Decl, Declarations (N));
5019                   Set_Renamed_Object (Formal, New_F);
5020                   Next_Formal (Formal);
5021                end loop;
5022
5023                End_Scope;
5024             end;
5025          end if;
5026       end if;
5027    end Expand_Accept_Declarations;
5028
5029    ---------------------------------------------
5030    -- Expand_Access_Protected_Subprogram_Type --
5031    ---------------------------------------------
5032
5033    procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
5034       Loc    : constant Source_Ptr := Sloc (N);
5035       Comps  : List_Id;
5036       T      : constant Entity_Id  := Defining_Identifier (N);
5037       D_T    : constant Entity_Id  := Designated_Type (T);
5038       D_T2   : constant Entity_Id  := Make_Temporary (Loc, 'D');
5039       E_T    : constant Entity_Id  := Make_Temporary (Loc, 'E');
5040       P_List : constant List_Id    := Build_Protected_Spec
5041                                         (N, RTE (RE_Address), D_T, False);
5042       Decl1  : Node_Id;
5043       Decl2  : Node_Id;
5044       Def1   : Node_Id;
5045
5046    begin
5047       --  Create access to subprogram with full signature
5048
5049       if Etype (D_T) /= Standard_Void_Type then
5050          Def1 :=
5051            Make_Access_Function_Definition (Loc,
5052              Parameter_Specifications => P_List,
5053              Result_Definition =>
5054                Copy_Result_Type (Result_Definition (Type_Definition (N))));
5055
5056       else
5057          Def1 :=
5058            Make_Access_Procedure_Definition (Loc,
5059              Parameter_Specifications => P_List);
5060       end if;
5061
5062       Decl1 :=
5063         Make_Full_Type_Declaration (Loc,
5064           Defining_Identifier => D_T2,
5065           Type_Definition => Def1);
5066
5067       Insert_After (N, Decl1);
5068       Analyze (Decl1);
5069
5070       --  Associate the access to subprogram with its original access to
5071       --  protected subprogram type. Needed by the backend to know that this
5072       --  type corresponds with an access to protected subprogram type.
5073
5074       Set_Original_Access_Type (D_T2, T);
5075
5076       --  Create Equivalent_Type, a record with two components for an access to
5077       --  object and an access to subprogram.
5078
5079       Comps := New_List (
5080         Make_Component_Declaration (Loc,
5081           Defining_Identifier => Make_Temporary (Loc, 'P'),
5082           Component_Definition =>
5083             Make_Component_Definition (Loc,
5084               Aliased_Present => False,
5085               Subtype_Indication =>
5086                 New_Occurrence_Of (RTE (RE_Address), Loc))),
5087
5088         Make_Component_Declaration (Loc,
5089           Defining_Identifier  => Make_Temporary (Loc, 'S'),
5090           Component_Definition =>
5091             Make_Component_Definition (Loc,
5092               Aliased_Present    => False,
5093               Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
5094
5095       Decl2 :=
5096         Make_Full_Type_Declaration (Loc,
5097           Defining_Identifier => E_T,
5098           Type_Definition =>
5099             Make_Record_Definition (Loc,
5100               Component_List =>
5101                 Make_Component_List (Loc,
5102                   Component_Items => Comps)));
5103
5104       Insert_After (Decl1, Decl2);
5105       Analyze (Decl2);
5106       Set_Equivalent_Type (T, E_T);
5107    end Expand_Access_Protected_Subprogram_Type;
5108
5109    --------------------------
5110    -- Expand_Entry_Barrier --
5111    --------------------------
5112
5113    procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
5114       Cond      : constant Node_Id   :=
5115                     Condition (Entry_Body_Formal_Part (N));
5116       Prot      : constant Entity_Id := Scope (Ent);
5117       Spec_Decl : constant Node_Id   := Parent (Prot);
5118       Func      : Node_Id;
5119       B_F       : Node_Id;
5120       Body_Decl : Node_Id;
5121
5122    begin
5123       if No_Run_Time_Mode then
5124          Error_Msg_CRT ("entry barrier", N);
5125          return;
5126       end if;
5127
5128       --  The body of the entry barrier must be analyzed in the context of the
5129       --  protected object, but its scope is external to it, just as any other
5130       --  unprotected version of a protected operation. The specification has
5131       --  been produced when the protected type declaration was elaborated. We
5132       --  build the body, insert it in the enclosing scope, but analyze it in
5133       --  the current context. A more uniform approach would be to treat the
5134       --  barrier just as a protected function, and discard the protected
5135       --  version of it because it is never called.
5136
5137       if Expander_Active then
5138          B_F := Build_Barrier_Function (N, Ent, Prot);
5139          Func := Barrier_Function (Ent);
5140          Set_Corresponding_Spec (B_F, Func);
5141
5142          Body_Decl := Parent (Corresponding_Body (Spec_Decl));
5143
5144          if Nkind (Parent (Body_Decl)) = N_Subunit then
5145             Body_Decl := Corresponding_Stub (Parent (Body_Decl));
5146          end if;
5147
5148          Insert_Before_And_Analyze (Body_Decl, B_F);
5149
5150          Set_Discriminals (Spec_Decl);
5151          Set_Scope (Func, Scope (Prot));
5152
5153       else
5154          Analyze_And_Resolve (Cond, Any_Boolean);
5155       end if;
5156
5157       --  The Ravenscar profile restricts barriers to simple variables declared
5158       --  within the protected object. We also allow Boolean constants, since
5159       --  these appear in several published examples and are also allowed by
5160       --  the Aonix compiler.
5161
5162       --  Note that after analysis variables in this context will be replaced
5163       --  by the corresponding prival, that is to say a renaming of a selected
5164       --  component of the form _Object.Var. If expansion is disabled, as
5165       --  within a generic, we check that the entity appears in the current
5166       --  scope.
5167
5168       if Is_Entity_Name (Cond) then
5169
5170          --  A small optimization of useless renamings. If the scope of the
5171          --  entity of the condition is not the barrier function, then the
5172          --  condition does not reference any of the generated renamings
5173          --  within the function.
5174
5175          if Expander_Active
5176            and then Scope (Entity (Cond)) /= Func
5177          then
5178             Set_Declarations (B_F, Empty_List);
5179          end if;
5180
5181          if Entity (Cond) = Standard_False
5182               or else
5183             Entity (Cond) = Standard_True
5184          then
5185             return;
5186
5187          elsif not Expander_Active
5188            and then Scope (Entity (Cond)) = Current_Scope
5189          then
5190             return;
5191
5192          --  Check for case of _object.all.field (note that the explicit
5193          --  dereference gets inserted by analyze/expand of _object.field)
5194
5195          elsif Present (Renamed_Object (Entity (Cond)))
5196            and then
5197              Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component
5198            and then
5199              Chars
5200                (Prefix
5201                  (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject
5202          then
5203             return;
5204          end if;
5205       end if;
5206
5207       --  It is not a boolean variable or literal, so check the restriction
5208
5209       Check_Restriction (Simple_Barriers, Cond);
5210    end Expand_Entry_Barrier;
5211
5212    ------------------------------
5213    -- Expand_N_Abort_Statement --
5214    ------------------------------
5215
5216    --  Expand abort T1, T2, .. Tn; into:
5217    --    Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
5218
5219    procedure Expand_N_Abort_Statement (N : Node_Id) is
5220       Loc    : constant Source_Ptr := Sloc (N);
5221       Tlist  : constant List_Id    := Names (N);
5222       Count  : Nat;
5223       Aggr   : Node_Id;
5224       Tasknm : Node_Id;
5225
5226    begin
5227       Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
5228       Count := 0;
5229
5230       Tasknm := First (Tlist);
5231
5232       while Present (Tasknm) loop
5233          Count := Count + 1;
5234
5235          --  A task interface class-wide type object is being aborted.
5236          --  Retrieve its _task_id by calling a dispatching routine.
5237
5238          if Ada_Version >= Ada_2005
5239            and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
5240            and then Is_Interface (Etype (Tasknm))
5241            and then Is_Task_Interface (Etype (Tasknm))
5242          then
5243             Append_To (Component_Associations (Aggr),
5244               Make_Component_Association (Loc,
5245                 Choices => New_List (
5246                   Make_Integer_Literal (Loc, Count)),
5247                 Expression =>
5248
5249                   --  Task_Id (Tasknm._disp_get_task_id)
5250
5251                   Make_Unchecked_Type_Conversion (Loc,
5252                     Subtype_Mark =>
5253                       New_Reference_To (RTE (RO_ST_Task_Id), Loc),
5254                     Expression =>
5255                       Make_Selected_Component (Loc,
5256                         Prefix        => New_Copy_Tree (Tasknm),
5257                         Selector_Name =>
5258                           Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
5259
5260          else
5261             Append_To (Component_Associations (Aggr),
5262               Make_Component_Association (Loc,
5263                 Choices => New_List (
5264                   Make_Integer_Literal (Loc, Count)),
5265                 Expression => Concurrent_Ref (Tasknm)));
5266          end if;
5267
5268          Next (Tasknm);
5269       end loop;
5270
5271       Rewrite (N,
5272         Make_Procedure_Call_Statement (Loc,
5273           Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc),
5274           Parameter_Associations => New_List (
5275             Make_Qualified_Expression (Loc,
5276               Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc),
5277               Expression => Aggr))));
5278
5279       Analyze (N);
5280    end Expand_N_Abort_Statement;
5281
5282    -------------------------------
5283    -- Expand_N_Accept_Statement --
5284    -------------------------------
5285
5286    --  This procedure handles expansion of accept statements that stand
5287    --  alone, i.e. they are not part of an accept alternative. The expansion
5288    --  of accept statement in accept alternatives is handled by the routines
5289    --  Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
5290    --  following description applies only to stand alone accept statements.
5291
5292    --  If there is no handled statement sequence, or only null statements,
5293    --  then this is called a trivial accept, and the expansion is:
5294
5295    --    Accept_Trivial (entry-index)
5296
5297    --  If there is a handled statement sequence, then the expansion is:
5298
5299    --    Ann : Address;
5300    --    {Lnn : Label}
5301
5302    --    begin
5303    --       begin
5304    --          Accept_Call (entry-index, Ann);
5305    --          Renaming_Declarations for formals
5306    --          <statement sequence from N_Accept_Statement node>
5307    --          Complete_Rendezvous;
5308    --          <<Lnn>>
5309    --
5310    --       exception
5311    --          when ... =>
5312    --             <exception handler from N_Accept_Statement node>
5313    --             Complete_Rendezvous;
5314    --          when ... =>
5315    --             <exception handler from N_Accept_Statement node>
5316    --             Complete_Rendezvous;
5317    --          ...
5318    --       end;
5319
5320    --    exception
5321    --       when all others =>
5322    --          Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
5323    --    end;
5324
5325    --  The first three declarations were already inserted ahead of the accept
5326    --  statement by the Expand_Accept_Declarations procedure, which was called
5327    --  directly from the semantics during analysis of the accept statement,
5328    --  before analyzing its contained statements.
5329
5330    --  The declarations from the N_Accept_Statement, as noted in Sinfo, come
5331    --  from possible expansion activity (the original source of course does
5332    --  not have any declarations associated with the accept statement, since
5333    --  an accept statement has no declarative part). In particular, if the
5334    --  expander is active, the first such declaration is the declaration of
5335    --  the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
5336    --
5337    --  The two blocks are merged into a single block if the inner block has
5338    --  no exception handlers, but otherwise two blocks are required, since
5339    --  exceptions might be raised in the exception handlers of the inner
5340    --  block, and Exceptional_Complete_Rendezvous must be called.
5341
5342    procedure Expand_N_Accept_Statement (N : Node_Id) is
5343       Loc     : constant Source_Ptr := Sloc (N);
5344       Stats   : constant Node_Id    := Handled_Statement_Sequence (N);
5345       Ename   : constant Node_Id    := Entry_Direct_Name (N);
5346       Eindx   : constant Node_Id    := Entry_Index (N);
5347       Eent    : constant Entity_Id  := Entity (Ename);
5348       Acstack : constant Elist_Id   := Accept_Address (Eent);
5349       Ann     : constant Entity_Id  := Node (Last_Elmt (Acstack));
5350       Ttyp    : constant Entity_Id  := Etype (Scope (Eent));
5351       Blkent  : Entity_Id;
5352       Call    : Node_Id;
5353       Block   : Node_Id;
5354
5355    --  Start of processing for Expand_N_Accept_Statement
5356
5357    begin
5358       --  If accept statement is not part of a list, then its parent must be
5359       --  an accept alternative, and, as described above, we do not do any
5360       --  expansion for such accept statements at this level.
5361
5362       if not Is_List_Member (N) then
5363          pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
5364          return;
5365
5366       --  Trivial accept case (no statement sequence, or null statements).
5367       --  If the accept statement has declarations, then just insert them
5368       --  before the procedure call.
5369
5370       elsif Trivial_Accept_OK
5371         and then (No (Stats) or else Null_Statements (Statements (Stats)))
5372       then
5373          --  Remove declarations for renamings, because the parameter block
5374          --  will not be assigned.
5375
5376          declare
5377             D      : Node_Id;
5378             Next_D : Node_Id;
5379
5380          begin
5381             D := First (Declarations (N));
5382
5383             while Present (D) loop
5384                Next_D := Next (D);
5385                if Nkind (D) = N_Object_Renaming_Declaration then
5386                   Remove (D);
5387                end if;
5388
5389                D := Next_D;
5390             end loop;
5391          end;
5392
5393          if Present (Declarations (N)) then
5394             Insert_Actions (N, Declarations (N));
5395          end if;
5396
5397          Rewrite (N,
5398            Make_Procedure_Call_Statement (Loc,
5399              Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc),
5400              Parameter_Associations => New_List (
5401                Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
5402
5403          Analyze (N);
5404
5405          --  Discard Entry_Address that was created for it, so it will not be
5406          --  emitted if this accept statement is in the statement part of a
5407          --  delay alternative.
5408
5409          if Present (Stats) then
5410             Remove_Last_Elmt (Acstack);
5411          end if;
5412
5413       --  Case of statement sequence present
5414
5415       else
5416          --  Construct the block, using the declarations from the accept
5417          --  statement if any to initialize the declarations of the block.
5418
5419          Blkent := Make_Temporary (Loc, 'A');
5420          Set_Ekind (Blkent, E_Block);
5421          Set_Etype (Blkent, Standard_Void_Type);
5422          Set_Scope (Blkent, Current_Scope);
5423
5424          Block :=
5425            Make_Block_Statement (Loc,
5426              Identifier                 => New_Reference_To (Blkent, Loc),
5427              Declarations               => Declarations (N),
5428              Handled_Statement_Sequence => Build_Accept_Body (N));
5429
5430          --  For the analysis of the generated declarations, the parent node
5431          --  must be properly set.
5432
5433          Set_Parent (Block, Parent (N));
5434
5435          --  Prepend call to Accept_Call to main statement sequence If the
5436          --  accept has exception handlers, the statement sequence is wrapped
5437          --  in a block. Insert call and renaming declarations in the
5438          --  declarations of the block, so they are elaborated before the
5439          --  handlers.
5440
5441          Call :=
5442            Make_Procedure_Call_Statement (Loc,
5443              Name => New_Reference_To (RTE (RE_Accept_Call), Loc),
5444              Parameter_Associations => New_List (
5445                Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
5446                New_Reference_To (Ann, Loc)));
5447
5448          if Parent (Stats) = N then
5449             Prepend (Call, Statements (Stats));
5450          else
5451             Set_Declarations
5452               (Parent (Stats),
5453                 New_List (Call));
5454          end if;
5455
5456          Analyze (Call);
5457
5458          Push_Scope (Blkent);
5459
5460          declare
5461             D      : Node_Id;
5462             Next_D : Node_Id;
5463             Typ    : Entity_Id;
5464
5465          begin
5466             D := First (Declarations (N));
5467             while Present (D) loop
5468                Next_D := Next (D);
5469
5470                if Nkind (D) = N_Object_Renaming_Declaration then
5471
5472                   --  The renaming declarations for the formals were created
5473                   --  during analysis of the accept statement, and attached to
5474                   --  the list of declarations. Place them now in the context
5475                   --  of the accept block or subprogram.
5476
5477                   Remove (D);
5478                   Typ := Entity (Subtype_Mark (D));
5479                   Insert_After (Call, D);
5480                   Analyze (D);
5481
5482                   --  If the formal is class_wide, it does not have an actual
5483                   --  subtype. The analysis of the renaming declaration creates
5484                   --  one, but we need to retain the class-wide nature of the
5485                   --  entity.
5486
5487                   if Is_Class_Wide_Type (Typ) then
5488                      Set_Etype (Defining_Identifier (D), Typ);
5489                   end if;
5490
5491                end if;
5492
5493                D := Next_D;
5494             end loop;
5495          end;
5496
5497          End_Scope;
5498
5499          --  Replace the accept statement by the new block
5500
5501          Rewrite (N, Block);
5502          Analyze (N);
5503
5504          --  Last step is to unstack the Accept_Address value
5505
5506          Remove_Last_Elmt (Acstack);
5507       end if;
5508    end Expand_N_Accept_Statement;
5509
5510    ----------------------------------
5511    -- Expand_N_Asynchronous_Select --
5512    ----------------------------------
5513
5514    --  This procedure assumes that the trigger statement is an entry call or
5515    --  a dispatching procedure call. A delay alternative should already have
5516    --  been expanded into an entry call to the appropriate delay object Wait
5517    --  entry.
5518
5519    --  If the trigger is a task entry call, the select is implemented with
5520    --  a Task_Entry_Call:
5521
5522    --    declare
5523    --       B : Boolean;
5524    --       C : Boolean;
5525    --       P : parms := (parm, parm, parm);
5526
5527    --        --  Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5528
5529    --       procedure _clean is
5530    --       begin
5531    --          ...
5532    --          Cancel_Task_Entry_Call (C);
5533    --          ...
5534    --       end _clean;
5535
5536    --    begin
5537    --       Abort_Defer;
5538    --       Task_Entry_Call
5539    --         (<acceptor-task>,    --  Acceptor
5540    --          <entry-index>,      --  E
5541    --          P'Address,          --  Uninterpreted_Data
5542    --          Asynchronous_Call,  --  Mode
5543    --          B);                 --  Rendezvous_Successful
5544
5545    --       begin
5546    --          begin
5547    --             Abort_Undefer;
5548    --             <abortable-part>
5549    --          at end
5550    --             _clean;  --  Added by Exp_Ch7.Expand_Cleanup_Actions
5551    --          end;
5552    --       exception
5553    --          when Abort_Signal => Abort_Undefer;
5554    --       end;
5555
5556    --       parm := P.param;
5557    --       parm := P.param;
5558    --       ...
5559    --       if not C then
5560    --          <triggered-statements>
5561    --       end if;
5562    --    end;
5563
5564    --  Note that Build_Simple_Entry_Call is used to expand the entry of the
5565    --  asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
5566    --  as follows:
5567
5568    --    declare
5569    --       P : parms := (parm, parm, parm);
5570    --    begin
5571    --       Call_Simple (acceptor-task, entry-index, P'Address);
5572    --       parm := P.param;
5573    --       parm := P.param;
5574    --       ...
5575    --    end;
5576
5577    --  so the task at hand is to convert the latter expansion into the former
5578
5579    --  If the trigger is a protected entry call, the select is implemented
5580    --  with Protected_Entry_Call:
5581
5582    --  declare
5583    --     P   : E1_Params := (param, param, param);
5584    --     Bnn : Communications_Block;
5585
5586    --  begin
5587    --     declare
5588
5589    --        --  Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5590
5591    --        procedure _clean is
5592    --        begin
5593    --           ...
5594    --           if Enqueued (Bnn) then
5595    --              Cancel_Protected_Entry_Call (Bnn);
5596    --           end if;
5597    --           ...
5598    --        end _clean;
5599
5600    --     begin
5601    --        begin
5602    --           Protected_Entry_Call
5603    --             (po._object'Access,  --  Object
5604    --              <entry index>,      --  E
5605    --              P'Address,          --  Uninterpreted_Data
5606    --              Asynchronous_Call,  --  Mode
5607    --              Bnn);               --  Block
5608
5609    --           if Enqueued (Bnn) then
5610    --              <abortable-part>
5611    --           end if;
5612    --        at end
5613    --           _clean;  --  Added by Exp_Ch7.Expand_Cleanup_Actions
5614    --        end;
5615    --     exception
5616    --        when Abort_Signal => Abort_Undefer;
5617    --     end;
5618
5619    --     if not Cancelled (Bnn) then
5620    --        <triggered-statements>
5621    --     end if;
5622    --  end;
5623
5624    --  Build_Simple_Entry_Call is used to expand the all to a simple protected
5625    --  entry call:
5626
5627    --  declare
5628    --     P   : E1_Params := (param, param, param);
5629    --     Bnn : Communications_Block;
5630
5631    --  begin
5632    --     Protected_Entry_Call
5633    --       (po._object'Access,  --  Object
5634    --        <entry index>,      --  E
5635    --        P'Address,          --  Uninterpreted_Data
5636    --        Simple_Call,        --  Mode
5637    --        Bnn);               --  Block
5638    --     parm := P.param;
5639    --     parm := P.param;
5640    --       ...
5641    --  end;
5642
5643    --  Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
5644    --  expanded into:
5645
5646    --    declare
5647    --       B   : Boolean := False;
5648    --       Bnn : Communication_Block;
5649    --       C   : Ada.Tags.Prim_Op_Kind;
5650    --       D   : System.Storage_Elements.Dummy_Communication_Block;
5651    --       K   : Ada.Tags.Tagged_Kind :=
5652    --               Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5653    --       P   : Parameters := (Param1 .. ParamN);
5654    --       S   : Integer;
5655    --       U   : Boolean;
5656
5657    --    begin
5658    --       if K = Ada.Tags.TK_Limited_Tagged then
5659    --          <dispatching-call>;
5660    --          <triggering-statements>;
5661
5662    --       else
5663    --          S :=
5664    --            Ada.Tags.Get_Offset_Index
5665    --              (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
5666
5667    --          _Disp_Get_Prim_Op_Kind (<object>, S, C);
5668
5669    --          if C = POK_Protected_Entry then
5670    --             declare
5671    --                procedure _clean is
5672    --                begin
5673    --                   if Enqueued (Bnn) then
5674    --                      Cancel_Protected_Entry_Call (Bnn);
5675    --                   end if;
5676    --                end _clean;
5677
5678    --             begin
5679    --                begin
5680    --                   _Disp_Asynchronous_Select
5681    --                     (<object>, S, P'Address, D, B);
5682    --                   Bnn := Communication_Block (D);
5683
5684    --                   Param1 := P.Param1;
5685    --                   ...
5686    --                   ParamN := P.ParamN;
5687
5688    --                   if Enqueued (Bnn) then
5689    --                      <abortable-statements>
5690    --                   end if;
5691    --                at end
5692    --                   _clean;  --  Added by Exp_Ch7.Expand_Cleanup_Actions
5693    --                end;
5694    --             exception
5695    --                when Abort_Signal => Abort_Undefer;
5696    --             end;
5697
5698    --             if not Cancelled (Bnn) then
5699    --                <triggering-statements>
5700    --             end if;
5701
5702    --          elsif C = POK_Task_Entry then
5703    --             declare
5704    --                procedure _clean is
5705    --                begin
5706    --                   Cancel_Task_Entry_Call (U);
5707    --                end _clean;
5708
5709    --             begin
5710    --                Abort_Defer;
5711
5712    --                _Disp_Asynchronous_Select
5713    --                  (<object>, S, P'Address, D, B);
5714    --                Bnn := Communication_Bloc (D);
5715
5716    --                Param1 := P.Param1;
5717    --                ...
5718    --                ParamN := P.ParamN;
5719
5720    --                begin
5721    --                   begin
5722    --                      Abort_Undefer;
5723    --                      <abortable-statements>
5724    --                   at end
5725    --                      _clean;  --  Added by Exp_Ch7.Expand_Cleanup_Actions
5726    --                   end;
5727    --                exception
5728    --                   when Abort_Signal => Abort_Undefer;
5729    --                end;
5730
5731    --                if not U then
5732    --                   <triggering-statements>
5733    --                end if;
5734    --             end;
5735
5736    --          else
5737    --             <dispatching-call>;
5738    --             <triggering-statements>
5739    --          end if;
5740    --       end if;
5741    --    end;
5742
5743    --  The job is to convert this to the asynchronous form
5744
5745    --  If the trigger is a delay statement, it will have been expanded into a
5746    --  call to one of the GNARL delay procedures. This routine will convert
5747    --  this into a protected entry call on a delay object and then continue
5748    --  processing as for a protected entry call trigger. This requires
5749    --  declaring a Delay_Block object and adding a pointer to this object to
5750    --  the parameter list of the delay procedure to form the parameter list of
5751    --  the entry call. This object is used by the runtime to queue the delay
5752    --  request.
5753
5754    --  For a description of the use of P and the assignments after the call,
5755    --  see Expand_N_Entry_Call_Statement.
5756
5757    procedure Expand_N_Asynchronous_Select (N : Node_Id) is
5758       Loc    : constant Source_Ptr := Sloc (N);
5759       Abrt   : constant Node_Id    := Abortable_Part (N);
5760       Astats : constant List_Id    := Statements (Abrt);
5761       Trig   : constant Node_Id    := Triggering_Alternative (N);
5762       Tstats : constant List_Id    := Statements (Trig);
5763
5764       Abort_Block_Ent   : Entity_Id;
5765       Abortable_Block   : Node_Id;
5766       Actuals           : List_Id;
5767       Blk_Ent           : Entity_Id;
5768       Blk_Typ           : Entity_Id;
5769       Call              : Node_Id;
5770       Call_Ent          : Entity_Id;
5771       Cancel_Param      : Entity_Id;
5772       Cleanup_Block     : Node_Id;
5773       Cleanup_Block_Ent : Entity_Id;
5774       Cleanup_Stmts     : List_Id;
5775       Conc_Typ_Stmts    : List_Id;
5776       Concval           : Node_Id;
5777       Dblock_Ent        : Entity_Id;
5778       Decl              : Node_Id;
5779       Decls             : List_Id;
5780       Ecall             : Node_Id;
5781       Ename             : Node_Id;
5782       Enqueue_Call      : Node_Id;
5783       Formals           : List_Id;
5784       Hdle              : List_Id;
5785       Index             : Node_Id;
5786       Lim_Typ_Stmts     : List_Id;
5787       N_Orig            : Node_Id;
5788       Obj               : Entity_Id;
5789       Param             : Node_Id;
5790       Params            : List_Id;
5791       Pdef              : Entity_Id;
5792       ProtE_Stmts       : List_Id;
5793       ProtP_Stmts       : List_Id;
5794       Stmt              : Node_Id;
5795       Stmts             : List_Id;
5796       Target_Undefer    : RE_Id;
5797       TaskE_Stmts       : List_Id;
5798       Undefer_Args      : List_Id := No_List;
5799
5800       B   : Entity_Id;  --  Call status flag
5801       Bnn : Entity_Id;  --  Communication block
5802       C   : Entity_Id;  --  Call kind
5803       K   : Entity_Id;  --  Tagged kind
5804       P   : Entity_Id;  --  Parameter block
5805       S   : Entity_Id;  --  Primitive operation slot
5806       T   : Entity_Id;  --  Additional status flag
5807
5808    begin
5809       Blk_Ent := Make_Temporary (Loc, 'A');
5810       Ecall   := Triggering_Statement (Trig);
5811
5812       --  The arguments in the call may require dynamic allocation, and the
5813       --  call statement may have been transformed into a block. The block
5814       --  may contain additional declarations for internal entities, and the
5815       --  original call is found by sequential search.
5816
5817       if Nkind (Ecall) = N_Block_Statement then
5818          Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
5819          while not Nkind_In (Ecall, N_Procedure_Call_Statement,
5820                                     N_Entry_Call_Statement)
5821          loop
5822             Next (Ecall);
5823          end loop;
5824       end if;
5825
5826       --  This is either a dispatching call or a delay statement used as a
5827       --  trigger which was expanded into a procedure call.
5828
5829       if Nkind (Ecall) = N_Procedure_Call_Statement then
5830          if Ada_Version >= Ada_2005
5831            and then
5832              (No (Original_Node (Ecall))
5833                 or else not Nkind_In (Original_Node (Ecall),
5834                                         N_Delay_Relative_Statement,
5835                                         N_Delay_Until_Statement))
5836          then
5837             Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
5838
5839             Decls := New_List;
5840             Stmts := New_List;
5841
5842             --  Call status flag processing, generate:
5843             --    B : Boolean := False;
5844
5845             B := Build_B (Loc, Decls);
5846
5847             --  Communication block processing, generate:
5848             --    Bnn : Communication_Block;
5849
5850             Bnn := Make_Temporary (Loc, 'B');
5851             Append_To (Decls,
5852               Make_Object_Declaration (Loc,
5853                 Defining_Identifier => Bnn,
5854                 Object_Definition   =>
5855                   New_Reference_To (RTE (RE_Communication_Block), Loc)));
5856
5857             --  Call kind processing, generate:
5858             --    C : Ada.Tags.Prim_Op_Kind;
5859
5860             C := Build_C (Loc, Decls);
5861
5862             --  Tagged kind processing, generate:
5863             --    K : Ada.Tags.Tagged_Kind :=
5864             --          Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5865
5866             --  Dummy communication block, generate:
5867             --    D : Dummy_Communication_Block;
5868
5869             Append_To (Decls,
5870               Make_Object_Declaration (Loc,
5871                 Defining_Identifier =>
5872                   Make_Defining_Identifier (Loc, Name_uD),
5873                 Object_Definition =>
5874                   New_Reference_To (
5875                     RTE (RE_Dummy_Communication_Block), Loc)));
5876
5877             K := Build_K (Loc, Decls, Obj);
5878
5879             --  Parameter block processing
5880
5881             Blk_Typ := Build_Parameter_Block
5882                          (Loc, Actuals, Formals, Decls);
5883             P       := Parameter_Block_Pack
5884                          (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
5885
5886             --  Dispatch table slot processing, generate:
5887             --    S : Integer;
5888
5889             S := Build_S (Loc, Decls);
5890
5891             --  Additional status flag processing, generate:
5892             --    Tnn : Boolean;
5893
5894             T := Make_Temporary (Loc, 'T');
5895             Append_To (Decls,
5896               Make_Object_Declaration (Loc,
5897                 Defining_Identifier => T,
5898                 Object_Definition   =>
5899                   New_Reference_To (Standard_Boolean, Loc)));
5900
5901             ------------------------------
5902             -- Protected entry handling --
5903             ------------------------------
5904
5905             --  Generate:
5906             --    Param1 := P.Param1;
5907             --    ...
5908             --    ParamN := P.ParamN;
5909
5910             Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
5911
5912             --  Generate:
5913             --    Bnn := Communication_Block (D);
5914
5915             Prepend_To (Cleanup_Stmts,
5916               Make_Assignment_Statement (Loc,
5917                 Name =>
5918                   New_Reference_To (Bnn, Loc),
5919                 Expression =>
5920                   Make_Unchecked_Type_Conversion (Loc,
5921                     Subtype_Mark =>
5922                       New_Reference_To (RTE (RE_Communication_Block), Loc),
5923                     Expression   => Make_Identifier (Loc, Name_uD))));
5924
5925             --  Generate:
5926             --    _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
5927
5928             Prepend_To (Cleanup_Stmts,
5929               Make_Procedure_Call_Statement (Loc,
5930                 Name =>
5931                   New_Reference_To (
5932                     Find_Prim_Op (Etype (Etype (Obj)),
5933                       Name_uDisp_Asynchronous_Select),
5934                     Loc),
5935                 Parameter_Associations =>
5936                   New_List (
5937                     New_Copy_Tree (Obj),             --  <object>
5938                     New_Reference_To (S, Loc),       --  S
5939                     Make_Attribute_Reference (Loc,   --  P'Address
5940                       Prefix =>
5941                         New_Reference_To (P, Loc),
5942                       Attribute_Name =>
5943                         Name_Address),
5944                     Make_Identifier (Loc, Name_uD),  --  D
5945                     New_Reference_To (B, Loc))));    --  B
5946
5947             --  Generate:
5948             --    if Enqueued (Bnn) then
5949             --       <abortable-statements>
5950             --    end if;
5951
5952             Append_To (Cleanup_Stmts,
5953               Make_If_Statement (Loc,
5954                 Condition =>
5955                   Make_Function_Call (Loc,
5956                     Name =>
5957                       New_Reference_To (RTE (RE_Enqueued), Loc),
5958                     Parameter_Associations =>
5959                       New_List (
5960                         New_Reference_To (Bnn, Loc))),
5961
5962                 Then_Statements =>
5963                   New_Copy_List_Tree (Astats)));
5964
5965             --  Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
5966             --  will then generate a _clean for the communication block Bnn.
5967
5968             --  Generate:
5969             --    declare
5970             --       procedure _clean is
5971             --       begin
5972             --          if Enqueued (Bnn) then
5973             --             Cancel_Protected_Entry_Call (Bnn);
5974             --          end if;
5975             --       end _clean;
5976             --    begin
5977             --       Cleanup_Stmts
5978             --    at end
5979             --       _clean;
5980             --    end;
5981
5982             Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
5983             Cleanup_Block :=
5984               Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
5985
5986             --  Wrap the cleanup block in an exception handling block
5987
5988             --  Generate:
5989             --    begin
5990             --       Cleanup_Block
5991             --    exception
5992             --       when Abort_Signal => Abort_Undefer;
5993             --    end;
5994
5995             Abort_Block_Ent := Make_Temporary (Loc, 'A');
5996             ProtE_Stmts :=
5997               New_List (
5998                 Make_Implicit_Label_Declaration (Loc,
5999                   Defining_Identifier =>
6000                     Abort_Block_Ent),
6001
6002                 Build_Abort_Block
6003                   (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
6004
6005             --  Generate:
6006             --    if not Cancelled (Bnn) then
6007             --       <triggering-statements>
6008             --    end if;
6009
6010             Append_To (ProtE_Stmts,
6011               Make_If_Statement (Loc,
6012                 Condition =>
6013                   Make_Op_Not (Loc,
6014                     Right_Opnd =>
6015                       Make_Function_Call (Loc,
6016                         Name =>
6017                           New_Reference_To (RTE (RE_Cancelled), Loc),
6018                         Parameter_Associations =>
6019                           New_List (
6020                             New_Reference_To (Bnn, Loc)))),
6021
6022                 Then_Statements =>
6023                   New_Copy_List_Tree (Tstats)));
6024
6025             -------------------------
6026             -- Task entry handling --
6027             -------------------------
6028
6029             --  Generate:
6030             --    Param1 := P.Param1;
6031             --    ...
6032             --    ParamN := P.ParamN;
6033
6034             TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
6035
6036             --  Generate:
6037             --    Bnn := Communication_Block (D);
6038
6039             Append_To (TaskE_Stmts,
6040               Make_Assignment_Statement (Loc,
6041                 Name =>
6042                   New_Reference_To (Bnn, Loc),
6043                 Expression =>
6044                   Make_Unchecked_Type_Conversion (Loc,
6045                     Subtype_Mark =>
6046                       New_Reference_To (RTE (RE_Communication_Block), Loc),
6047                     Expression   => Make_Identifier (Loc, Name_uD))));
6048
6049             --  Generate:
6050             --    _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
6051
6052             Prepend_To (TaskE_Stmts,
6053               Make_Procedure_Call_Statement (Loc,
6054                 Name =>
6055                   New_Reference_To (
6056                     Find_Prim_Op (Etype (Etype (Obj)),
6057                       Name_uDisp_Asynchronous_Select),
6058                     Loc),
6059                 Parameter_Associations =>
6060                   New_List (
6061                     New_Copy_Tree (Obj),             --  <object>
6062                     New_Reference_To (S, Loc),       --  S
6063                     Make_Attribute_Reference (Loc,   --  P'Address
6064                       Prefix =>
6065                         New_Reference_To (P, Loc),
6066                       Attribute_Name =>
6067                         Name_Address),
6068                     Make_Identifier (Loc, Name_uD),  --  D
6069                     New_Reference_To (B, Loc))));    --  B
6070
6071             --  Generate:
6072             --    Abort_Defer;
6073
6074             Prepend_To (TaskE_Stmts,
6075               Make_Procedure_Call_Statement (Loc,
6076                 Name =>
6077                   New_Reference_To (RTE (RE_Abort_Defer), Loc),
6078                 Parameter_Associations =>
6079                   No_List));
6080
6081             --  Generate:
6082             --    Abort_Undefer;
6083             --    <abortable-statements>
6084
6085             Cleanup_Stmts := New_Copy_List_Tree (Astats);
6086
6087             Prepend_To (Cleanup_Stmts,
6088               Make_Procedure_Call_Statement (Loc,
6089                 Name =>
6090                   New_Reference_To (RTE (RE_Abort_Undefer), Loc),
6091                 Parameter_Associations =>
6092                   No_List));
6093
6094             --  Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
6095             --  will generate a _clean for the additional status flag.
6096
6097             --  Generate:
6098             --    declare
6099             --       procedure _clean is
6100             --       begin
6101             --          Cancel_Task_Entry_Call (U);
6102             --       end _clean;
6103             --    begin
6104             --       Cleanup_Stmts
6105             --    at end
6106             --       _clean;
6107             --    end;
6108
6109             Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
6110             Cleanup_Block :=
6111               Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
6112
6113             --  Wrap the cleanup block in an exception handling block
6114
6115             --  Generate:
6116             --    begin
6117             --       Cleanup_Block
6118             --    exception
6119             --       when Abort_Signal => Abort_Undefer;
6120             --    end;
6121
6122             Abort_Block_Ent := Make_Temporary (Loc, 'A');
6123
6124             Append_To (TaskE_Stmts,
6125               Make_Implicit_Label_Declaration (Loc,
6126                 Defining_Identifier => Abort_Block_Ent));
6127
6128             Append_To (TaskE_Stmts,
6129               Build_Abort_Block
6130                 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
6131
6132             --  Generate:
6133             --    if not T then
6134             --       <triggering-statements>
6135             --    end if;
6136
6137             Append_To (TaskE_Stmts,
6138               Make_If_Statement (Loc,
6139                 Condition =>
6140                   Make_Op_Not (Loc,
6141                     Right_Opnd =>
6142                       New_Reference_To (T, Loc)),
6143
6144                 Then_Statements =>
6145                   New_Copy_List_Tree (Tstats)));
6146
6147             ----------------------------------
6148             -- Protected procedure handling --
6149             ----------------------------------
6150
6151             --  Generate:
6152             --    <dispatching-call>;
6153             --    <triggering-statements>
6154
6155             ProtP_Stmts := New_Copy_List_Tree (Tstats);
6156             Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
6157
6158             --  Generate:
6159             --    S := Ada.Tags.Get_Offset_Index
6160             --           (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6161
6162             Conc_Typ_Stmts :=
6163               New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
6164
6165             --  Generate:
6166             --    _Disp_Get_Prim_Op_Kind (<object>, S, C);
6167
6168             Append_To (Conc_Typ_Stmts,
6169               Make_Procedure_Call_Statement (Loc,
6170                 Name =>
6171                   New_Reference_To (
6172                     Find_Prim_Op (Etype (Etype (Obj)),
6173                       Name_uDisp_Get_Prim_Op_Kind),
6174                     Loc),
6175                 Parameter_Associations =>
6176                   New_List (
6177                     New_Copy_Tree (Obj),
6178                     New_Reference_To (S, Loc),
6179                     New_Reference_To (C, Loc))));
6180
6181             --  Generate:
6182             --    if C = POK_Procedure_Entry then
6183             --       ProtE_Stmts
6184             --    elsif C = POK_Task_Entry then
6185             --       TaskE_Stmts
6186             --    else
6187             --       ProtP_Stmts
6188             --    end if;
6189
6190             Append_To (Conc_Typ_Stmts,
6191               Make_If_Statement (Loc,
6192                 Condition =>
6193                   Make_Op_Eq (Loc,
6194                     Left_Opnd =>
6195                       New_Reference_To (C, Loc),
6196                     Right_Opnd =>
6197                       New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
6198
6199                 Then_Statements =>
6200                   ProtE_Stmts,
6201
6202                 Elsif_Parts =>
6203                   New_List (
6204                     Make_Elsif_Part (Loc,
6205                       Condition =>
6206                         Make_Op_Eq (Loc,
6207                           Left_Opnd =>
6208                             New_Reference_To (C, Loc),
6209                           Right_Opnd =>
6210                             New_Reference_To (RTE (RE_POK_Task_Entry), Loc)),
6211
6212                       Then_Statements =>
6213                         TaskE_Stmts)),
6214
6215                 Else_Statements =>
6216                   ProtP_Stmts));
6217
6218             --  Generate:
6219             --    <dispatching-call>;
6220             --    <triggering-statements>
6221
6222             Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
6223             Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
6224
6225             --  Generate:
6226             --    if K = Ada.Tags.TK_Limited_Tagged then
6227             --       Lim_Typ_Stmts
6228             --    else
6229             --       Conc_Typ_Stmts
6230             --    end if;
6231
6232             Append_To (Stmts,
6233               Make_If_Statement (Loc,
6234                 Condition =>
6235                    Make_Op_Eq (Loc,
6236                      Left_Opnd =>
6237                        New_Reference_To (K, Loc),
6238                      Right_Opnd =>
6239                        New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
6240
6241                 Then_Statements =>
6242                   Lim_Typ_Stmts,
6243
6244                 Else_Statements =>
6245                   Conc_Typ_Stmts));
6246
6247             Rewrite (N,
6248               Make_Block_Statement (Loc,
6249                 Declarations =>
6250                   Decls,
6251                 Handled_Statement_Sequence =>
6252                   Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6253
6254             Analyze (N);
6255             return;
6256
6257          --  Delay triggering statement processing
6258
6259          else
6260             --  Add a Delay_Block object to the parameter list of the delay
6261             --  procedure to form the parameter list of the Wait entry call.
6262
6263             Dblock_Ent := Make_Temporary (Loc, 'D');
6264
6265             Pdef := Entity (Name (Ecall));
6266
6267             if Is_RTE (Pdef, RO_CA_Delay_For) then
6268                Enqueue_Call :=
6269                  New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
6270
6271             elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
6272                Enqueue_Call :=
6273                  New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
6274
6275             else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
6276                Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
6277             end if;
6278
6279             Append_To (Parameter_Associations (Ecall),
6280               Make_Attribute_Reference (Loc,
6281                 Prefix => New_Reference_To (Dblock_Ent, Loc),
6282                 Attribute_Name => Name_Unchecked_Access));
6283
6284             --  Create the inner block to protect the abortable part
6285
6286             Hdle := New_List (
6287               Make_Implicit_Exception_Handler (Loc,
6288                 Exception_Choices =>
6289                   New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
6290                 Statements => New_List (
6291                   Make_Procedure_Call_Statement (Loc,
6292                     Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
6293
6294             Prepend_To (Astats,
6295               Make_Procedure_Call_Statement (Loc,
6296                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
6297
6298             Abortable_Block :=
6299               Make_Block_Statement (Loc,
6300                 Identifier => New_Reference_To (Blk_Ent, Loc),
6301                 Handled_Statement_Sequence =>
6302                   Make_Handled_Sequence_Of_Statements (Loc,
6303                     Statements => Astats),
6304                 Has_Created_Identifier => True,
6305                 Is_Asynchronous_Call_Block => True);
6306
6307             --  Append call to if Enqueue (When, DB'Unchecked_Access) then
6308
6309             Rewrite (Ecall,
6310               Make_Implicit_If_Statement (N,
6311                 Condition => Make_Function_Call (Loc,
6312                   Name => Enqueue_Call,
6313                   Parameter_Associations => Parameter_Associations (Ecall)),
6314                 Then_Statements =>
6315                   New_List (Make_Block_Statement (Loc,
6316                     Handled_Statement_Sequence =>
6317                       Make_Handled_Sequence_Of_Statements (Loc,
6318                         Statements => New_List (
6319                           Make_Implicit_Label_Declaration (Loc,
6320                             Defining_Identifier => Blk_Ent,
6321                             Label_Construct     => Abortable_Block),
6322                           Abortable_Block),
6323                         Exception_Handlers => Hdle)))));
6324
6325             Stmts := New_List (Ecall);
6326
6327             --  Construct statement sequence for new block
6328
6329             Append_To (Stmts,
6330               Make_Implicit_If_Statement (N,
6331                 Condition => Make_Function_Call (Loc,
6332                   Name => New_Reference_To (
6333                     RTE (RE_Timed_Out), Loc),
6334                   Parameter_Associations => New_List (
6335                     Make_Attribute_Reference (Loc,
6336                       Prefix => New_Reference_To (Dblock_Ent, Loc),
6337                       Attribute_Name => Name_Unchecked_Access))),
6338                 Then_Statements => Tstats));
6339
6340             --  The result is the new block
6341
6342             Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
6343
6344             Rewrite (N,
6345               Make_Block_Statement (Loc,
6346                 Declarations => New_List (
6347                   Make_Object_Declaration (Loc,
6348                     Defining_Identifier => Dblock_Ent,
6349                     Aliased_Present => True,
6350                     Object_Definition => New_Reference_To (
6351                       RTE (RE_Delay_Block), Loc))),
6352
6353                 Handled_Statement_Sequence =>
6354                   Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6355
6356             Analyze (N);
6357             return;
6358          end if;
6359
6360       else
6361          N_Orig := N;
6362       end if;
6363
6364       Extract_Entry (Ecall, Concval, Ename, Index);
6365       Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
6366
6367       Stmts := Statements (Handled_Statement_Sequence (Ecall));
6368       Decls := Declarations (Ecall);
6369
6370       if Is_Protected_Type (Etype (Concval)) then
6371
6372          --  Get the declarations of the block expanded from the entry call
6373
6374          Decl := First (Decls);
6375          while Present (Decl)
6376            and then
6377              (Nkind (Decl) /= N_Object_Declaration
6378                or else not Is_RTE (Etype (Object_Definition (Decl)),
6379                                    RE_Communication_Block))
6380          loop
6381             Next (Decl);
6382          end loop;
6383
6384          pragma Assert (Present (Decl));
6385          Cancel_Param := Defining_Identifier (Decl);
6386
6387          --  Change the mode of the Protected_Entry_Call call
6388
6389          --  Protected_Entry_Call (
6390          --    Object => po._object'Access,
6391          --    E => <entry index>;
6392          --    Uninterpreted_Data => P'Address;
6393          --    Mode => Asynchronous_Call;
6394          --    Block => Bnn);
6395
6396          Stmt := First (Stmts);
6397
6398          --  Skip assignments to temporaries created for in-out parameters
6399
6400          --  This makes unwarranted assumptions about the shape of the expanded
6401          --  tree for the call, and should be cleaned up ???
6402
6403          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
6404             Next (Stmt);
6405          end loop;
6406
6407          Call := Stmt;
6408
6409          Param := First (Parameter_Associations (Call));
6410          while Present (Param)
6411            and then not Is_RTE (Etype (Param), RE_Call_Modes)
6412          loop
6413             Next (Param);
6414          end loop;
6415
6416          pragma Assert (Present (Param));
6417          Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
6418          Analyze (Param);
6419
6420          --  Append an if statement to execute the abortable part
6421
6422          --  Generate:
6423          --    if Enqueued (Bnn) then
6424
6425          Append_To (Stmts,
6426            Make_Implicit_If_Statement (N,
6427              Condition => Make_Function_Call (Loc,
6428                Name => New_Reference_To (
6429                  RTE (RE_Enqueued), Loc),
6430                Parameter_Associations => New_List (
6431                  New_Reference_To (Cancel_Param, Loc))),
6432              Then_Statements => Astats));
6433
6434          Abortable_Block :=
6435            Make_Block_Statement (Loc,
6436              Identifier => New_Reference_To (Blk_Ent, Loc),
6437              Handled_Statement_Sequence =>
6438                Make_Handled_Sequence_Of_Statements (Loc,
6439                  Statements => Stmts),
6440              Has_Created_Identifier => True,
6441              Is_Asynchronous_Call_Block => True);
6442
6443          --  For the VM call Update_Exception instead of Abort_Undefer.
6444          --  See 4jexcept.ads for an explanation.
6445
6446          if VM_Target = No_VM then
6447             Target_Undefer := RE_Abort_Undefer;
6448          else
6449             Target_Undefer := RE_Update_Exception;
6450             Undefer_Args :=
6451               New_List (Make_Function_Call (Loc,
6452                           Name => New_Occurrence_Of
6453                                     (RTE (RE_Current_Target_Exception), Loc)));
6454          end if;
6455
6456          Stmts := New_List (
6457            Make_Block_Statement (Loc,
6458              Handled_Statement_Sequence =>
6459                Make_Handled_Sequence_Of_Statements (Loc,
6460                  Statements => New_List (
6461                    Make_Implicit_Label_Declaration (Loc,
6462                      Defining_Identifier => Blk_Ent,
6463                      Label_Construct     => Abortable_Block),
6464                    Abortable_Block),
6465
6466                --  exception
6467
6468                  Exception_Handlers => New_List (
6469                    Make_Implicit_Exception_Handler (Loc,
6470
6471                --  when Abort_Signal =>
6472                --     Abort_Undefer.all;
6473
6474                      Exception_Choices =>
6475                        New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
6476                      Statements => New_List (
6477                        Make_Procedure_Call_Statement (Loc,
6478                          Name => New_Reference_To (
6479                            RTE (Target_Undefer), Loc),
6480                          Parameter_Associations => Undefer_Args)))))),
6481
6482          --  if not Cancelled (Bnn) then
6483          --     triggered statements
6484          --  end if;
6485
6486            Make_Implicit_If_Statement (N,
6487              Condition => Make_Op_Not (Loc,
6488                Right_Opnd =>
6489                  Make_Function_Call (Loc,
6490                    Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
6491                    Parameter_Associations => New_List (
6492                      New_Occurrence_Of (Cancel_Param, Loc)))),
6493              Then_Statements => Tstats));
6494
6495       --  Asynchronous task entry call
6496
6497       else
6498          if No (Decls) then
6499             Decls := New_List;
6500          end if;
6501
6502          B := Make_Defining_Identifier (Loc, Name_uB);
6503
6504          --  Insert declaration of B in declarations of existing block
6505
6506          Prepend_To (Decls,
6507            Make_Object_Declaration (Loc,
6508              Defining_Identifier => B,
6509              Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
6510
6511          Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
6512
6513          --  Insert declaration of C in declarations of existing block
6514
6515          Prepend_To (Decls,
6516            Make_Object_Declaration (Loc,
6517              Defining_Identifier => Cancel_Param,
6518              Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
6519
6520          --  Remove and save the call to Call_Simple
6521
6522          Stmt := First (Stmts);
6523
6524          --  Skip assignments to temporaries created for in-out parameters.
6525          --  This makes unwarranted assumptions about the shape of the expanded
6526          --  tree for the call, and should be cleaned up ???
6527
6528          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
6529             Next (Stmt);
6530          end loop;
6531
6532          Call := Stmt;
6533
6534          --  Create the inner block to protect the abortable part
6535
6536          Hdle :=  New_List (
6537            Make_Implicit_Exception_Handler (Loc,
6538              Exception_Choices =>
6539                New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
6540              Statements =>
6541                New_List (
6542                  Make_Procedure_Call_Statement (Loc,
6543                    Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
6544
6545          Prepend_To (Astats,
6546            Make_Procedure_Call_Statement (Loc,
6547              Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
6548
6549          Abortable_Block :=
6550            Make_Block_Statement (Loc,
6551              Identifier => New_Reference_To (Blk_Ent, Loc),
6552              Handled_Statement_Sequence =>
6553                Make_Handled_Sequence_Of_Statements (Loc,
6554                  Statements => Astats),
6555              Has_Created_Identifier => True,
6556              Is_Asynchronous_Call_Block => True);
6557
6558          Insert_After (Call,
6559            Make_Block_Statement (Loc,
6560              Handled_Statement_Sequence =>
6561                Make_Handled_Sequence_Of_Statements (Loc,
6562                  Statements => New_List (
6563                    Make_Implicit_Label_Declaration (Loc,
6564                      Defining_Identifier =>
6565                        Blk_Ent,
6566                      Label_Construct =>
6567                        Abortable_Block),
6568                    Abortable_Block),
6569                  Exception_Handlers => Hdle)));
6570
6571          --  Create new call statement
6572
6573          Params := Parameter_Associations (Call);
6574
6575          Append_To (Params,
6576            New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
6577          Append_To (Params,
6578            New_Reference_To (B, Loc));
6579
6580          Rewrite (Call,
6581            Make_Procedure_Call_Statement (Loc,
6582              Name =>
6583                New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
6584              Parameter_Associations => Params));
6585
6586          --  Construct statement sequence for new block
6587
6588          Append_To (Stmts,
6589            Make_Implicit_If_Statement (N,
6590              Condition =>
6591                Make_Op_Not (Loc,
6592                  New_Reference_To (Cancel_Param, Loc)),
6593              Then_Statements => Tstats));
6594
6595          --  Protected the call against abort
6596
6597          Prepend_To (Stmts,
6598            Make_Procedure_Call_Statement (Loc,
6599              Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
6600              Parameter_Associations => Empty_List));
6601       end if;
6602
6603       Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
6604
6605       --  The result is the new block
6606
6607       Rewrite (N_Orig,
6608         Make_Block_Statement (Loc,
6609           Declarations => Decls,
6610           Handled_Statement_Sequence =>
6611             Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6612
6613       Analyze (N_Orig);
6614    end Expand_N_Asynchronous_Select;
6615
6616    -------------------------------------
6617    -- Expand_N_Conditional_Entry_Call --
6618    -------------------------------------
6619
6620    --  The conditional task entry call is converted to a call to
6621    --  Task_Entry_Call:
6622
6623    --    declare
6624    --       B : Boolean;
6625    --       P : parms := (parm, parm, parm);
6626
6627    --    begin
6628    --       Task_Entry_Call
6629    --         (<acceptor-task>,   --  Acceptor
6630    --          <entry-index>,     --  E
6631    --          P'Address,         --  Uninterpreted_Data
6632    --          Conditional_Call,  --  Mode
6633    --          B);                --  Rendezvous_Successful
6634    --       parm := P.param;
6635    --       parm := P.param;
6636    --       ...
6637    --       if B then
6638    --          normal-statements
6639    --       else
6640    --          else-statements
6641    --       end if;
6642    --    end;
6643
6644    --  For a description of the use of P and the assignments after the call,
6645    --  see Expand_N_Entry_Call_Statement. Note that the entry call of the
6646    --  conditional entry call has already been expanded (by the Expand_N_Entry
6647    --  _Call_Statement procedure) as follows:
6648
6649    --    declare
6650    --       P : parms := (parm, parm, parm);
6651    --    begin
6652    --       ... info for in-out parameters
6653    --       Call_Simple (acceptor-task, entry-index, P'Address);
6654    --       parm := P.param;
6655    --       parm := P.param;
6656    --       ...
6657    --    end;
6658
6659    --  so the task at hand is to convert the latter expansion into the former
6660
6661    --  The conditional protected entry call is converted to a call to
6662    --  Protected_Entry_Call:
6663
6664    --    declare
6665    --       P : parms := (parm, parm, parm);
6666    --       Bnn : Communications_Block;
6667
6668    --    begin
6669    --       Protected_Entry_Call
6670    --         (po._object'Access,  --  Object
6671    --          <entry index>,      --  E
6672    --          P'Address,          --  Uninterpreted_Data
6673    --          Conditional_Call,   --  Mode
6674    --          Bnn);               --  Block
6675    --       parm := P.param;
6676    --       parm := P.param;
6677    --       ...
6678    --       if Cancelled (Bnn) then
6679    --          else-statements
6680    --       else
6681    --          normal-statements
6682    --       end if;
6683    --    end;
6684
6685    --  Ada 2005 (AI-345): A dispatching conditional entry call is converted
6686    --  into:
6687
6688    --    declare
6689    --       B : Boolean := False;
6690    --       C : Ada.Tags.Prim_Op_Kind;
6691    --       K : Ada.Tags.Tagged_Kind :=
6692    --             Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6693    --       P : Parameters := (Param1 .. ParamN);
6694    --       S : Integer;
6695
6696    --    begin
6697    --       if K = Ada.Tags.TK_Limited_Tagged then
6698    --          <dispatching-call>;
6699    --          <triggering-statements>
6700
6701    --       else
6702    --          S :=
6703    --            Ada.Tags.Get_Offset_Index
6704    --              (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6705
6706    --          _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6707
6708    --          if C = POK_Protected_Entry
6709    --            or else C = POK_Task_Entry
6710    --          then
6711    --             Param1 := P.Param1;
6712    --             ...
6713    --             ParamN := P.ParamN;
6714    --          end if;
6715
6716    --          if B then
6717    --             if C = POK_Procedure
6718    --               or else C = POK_Protected_Procedure
6719    --               or else C = POK_Task_Procedure
6720    --             then
6721    --                <dispatching-call>;
6722    --             end if;
6723
6724    --             <triggering-statements>
6725    --          else
6726    --             <else-statements>
6727    --          end if;
6728    --       end if;
6729    --    end;
6730
6731    procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
6732       Loc : constant Source_Ptr := Sloc (N);
6733       Alt : constant Node_Id    := Entry_Call_Alternative (N);
6734       Blk : Node_Id             := Entry_Call_Statement (Alt);
6735
6736       Actuals        : List_Id;
6737       Blk_Typ        : Entity_Id;
6738       Call           : Node_Id;
6739       Call_Ent       : Entity_Id;
6740       Conc_Typ_Stmts : List_Id;
6741       Decl           : Node_Id;
6742       Decls          : List_Id;
6743       Formals        : List_Id;
6744       Lim_Typ_Stmts  : List_Id;
6745       N_Stats        : List_Id;
6746       Obj            : Entity_Id;
6747       Param          : Node_Id;
6748       Params         : List_Id;
6749       Stmt           : Node_Id;
6750       Stmts          : List_Id;
6751       Transient_Blk  : Node_Id;
6752       Unpack         : List_Id;
6753
6754       B : Entity_Id;  --  Call status flag
6755       C : Entity_Id;  --  Call kind
6756       K : Entity_Id;  --  Tagged kind
6757       P : Entity_Id;  --  Parameter block
6758       S : Entity_Id;  --  Primitive operation slot
6759
6760    begin
6761       if Ada_Version >= Ada_2005
6762         and then Nkind (Blk) = N_Procedure_Call_Statement
6763       then
6764          Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
6765
6766          Decls := New_List;
6767          Stmts := New_List;
6768
6769          --  Call status flag processing, generate:
6770          --    B : Boolean := False;
6771
6772          B := Build_B (Loc, Decls);
6773
6774          --  Call kind processing, generate:
6775          --    C : Ada.Tags.Prim_Op_Kind;
6776
6777          C := Build_C (Loc, Decls);
6778
6779          --  Tagged kind processing, generate:
6780          --    K : Ada.Tags.Tagged_Kind :=
6781          --          Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6782
6783          K := Build_K (Loc, Decls, Obj);
6784
6785          --  Parameter block processing
6786
6787          Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
6788          P       := Parameter_Block_Pack
6789                       (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
6790
6791          --  Dispatch table slot processing, generate:
6792          --    S : Integer;
6793
6794          S := Build_S (Loc, Decls);
6795
6796          --  Generate:
6797          --    S := Ada.Tags.Get_Offset_Index
6798          --           (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6799
6800          Conc_Typ_Stmts :=
6801            New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
6802
6803          --  Generate:
6804          --    _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6805
6806          Append_To (Conc_Typ_Stmts,
6807            Make_Procedure_Call_Statement (Loc,
6808              Name =>
6809                New_Reference_To (
6810                  Find_Prim_Op (Etype (Etype (Obj)),
6811                    Name_uDisp_Conditional_Select),
6812                  Loc),
6813              Parameter_Associations =>
6814                New_List (
6815                  New_Copy_Tree (Obj),            --  <object>
6816                  New_Reference_To (S, Loc),      --  S
6817                  Make_Attribute_Reference (Loc,  --  P'Address
6818                    Prefix =>
6819                      New_Reference_To (P, Loc),
6820                    Attribute_Name =>
6821                      Name_Address),
6822                  New_Reference_To (C, Loc),      --  C
6823                  New_Reference_To (B, Loc))));   --  B
6824
6825          --  Generate:
6826          --    if C = POK_Protected_Entry
6827          --      or else C = POK_Task_Entry
6828          --    then
6829          --       Param1 := P.Param1;
6830          --       ...
6831          --       ParamN := P.ParamN;
6832          --    end if;
6833
6834          Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
6835
6836          --  Generate the if statement only when the packed parameters need
6837          --  explicit assignments to their corresponding actuals.
6838
6839          if Present (Unpack) then
6840             Append_To (Conc_Typ_Stmts,
6841               Make_If_Statement (Loc,
6842
6843                 Condition =>
6844                   Make_Or_Else (Loc,
6845                     Left_Opnd =>
6846                       Make_Op_Eq (Loc,
6847                         Left_Opnd =>
6848                           New_Reference_To (C, Loc),
6849                         Right_Opnd =>
6850                           New_Reference_To (RTE (
6851                             RE_POK_Protected_Entry), Loc)),
6852                     Right_Opnd =>
6853                       Make_Op_Eq (Loc,
6854                         Left_Opnd =>
6855                           New_Reference_To (C, Loc),
6856                         Right_Opnd =>
6857                           New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
6858
6859                  Then_Statements =>
6860                    Unpack));
6861          end if;
6862
6863          --  Generate:
6864          --    if B then
6865          --       if C = POK_Procedure
6866          --         or else C = POK_Protected_Procedure
6867          --         or else C = POK_Task_Procedure
6868          --       then
6869          --          <dispatching-call>
6870          --       end if;
6871          --       <normal-statements>
6872          --    else
6873          --       <else-statements>
6874          --    end if;
6875
6876          N_Stats := New_Copy_List_Tree (Statements (Alt));
6877
6878          Prepend_To (N_Stats,
6879            Make_If_Statement (Loc,
6880              Condition =>
6881                Make_Or_Else (Loc,
6882                  Left_Opnd =>
6883                    Make_Op_Eq (Loc,
6884                      Left_Opnd =>
6885                        New_Reference_To (C, Loc),
6886                      Right_Opnd =>
6887                        New_Reference_To (RTE (RE_POK_Procedure), Loc)),
6888
6889                  Right_Opnd =>
6890                    Make_Or_Else (Loc,
6891                      Left_Opnd =>
6892                        Make_Op_Eq (Loc,
6893                          Left_Opnd =>
6894                            New_Reference_To (C, Loc),
6895                          Right_Opnd =>
6896                            New_Reference_To (RTE (
6897                              RE_POK_Protected_Procedure), Loc)),
6898
6899                      Right_Opnd =>
6900                        Make_Op_Eq (Loc,
6901                          Left_Opnd =>
6902                            New_Reference_To (C, Loc),
6903                          Right_Opnd =>
6904                            New_Reference_To (RTE (
6905                              RE_POK_Task_Procedure), Loc)))),
6906
6907              Then_Statements =>
6908                New_List (Blk)));
6909
6910          Append_To (Conc_Typ_Stmts,
6911            Make_If_Statement (Loc,
6912              Condition => New_Reference_To (B, Loc),
6913              Then_Statements => N_Stats,
6914              Else_Statements => Else_Statements (N)));
6915
6916          --  Generate:
6917          --    <dispatching-call>;
6918          --    <triggering-statements>
6919
6920          Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
6921          Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
6922
6923          --  Generate:
6924          --    if K = Ada.Tags.TK_Limited_Tagged then
6925          --       Lim_Typ_Stmts
6926          --    else
6927          --       Conc_Typ_Stmts
6928          --    end if;
6929
6930          Append_To (Stmts,
6931            Make_If_Statement (Loc,
6932              Condition =>
6933                Make_Op_Eq (Loc,
6934                  Left_Opnd =>
6935                    New_Reference_To (K, Loc),
6936                  Right_Opnd =>
6937                    New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
6938
6939              Then_Statements =>
6940                Lim_Typ_Stmts,
6941
6942              Else_Statements =>
6943                Conc_Typ_Stmts));
6944
6945          Rewrite (N,
6946            Make_Block_Statement (Loc,
6947              Declarations =>
6948                Decls,
6949              Handled_Statement_Sequence =>
6950                Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6951
6952       --  As described above, The entry alternative is transformed into a
6953       --  block that contains the gnulli call, and possibly assignment
6954       --  statements for in-out parameters. The gnulli call may itself be
6955       --  rewritten into a transient block if some unconstrained parameters
6956       --  require it. We need to retrieve the call to complete its parameter
6957       --  list.
6958
6959       else
6960          Transient_Blk :=
6961            First_Real_Statement (Handled_Statement_Sequence (Blk));
6962
6963          if Present (Transient_Blk)
6964            and then Nkind (Transient_Blk) = N_Block_Statement
6965          then
6966             Blk := Transient_Blk;
6967          end if;
6968
6969          Stmts := Statements (Handled_Statement_Sequence (Blk));
6970          Stmt  := First (Stmts);
6971          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
6972             Next (Stmt);
6973          end loop;
6974
6975          Call   := Stmt;
6976          Params := Parameter_Associations (Call);
6977
6978          if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
6979
6980             --  Substitute Conditional_Entry_Call for Simple_Call parameter
6981
6982             Param := First (Params);
6983             while Present (Param)
6984               and then not Is_RTE (Etype (Param), RE_Call_Modes)
6985             loop
6986                Next (Param);
6987             end loop;
6988
6989             pragma Assert (Present (Param));
6990             Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc));
6991
6992             Analyze (Param);
6993
6994             --  Find the Communication_Block parameter for the call to the
6995             --  Cancelled function.
6996
6997             Decl := First (Declarations (Blk));
6998             while Present (Decl)
6999               and then not Is_RTE (Etype (Object_Definition (Decl)),
7000                              RE_Communication_Block)
7001             loop
7002                Next (Decl);
7003             end loop;
7004
7005             --  Add an if statement to execute the else part if the call
7006             --  does not succeed (as indicated by the Cancelled predicate).
7007
7008             Append_To (Stmts,
7009               Make_Implicit_If_Statement (N,
7010                 Condition => Make_Function_Call (Loc,
7011                   Name => New_Reference_To (RTE (RE_Cancelled), Loc),
7012                   Parameter_Associations => New_List (
7013                     New_Reference_To (Defining_Identifier (Decl), Loc))),
7014                 Then_Statements => Else_Statements (N),
7015                 Else_Statements => Statements (Alt)));
7016
7017          else
7018             B := Make_Defining_Identifier (Loc, Name_uB);
7019
7020             --  Insert declaration of B in declarations of existing block
7021
7022             if No (Declarations (Blk)) then
7023                Set_Declarations (Blk, New_List);
7024             end if;
7025
7026             Prepend_To (Declarations (Blk),
7027               Make_Object_Declaration (Loc,
7028                 Defining_Identifier => B,
7029                 Object_Definition =>
7030                   New_Reference_To (Standard_Boolean, Loc)));
7031
7032             --  Create new call statement
7033
7034             Append_To (Params,
7035               New_Reference_To (RTE (RE_Conditional_Call), Loc));
7036             Append_To (Params, New_Reference_To (B, Loc));
7037
7038             Rewrite (Call,
7039               Make_Procedure_Call_Statement (Loc,
7040                 Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
7041                 Parameter_Associations => Params));
7042
7043             --  Construct statement sequence for new block
7044
7045             Append_To (Stmts,
7046               Make_Implicit_If_Statement (N,
7047                 Condition => New_Reference_To (B, Loc),
7048                 Then_Statements => Statements (Alt),
7049                 Else_Statements => Else_Statements (N)));
7050          end if;
7051
7052          --  The result is the new block
7053
7054          Rewrite (N,
7055            Make_Block_Statement (Loc,
7056              Declarations => Declarations (Blk),
7057              Handled_Statement_Sequence =>
7058                Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7059       end if;
7060
7061       Analyze (N);
7062    end Expand_N_Conditional_Entry_Call;
7063
7064    ---------------------------------------
7065    -- Expand_N_Delay_Relative_Statement --
7066    ---------------------------------------
7067
7068    --  Delay statement is implemented as a procedure call to Delay_For
7069    --  defined in Ada.Calendar.Delays in order to reduce the overhead of
7070    --  simple delays imposed by the use of Protected Objects.
7071
7072    procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
7073       Loc : constant Source_Ptr := Sloc (N);
7074    begin
7075       Rewrite (N,
7076         Make_Procedure_Call_Statement (Loc,
7077           Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc),
7078           Parameter_Associations => New_List (Expression (N))));
7079       Analyze (N);
7080    end Expand_N_Delay_Relative_Statement;
7081
7082    ------------------------------------
7083    -- Expand_N_Delay_Until_Statement --
7084    ------------------------------------
7085
7086    --  Delay Until statement is implemented as a procedure call to
7087    --  Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
7088
7089    procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
7090       Loc : constant Source_Ptr := Sloc (N);
7091       Typ : Entity_Id;
7092
7093    begin
7094       if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
7095          Typ := RTE (RO_CA_Delay_Until);
7096       else
7097          Typ := RTE (RO_RT_Delay_Until);
7098       end if;
7099
7100       Rewrite (N,
7101         Make_Procedure_Call_Statement (Loc,
7102           Name => New_Reference_To (Typ, Loc),
7103           Parameter_Associations => New_List (Expression (N))));
7104
7105       Analyze (N);
7106    end Expand_N_Delay_Until_Statement;
7107
7108    -------------------------
7109    -- Expand_N_Entry_Body --
7110    -------------------------
7111
7112    procedure Expand_N_Entry_Body (N : Node_Id) is
7113    begin
7114       --  Associate discriminals with the next protected operation body to be
7115       --  expanded.
7116
7117       if Present (Next_Protected_Operation (N)) then
7118          Set_Discriminals (Parent (Current_Scope));
7119       end if;
7120    end Expand_N_Entry_Body;
7121
7122    -----------------------------------
7123    -- Expand_N_Entry_Call_Statement --
7124    -----------------------------------
7125
7126    --  An entry call is expanded into GNARLI calls to implement a simple entry
7127    --  call (see Build_Simple_Entry_Call).
7128
7129    procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
7130       Concval : Node_Id;
7131       Ename   : Node_Id;
7132       Index   : Node_Id;
7133
7134    begin
7135       if No_Run_Time_Mode then
7136          Error_Msg_CRT ("entry call", N);
7137          return;
7138       end if;
7139
7140       --  If this entry call is part of an asynchronous select, don't expand it
7141       --  here; it will be expanded with the select statement. Don't expand
7142       --  timed entry calls either, as they are translated into asynchronous
7143       --  entry calls.
7144
7145       --  ??? This whole approach is questionable; it may be better to go back
7146       --  to allowing the expansion to take place and then attempting to fix it
7147       --  up in Expand_N_Asynchronous_Select. The tricky part is figuring out
7148       --  whether the expanded call is on a task or protected entry.
7149
7150       if (Nkind (Parent (N)) /= N_Triggering_Alternative
7151            or else N /= Triggering_Statement (Parent (N)))
7152         and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
7153                    or else N /= Entry_Call_Statement (Parent (N))
7154                    or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
7155       then
7156          Extract_Entry (N, Concval, Ename, Index);
7157          Build_Simple_Entry_Call (N, Concval, Ename, Index);
7158       end if;
7159    end Expand_N_Entry_Call_Statement;
7160
7161    --------------------------------
7162    -- Expand_N_Entry_Declaration --
7163    --------------------------------
7164
7165    --  If there are parameters, then first, each of the formals is marked by
7166    --  setting Is_Entry_Formal. Next a record type is built which is used to
7167    --  hold the parameter values. The name of this record type is entryP where
7168    --  entry is the name of the entry, with an additional corresponding access
7169    --  type called entryPA. The record type has matching components for each
7170    --  formal (the component names are the same as the formal names). For
7171    --  elementary types, the component type matches the formal type. For
7172    --  composite types, an access type is declared (with the name formalA)
7173    --  which designates the formal type, and the type of the component is this
7174    --  access type. Finally the Entry_Component of each formal is set to
7175    --  reference the corresponding record component.
7176
7177    procedure Expand_N_Entry_Declaration (N : Node_Id) is
7178       Loc        : constant Source_Ptr := Sloc (N);
7179       Entry_Ent  : constant Entity_Id  := Defining_Identifier (N);
7180       Components : List_Id;
7181       Formal     : Node_Id;
7182       Ftype      : Entity_Id;
7183       Last_Decl  : Node_Id;
7184       Component  : Entity_Id;
7185       Ctype      : Entity_Id;
7186       Decl       : Node_Id;
7187       Rec_Ent    : Entity_Id;
7188       Acc_Ent    : Entity_Id;
7189
7190    begin
7191       Formal := First_Formal (Entry_Ent);
7192       Last_Decl := N;
7193
7194       --  Most processing is done only if parameters are present
7195
7196       if Present (Formal) then
7197          Components := New_List;
7198
7199          --  Loop through formals
7200
7201          while Present (Formal) loop
7202             Set_Is_Entry_Formal (Formal);
7203             Component :=
7204               Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
7205             Set_Entry_Component (Formal, Component);
7206             Set_Entry_Formal (Component, Formal);
7207             Ftype := Etype (Formal);
7208
7209             --  Declare new access type and then append
7210
7211             Ctype := Make_Temporary (Loc, 'A');
7212
7213             Decl :=
7214               Make_Full_Type_Declaration (Loc,
7215                 Defining_Identifier => Ctype,
7216                 Type_Definition     =>
7217                   Make_Access_To_Object_Definition (Loc,
7218                     All_Present        => True,
7219                     Constant_Present   => Ekind (Formal) = E_In_Parameter,
7220                     Subtype_Indication => New_Reference_To (Ftype, Loc)));
7221
7222             Insert_After (Last_Decl, Decl);
7223             Last_Decl := Decl;
7224
7225             Append_To (Components,
7226               Make_Component_Declaration (Loc,
7227                 Defining_Identifier => Component,
7228                 Component_Definition =>
7229                   Make_Component_Definition (Loc,
7230                     Aliased_Present    => False,
7231                     Subtype_Indication => New_Reference_To (Ctype, Loc))));
7232
7233             Next_Formal_With_Extras (Formal);
7234          end loop;
7235
7236          --  Create the Entry_Parameter_Record declaration
7237
7238          Rec_Ent := Make_Temporary (Loc, 'P');
7239
7240          Decl :=
7241            Make_Full_Type_Declaration (Loc,
7242              Defining_Identifier => Rec_Ent,
7243              Type_Definition     =>
7244                Make_Record_Definition (Loc,
7245                  Component_List =>
7246                    Make_Component_List (Loc,
7247                      Component_Items => Components)));
7248
7249          Insert_After (Last_Decl, Decl);
7250          Last_Decl := Decl;
7251
7252          --  Construct and link in the corresponding access type
7253
7254          Acc_Ent := Make_Temporary (Loc, 'A');
7255
7256          Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
7257
7258          Decl :=
7259            Make_Full_Type_Declaration (Loc,
7260              Defining_Identifier => Acc_Ent,
7261              Type_Definition     =>
7262                Make_Access_To_Object_Definition (Loc,
7263                  All_Present        => True,
7264                  Subtype_Indication => New_Reference_To (Rec_Ent, Loc)));
7265
7266          Insert_After (Last_Decl, Decl);
7267          Last_Decl := Decl;
7268       end if;
7269    end Expand_N_Entry_Declaration;
7270
7271    -----------------------------
7272    -- Expand_N_Protected_Body --
7273    -----------------------------
7274
7275    --  Protected bodies are expanded to the completion of the subprograms
7276    --  created for the corresponding protected type. These are a protected and
7277    --  unprotected version of each protected subprogram in the object, a
7278    --  function to calculate each entry barrier, and a procedure to execute the
7279    --  sequence of statements of each protected entry body. For example, for
7280    --  protected type ptype:
7281
7282    --  function entB
7283    --    (O : System.Address;
7284    --     E : Protected_Entry_Index)
7285    --     return Boolean
7286    --  is
7287    --     <discriminant renamings>
7288    --     <private object renamings>
7289    --  begin
7290    --     return <barrier expression>;
7291    --  end entB;
7292
7293    --  procedure pprocN (_object : in out poV;...) is
7294    --     <discriminant renamings>
7295    --     <private object renamings>
7296    --  begin
7297    --     <sequence of statements>
7298    --  end pprocN;
7299
7300    --  procedure pprocP (_object : in out poV;...) is
7301    --     procedure _clean is
7302    --       Pn : Boolean;
7303    --     begin
7304    --       ptypeS (_object, Pn);
7305    --       Unlock (_object._object'Access);
7306    --       Abort_Undefer.all;
7307    --     end _clean;
7308
7309    --  begin
7310    --     Abort_Defer.all;
7311    --     Lock (_object._object'Access);
7312    --     pprocN (_object;...);
7313    --  at end
7314    --     _clean;
7315    --  end pproc;
7316
7317    --  function pfuncN (_object : poV;...) return Return_Type is
7318    --     <discriminant renamings>
7319    --     <private object renamings>
7320    --  begin
7321    --     <sequence of statements>
7322    --  end pfuncN;
7323
7324    --  function pfuncP (_object : poV) return Return_Type is
7325    --     procedure _clean is
7326    --     begin
7327    --        Unlock (_object._object'Access);
7328    --        Abort_Undefer.all;
7329    --     end _clean;
7330
7331    --  begin
7332    --     Abort_Defer.all;
7333    --     Lock (_object._object'Access);
7334    --     return pfuncN (_object);
7335
7336    --  at end
7337    --     _clean;
7338    --  end pfunc;
7339
7340    --  procedure entE
7341    --    (O : System.Address;
7342    --     P : System.Address;
7343    --     E : Protected_Entry_Index)
7344    --  is
7345    --     <discriminant renamings>
7346    --     <private object renamings>
7347    --     type poVP is access poV;
7348    --     _Object : ptVP := ptVP!(O);
7349
7350    --  begin
7351    --     begin
7352    --        <statement sequence>
7353    --        Complete_Entry_Body (_Object._Object);
7354    --     exception
7355    --        when all others =>
7356    --           Exceptional_Complete_Entry_Body (
7357    --             _Object._Object, Get_GNAT_Exception);
7358    --     end;
7359    --  end entE;
7360
7361    --  The type poV is the record created for the protected type to hold
7362    --  the state of the protected object.
7363
7364    procedure Expand_N_Protected_Body (N : Node_Id) is
7365       Loc          : constant Source_Ptr := Sloc (N);
7366       Pid          : constant Entity_Id  := Corresponding_Spec (N);
7367
7368       Current_Node : Node_Id;
7369       Disp_Op_Body : Node_Id;
7370       New_Op_Body  : Node_Id;
7371       Num_Entries  : Natural := 0;
7372       Op_Body      : Node_Id;
7373       Op_Id        : Entity_Id;
7374
7375       Chain        : Entity_Id := Empty;
7376       --  Finalization chain that may be attached to new body
7377
7378       function Build_Dispatching_Subprogram_Body
7379         (N        : Node_Id;
7380          Pid      : Node_Id;
7381          Prot_Bod : Node_Id) return Node_Id;
7382       --  Build a dispatching version of the protected subprogram body. The
7383       --  newly generated subprogram contains a call to the original protected
7384       --  body. The following code is generated:
7385       --
7386       --  function <protected-function-name> (Param1 .. ParamN) return
7387       --    <return-type> is
7388       --  begin
7389       --     return <protected-function-name>P (Param1 .. ParamN);
7390       --  end <protected-function-name>;
7391       --
7392       --  or
7393       --
7394       --  procedure <protected-procedure-name> (Param1 .. ParamN) is
7395       --  begin
7396       --     <protected-procedure-name>P (Param1 .. ParamN);
7397       --  end <protected-procedure-name>
7398
7399       ---------------------------------------
7400       -- Build_Dispatching_Subprogram_Body --
7401       ---------------------------------------
7402
7403       function Build_Dispatching_Subprogram_Body
7404         (N        : Node_Id;
7405          Pid      : Node_Id;
7406          Prot_Bod : Node_Id) return Node_Id
7407       is
7408          Loc     : constant Source_Ptr := Sloc (N);
7409          Actuals : List_Id;
7410          Formal  : Node_Id;
7411          Spec    : Node_Id;
7412          Stmts   : List_Id;
7413
7414       begin
7415          --  Generate a specification without a letter suffix in order to
7416          --  override an interface function or procedure.
7417
7418          Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
7419
7420          --  The formal parameters become the actuals of the protected function
7421          --  or procedure call.
7422
7423          Actuals := New_List;
7424          Formal  := First (Parameter_Specifications (Spec));
7425          while Present (Formal) loop
7426             Append_To (Actuals,
7427               Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
7428
7429             Next (Formal);
7430          end loop;
7431
7432          if Nkind (Spec) = N_Procedure_Specification then
7433             Stmts :=
7434               New_List (
7435                 Make_Procedure_Call_Statement (Loc,
7436                   Name =>
7437                     New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
7438                   Parameter_Associations => Actuals));
7439          else
7440             pragma Assert (Nkind (Spec) = N_Function_Specification);
7441
7442             Stmts :=
7443               New_List (
7444                 Make_Simple_Return_Statement (Loc,
7445                   Expression =>
7446                     Make_Function_Call (Loc,
7447                       Name =>
7448                         New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
7449                       Parameter_Associations => Actuals)));
7450          end if;
7451
7452          return
7453            Make_Subprogram_Body (Loc,
7454              Declarations               => Empty_List,
7455              Specification              => Spec,
7456              Handled_Statement_Sequence =>
7457                Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7458       end Build_Dispatching_Subprogram_Body;
7459
7460    --  Start of processing for Expand_N_Protected_Body
7461
7462    begin
7463       if No_Run_Time_Mode then
7464          Error_Msg_CRT ("protected body", N);
7465          return;
7466       end if;
7467
7468       --  This is the proper body corresponding to a stub. The declarations
7469       --  must be inserted at the point of the stub, which in turn is in the
7470       --  declarative part of the parent unit.
7471
7472       if Nkind (Parent (N)) = N_Subunit then
7473          Current_Node := Corresponding_Stub (Parent (N));
7474       else
7475          Current_Node := N;
7476       end if;
7477
7478       Op_Body := First (Declarations (N));
7479
7480       --  The protected body is replaced with the bodies of its
7481       --  protected operations, and the declarations for internal objects
7482       --  that may have been created for entry family bounds.
7483
7484       Rewrite (N, Make_Null_Statement (Sloc (N)));
7485       Analyze (N);
7486
7487       while Present (Op_Body) loop
7488          case Nkind (Op_Body) is
7489             when N_Subprogram_Declaration =>
7490                null;
7491
7492             when N_Subprogram_Body =>
7493
7494                --  Do not create bodies for eliminated operations
7495
7496                if not Is_Eliminated (Defining_Entity (Op_Body))
7497                  and then not Is_Eliminated (Corresponding_Spec (Op_Body))
7498                then
7499                   New_Op_Body :=
7500                     Build_Unprotected_Subprogram_Body (Op_Body, Pid);
7501
7502                   --  Propagate the finalization chain to the new body. In the
7503                   --  unlikely event that the subprogram contains a declaration
7504                   --  or allocator for an object that requires finalization,
7505                   --  the corresponding chain is created when analyzing the
7506                   --  body, and attached to its entity. This entity is not
7507                   --  further elaborated, and so the chain properly belongs to
7508                   --  the newly created subprogram body.
7509
7510                   Chain :=
7511                     Finalization_Chain_Entity (Defining_Entity (Op_Body));
7512
7513                   if Present (Chain) then
7514                      Set_Finalization_Chain_Entity
7515                        (Protected_Body_Subprogram
7516                          (Corresponding_Spec (Op_Body)), Chain);
7517                      Set_Analyzed
7518                          (Handled_Statement_Sequence (New_Op_Body), False);
7519                   end if;
7520
7521                   Insert_After (Current_Node, New_Op_Body);
7522                   Current_Node := New_Op_Body;
7523                   Analyze (New_Op_Body);
7524
7525                   --  Build the corresponding protected operation. It may
7526                   --  appear that this is needed only if this is a visible
7527                   --  operation of the type, or if it is an interrupt handler,
7528                   --  and this was the strategy used previously in GNAT.
7529                   --  However, the operation may be exported through a 'Access
7530                   --  to an external caller. This is the common idiom in code
7531                   --  that uses the Ada 2005 Timing_Events package. As a result
7532                   --  we need to produce the protected body for both visible
7533                   --  and private operations, as well as operations that only
7534                   --  have a body in the source, and for which we create a
7535                   --  declaration in the protected body itself.
7536
7537                   if Present (Corresponding_Spec (Op_Body)) then
7538                      New_Op_Body :=
7539                        Build_Protected_Subprogram_Body (
7540                          Op_Body, Pid, Specification (New_Op_Body));
7541
7542                      Insert_After (Current_Node, New_Op_Body);
7543                      Analyze (New_Op_Body);
7544
7545                      Current_Node := New_Op_Body;
7546
7547                      --  Generate an overriding primitive operation body for
7548                      --  this subprogram if the protected type implements an
7549                      --  interface.
7550
7551                      if Ada_Version >= Ada_2005
7552                           and then
7553                         Present (Interfaces (Corresponding_Record_Type (Pid)))
7554                      then
7555                         Disp_Op_Body :=
7556                           Build_Dispatching_Subprogram_Body
7557                             (Op_Body, Pid, New_Op_Body);
7558
7559                         Insert_After (Current_Node, Disp_Op_Body);
7560                         Analyze (Disp_Op_Body);
7561
7562                         Current_Node := Disp_Op_Body;
7563                      end if;
7564                   end if;
7565                end if;
7566
7567             when N_Entry_Body =>
7568                Op_Id := Defining_Identifier (Op_Body);
7569                Num_Entries := Num_Entries + 1;
7570
7571                New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
7572
7573                Insert_After (Current_Node, New_Op_Body);
7574                Current_Node := New_Op_Body;
7575                Analyze (New_Op_Body);
7576
7577             when N_Implicit_Label_Declaration =>
7578                null;
7579
7580             when N_Itype_Reference =>
7581                Insert_After (Current_Node, New_Copy (Op_Body));
7582
7583             when N_Freeze_Entity =>
7584                New_Op_Body := New_Copy (Op_Body);
7585
7586                if Present (Entity (Op_Body))
7587                  and then Freeze_Node (Entity (Op_Body)) = Op_Body
7588                then
7589                   Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
7590                end if;
7591
7592                Insert_After (Current_Node, New_Op_Body);
7593                Current_Node := New_Op_Body;
7594                Analyze (New_Op_Body);
7595
7596             when N_Pragma =>
7597                New_Op_Body := New_Copy (Op_Body);
7598                Insert_After (Current_Node, New_Op_Body);
7599                Current_Node := New_Op_Body;
7600                Analyze (New_Op_Body);
7601
7602             when N_Object_Declaration =>
7603                pragma Assert (not Comes_From_Source (Op_Body));
7604                New_Op_Body := New_Copy (Op_Body);
7605                Insert_After (Current_Node, New_Op_Body);
7606                Current_Node := New_Op_Body;
7607                Analyze (New_Op_Body);
7608
7609             when others =>
7610                raise Program_Error;
7611
7612          end case;
7613
7614          Next (Op_Body);
7615       end loop;
7616
7617       --  Finally, create the body of the function that maps an entry index
7618       --  into the corresponding body index, except when there is no entry, or
7619       --  in a Ravenscar-like profile.
7620
7621       if Corresponding_Runtime_Package (Pid) =
7622            System_Tasking_Protected_Objects_Entries
7623       then
7624          New_Op_Body := Build_Find_Body_Index (Pid);
7625          Insert_After (Current_Node, New_Op_Body);
7626          Current_Node := New_Op_Body;
7627          Analyze (New_Op_Body);
7628       end if;
7629
7630       --  Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
7631       --  protected body. At this point all wrapper specs have been created,
7632       --  frozen and included in the dispatch table for the protected type.
7633
7634       if Ada_Version >= Ada_2005 then
7635          Build_Wrapper_Bodies (Loc, Pid, Current_Node);
7636       end if;
7637    end Expand_N_Protected_Body;
7638
7639    -----------------------------------------
7640    -- Expand_N_Protected_Type_Declaration --
7641    -----------------------------------------
7642
7643    --  First we create a corresponding record type declaration used to
7644    --  represent values of this protected type.
7645    --  The general form of this type declaration is
7646
7647    --    type poV (discriminants) is record
7648    --      _Object       : aliased <kind>Protection
7649    --         [(<entry count> [, <handler count>])];
7650    --      [entry_family  : array (bounds) of Void;]
7651    --      <private data fields>
7652    --    end record;
7653
7654    --  The discriminants are present only if the corresponding protected type
7655    --  has discriminants, and they exactly mirror the protected type
7656    --  discriminants. The private data fields similarly mirror the private
7657    --  declarations of the protected type.
7658
7659    --  The Object field is always present. It contains RTS specific data used
7660    --  to control the protected object. It is declared as Aliased so that it
7661    --  can be passed as a pointer to the RTS. This allows the protected record
7662    --  to be referenced within RTS data structures. An appropriate Protection
7663    --  type and discriminant are generated.
7664
7665    --  The Service field is present for protected objects with entries. It
7666    --  contains sufficient information to allow the entry service procedure for
7667    --  this object to be called when the object is not known till runtime.
7668
7669    --  One entry_family component is present for each entry family in the
7670    --  task definition (see Expand_N_Task_Type_Declaration).
7671
7672    --  When a protected object is declared, an instance of the protected type
7673    --  value record is created. The elaboration of this declaration creates the
7674    --  correct bounds for the entry families, and also evaluates the priority
7675    --  expression if needed. The initialization routine for the protected type
7676    --  itself then calls Initialize_Protection with appropriate parameters to
7677    --  initialize the value of the Task_Id field. Install_Handlers may be also
7678    --  called if a pragma Attach_Handler applies.
7679
7680    --  Note: this record is passed to the subprograms created by the expansion
7681    --  of protected subprograms and entries. It is an in parameter to protected
7682    --  functions and an in out parameter to procedures and entry bodies. The
7683    --  Entity_Id for this created record type is placed in the
7684    --  Corresponding_Record_Type field of the associated protected type entity.
7685
7686    --  Next we create a procedure specifications for protected subprograms and
7687    --  entry bodies. For each protected subprograms two subprograms are
7688    --  created, an unprotected and a protected version. The unprotected version
7689    --  is called from within other operations of the same protected object.
7690
7691    --  We also build the call to register the procedure if a pragma
7692    --  Interrupt_Handler applies.
7693
7694    --  A single subprogram is created to service all entry bodies; it has an
7695    --  additional boolean out parameter indicating that the previous entry call
7696    --  made by the current task was serviced immediately, i.e. not by proxy.
7697    --  The O parameter contains a pointer to a record object of the type
7698    --  described above. An untyped interface is used here to allow this
7699    --  procedure to be called in places where the type of the object to be
7700    --  serviced is not known. This must be done, for example, when a call that
7701    --  may have been requeued is cancelled; the corresponding object must be
7702    --  serviced, but which object that is not known till runtime.
7703
7704    --  procedure ptypeS
7705    --    (O : System.Address; P : out Boolean);
7706    --  procedure pprocN (_object : in out poV);
7707    --  procedure pproc (_object : in out poV);
7708    --  function pfuncN (_object : poV);
7709    --  function pfunc (_object : poV);
7710    --  ...
7711
7712    --  Note that this must come after the record type declaration, since
7713    --  the specs refer to this type.
7714
7715    procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
7716       Loc      : constant Source_Ptr := Sloc (N);
7717       Prot_Typ : constant Entity_Id  := Defining_Identifier (N);
7718
7719       Pdef : constant Node_Id := Protected_Definition (N);
7720       --  This contains two lists; one for visible and one for private decls
7721
7722       Rec_Decl     : Node_Id;
7723       Cdecls       : List_Id;
7724       Discr_Map    : constant Elist_Id := New_Elmt_List;
7725       Priv         : Node_Id;
7726       New_Priv     : Node_Id;
7727       Comp         : Node_Id;
7728       Comp_Id      : Entity_Id;
7729       Sub          : Node_Id;
7730       Current_Node : Node_Id := N;
7731       Bdef         : Entity_Id := Empty; -- avoid uninit warning
7732       Edef         : Entity_Id := Empty; -- avoid uninit warning
7733       Entries_Aggr : Node_Id;
7734       Body_Id      : Entity_Id;
7735       Body_Arr     : Node_Id;
7736       E_Count      : Int;
7737       Object_Comp  : Node_Id;
7738
7739       procedure Check_Inlining (Subp : Entity_Id);
7740       --  If the original operation has a pragma Inline, propagate the flag
7741       --  to the internal body, for possible inlining later on. The source
7742       --  operation is invisible to the back-end and is never actually called.
7743
7744       function Static_Component_Size (Comp : Entity_Id) return Boolean;
7745       --  When compiling under the Ravenscar profile, private components must
7746       --  have a static size, or else a protected object  will require heap
7747       --  allocation, violating the corresponding restriction. It is preferable
7748       --  to make this check here, because it provides a better error message
7749       --  than the back-end, which refers to the object as a whole.
7750
7751       procedure Register_Handler;
7752       --  For a protected operation that is an interrupt handler, add the
7753       --  freeze action that will register it as such.
7754
7755       --------------------
7756       -- Check_Inlining --
7757       --------------------
7758
7759       procedure Check_Inlining (Subp : Entity_Id) is
7760       begin
7761          if Is_Inlined (Subp) then
7762             Set_Is_Inlined (Protected_Body_Subprogram (Subp));
7763             Set_Is_Inlined (Subp, False);
7764          end if;
7765       end Check_Inlining;
7766
7767       ---------------------------------
7768       -- Check_Static_Component_Size --
7769       ---------------------------------
7770
7771       function Static_Component_Size (Comp : Entity_Id) return Boolean is
7772          Typ : constant Entity_Id := Etype (Comp);
7773          C   : Entity_Id;
7774
7775       begin
7776          if Is_Scalar_Type (Typ) then
7777             return True;
7778
7779          elsif Is_Array_Type (Typ) then
7780             return Compile_Time_Known_Bounds (Typ);
7781
7782          elsif Is_Record_Type (Typ) then
7783             C := First_Component (Typ);
7784             while Present (C) loop
7785                if not Static_Component_Size (C) then
7786                   return False;
7787                end if;
7788
7789                Next_Component (C);
7790             end loop;
7791
7792             return True;
7793
7794          --  Any other types will be checked by the back-end
7795
7796          else
7797             return True;
7798          end if;
7799       end Static_Component_Size;
7800
7801       ----------------------
7802       -- Register_Handler --
7803       ----------------------
7804
7805       procedure Register_Handler is
7806
7807          --  All semantic checks already done in Sem_Prag
7808
7809          Prot_Proc    : constant Entity_Id :=
7810                        Defining_Unit_Name
7811                          (Specification (Current_Node));
7812
7813          Proc_Address : constant Node_Id :=
7814                           Make_Attribute_Reference (Loc,
7815                           Prefix => New_Reference_To (Prot_Proc, Loc),
7816                           Attribute_Name => Name_Address);
7817
7818          RTS_Call     : constant Entity_Id :=
7819                           Make_Procedure_Call_Statement (Loc,
7820                             Name =>
7821                               New_Reference_To (
7822                                 RTE (RE_Register_Interrupt_Handler), Loc),
7823                             Parameter_Associations =>
7824                               New_List (Proc_Address));
7825       begin
7826          Append_Freeze_Action (Prot_Proc, RTS_Call);
7827       end Register_Handler;
7828
7829    --  Start of processing for Expand_N_Protected_Type_Declaration
7830
7831    begin
7832       if Present (Corresponding_Record_Type (Prot_Typ)) then
7833          return;
7834       else
7835          Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
7836       end if;
7837
7838       Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
7839
7840       Qualify_Entity_Names (N);
7841
7842       --  If the type has discriminants, their occurrences in the declaration
7843       --  have been replaced by the corresponding discriminals. For components
7844       --  that are constrained by discriminants, their homologues in the
7845       --  corresponding record type must refer to the discriminants of that
7846       --  record, so we must apply a new renaming to subtypes_indications:
7847
7848       --     protected discriminant => discriminal => record discriminant
7849
7850       --  This replacement is not applied to default expressions, for which
7851       --  the discriminal is correct.
7852
7853       if Has_Discriminants (Prot_Typ) then
7854          declare
7855             Disc : Entity_Id;
7856             Decl : Node_Id;
7857
7858          begin
7859             Disc := First_Discriminant (Prot_Typ);
7860             Decl := First (Discriminant_Specifications (Rec_Decl));
7861             while Present (Disc) loop
7862                Append_Elmt (Discriminal (Disc), Discr_Map);
7863                Append_Elmt (Defining_Identifier (Decl), Discr_Map);
7864                Next_Discriminant (Disc);
7865                Next (Decl);
7866             end loop;
7867          end;
7868       end if;
7869
7870       --  Fill in the component declarations
7871
7872       --  Add components for entry families. For each entry family, create an
7873       --  anonymous type declaration with the same size, and analyze the type.
7874
7875       Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
7876
7877       --  Prepend the _Object field with the right type to the component list.
7878       --  We need to compute the number of entries, and in some cases the
7879       --  number of Attach_Handler pragmas.
7880
7881       declare
7882          Ritem              : Node_Id;
7883          Num_Attach_Handler : Int := 0;
7884          Protection_Subtype : Node_Id;
7885          Entry_Count_Expr   : constant Node_Id :=
7886                                 Build_Entry_Count_Expression
7887                                   (Prot_Typ, Cdecls, Loc);
7888
7889       begin
7890          --  Could this be simplified using Corresponding_Runtime_Package???
7891
7892          if Has_Attach_Handler (Prot_Typ) then
7893             Ritem := First_Rep_Item (Prot_Typ);
7894             while Present (Ritem) loop
7895                if Nkind (Ritem) = N_Pragma
7896                  and then Pragma_Name (Ritem) = Name_Attach_Handler
7897                then
7898                   Num_Attach_Handler := Num_Attach_Handler + 1;
7899                end if;
7900
7901                Next_Rep_Item (Ritem);
7902             end loop;
7903
7904             if Restricted_Profile then
7905                if Has_Entries (Prot_Typ) then
7906                   Protection_Subtype :=
7907                     New_Reference_To (RTE (RE_Protection_Entry), Loc);
7908                else
7909                   Protection_Subtype :=
7910                     New_Reference_To (RTE (RE_Protection), Loc);
7911                end if;
7912             else
7913                Protection_Subtype :=
7914                  Make_Subtype_Indication
7915                    (Sloc => Loc,
7916                     Subtype_Mark =>
7917                       New_Reference_To
7918                         (RTE (RE_Static_Interrupt_Protection), Loc),
7919                     Constraint =>
7920                       Make_Index_Or_Discriminant_Constraint (
7921                         Sloc => Loc,
7922                         Constraints => New_List (
7923                           Entry_Count_Expr,
7924                           Make_Integer_Literal (Loc, Num_Attach_Handler))));
7925             end if;
7926
7927          elsif Has_Interrupt_Handler (Prot_Typ) then
7928             Protection_Subtype :=
7929                Make_Subtype_Indication (
7930                  Sloc => Loc,
7931                  Subtype_Mark => New_Reference_To
7932                    (RTE (RE_Dynamic_Interrupt_Protection), Loc),
7933                  Constraint =>
7934                    Make_Index_Or_Discriminant_Constraint (
7935                      Sloc => Loc,
7936                      Constraints => New_List (Entry_Count_Expr)));
7937
7938          --  Type has explicit entries or generated primitive entry wrappers
7939
7940          elsif Has_Entries (Prot_Typ)
7941            or else (Ada_Version >= Ada_2005
7942                       and then Present (Interface_List (N)))
7943          then
7944             case Corresponding_Runtime_Package (Prot_Typ) is
7945                when System_Tasking_Protected_Objects_Entries =>
7946                   Protection_Subtype :=
7947                      Make_Subtype_Indication (Loc,
7948                        Subtype_Mark =>
7949                          New_Reference_To (RTE (RE_Protection_Entries), Loc),
7950                        Constraint =>
7951                          Make_Index_Or_Discriminant_Constraint (
7952                            Sloc => Loc,
7953                            Constraints => New_List (Entry_Count_Expr)));
7954
7955                when System_Tasking_Protected_Objects_Single_Entry =>
7956                   Protection_Subtype :=
7957                     New_Reference_To (RTE (RE_Protection_Entry), Loc);
7958
7959                when others =>
7960                   raise Program_Error;
7961             end case;
7962
7963          else
7964             Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc);
7965          end if;
7966
7967          Object_Comp :=
7968            Make_Component_Declaration (Loc,
7969              Defining_Identifier =>
7970                Make_Defining_Identifier (Loc, Name_uObject),
7971              Component_Definition =>
7972                Make_Component_Definition (Loc,
7973                  Aliased_Present    => True,
7974                  Subtype_Indication => Protection_Subtype));
7975       end;
7976
7977       pragma Assert (Present (Pdef));
7978
7979       --  Add private field components
7980
7981       if Present (Private_Declarations (Pdef)) then
7982          Priv := First (Private_Declarations (Pdef));
7983
7984          while Present (Priv) loop
7985
7986             if Nkind (Priv) = N_Component_Declaration then
7987                if not Static_Component_Size (Defining_Identifier (Priv)) then
7988
7989                   --  When compiling for a restricted profile, the private
7990                   --  components must have a static size. If not, this is an
7991                   --  error for a single protected declaration, and rates a
7992                   --  warning on a protected type declaration.
7993
7994                   if not Comes_From_Source (Prot_Typ) then
7995                      Check_Restriction (No_Implicit_Heap_Allocations, Priv);
7996
7997                   elsif Restriction_Active (No_Implicit_Heap_Allocations) then
7998                      Error_Msg_N ("component has non-static size?", Priv);
7999                      Error_Msg_NE
8000                        ("\creation of protected object of type& will violate"
8001                         & " restriction No_Implicit_Heap_Allocations?",
8002                         Priv, Prot_Typ);
8003                   end if;
8004                end if;
8005
8006                --  The component definition consists of a subtype indication,
8007                --  or (in Ada 2005) an access definition. Make a copy of the
8008                --  proper definition.
8009
8010                declare
8011                   Old_Comp : constant Node_Id   := Component_Definition (Priv);
8012                   Oent     : constant Entity_Id := Defining_Identifier (Priv);
8013                   New_Comp : Node_Id;
8014                   Nent     : constant Entity_Id :=
8015                                Make_Defining_Identifier (Sloc (Oent),
8016                                  Chars => Chars (Oent));
8017
8018                begin
8019                   if Present (Subtype_Indication (Old_Comp)) then
8020                      New_Comp :=
8021                        Make_Component_Definition (Sloc (Oent),
8022                          Aliased_Present    => False,
8023                          Subtype_Indication =>
8024                            New_Copy_Tree (Subtype_Indication (Old_Comp),
8025                                            Discr_Map));
8026                   else
8027                      New_Comp :=
8028                        Make_Component_Definition (Sloc (Oent),
8029                          Aliased_Present    => False,
8030                          Access_Definition  =>
8031                            New_Copy_Tree (Access_Definition (Old_Comp),
8032                                            Discr_Map));
8033                   end if;
8034
8035                   New_Priv :=
8036                     Make_Component_Declaration (Loc,
8037                       Defining_Identifier  => Nent,
8038                       Component_Definition => New_Comp,
8039                       Expression           => Expression (Priv));
8040
8041                   Set_Has_Per_Object_Constraint (Nent,
8042                     Has_Per_Object_Constraint (Oent));
8043
8044                   Append_To (Cdecls, New_Priv);
8045                end;
8046
8047             elsif Nkind (Priv) = N_Subprogram_Declaration then
8048
8049                --  Make the unprotected version of the subprogram available
8050                --  for expansion of intra object calls. There is need for
8051                --  a protected version only if the subprogram is an interrupt
8052                --  handler, otherwise  this operation can only be called from
8053                --  within the body.
8054
8055                Sub :=
8056                  Make_Subprogram_Declaration (Loc,
8057                    Specification =>
8058                      Build_Protected_Sub_Specification
8059                        (Priv, Prot_Typ, Unprotected_Mode));
8060
8061                Insert_After (Current_Node, Sub);
8062                Analyze (Sub);
8063
8064                Set_Protected_Body_Subprogram
8065                  (Defining_Unit_Name (Specification (Priv)),
8066                   Defining_Unit_Name (Specification (Sub)));
8067                Check_Inlining (Defining_Unit_Name (Specification (Priv)));
8068                Current_Node := Sub;
8069
8070                Sub :=
8071                  Make_Subprogram_Declaration (Loc,
8072                    Specification =>
8073                      Build_Protected_Sub_Specification
8074                        (Priv, Prot_Typ, Protected_Mode));
8075
8076                Insert_After (Current_Node, Sub);
8077                Analyze (Sub);
8078                Current_Node := Sub;
8079
8080                if Is_Interrupt_Handler
8081                  (Defining_Unit_Name (Specification (Priv)))
8082                then
8083                   if not Restricted_Profile then
8084                      Register_Handler;
8085                   end if;
8086                end if;
8087             end if;
8088
8089             Next (Priv);
8090          end loop;
8091       end if;
8092
8093       --  Put the _Object component after the private component so that it
8094       --  be finalized early as required by 9.4 (20)
8095
8096       Append_To (Cdecls, Object_Comp);
8097
8098       Insert_After (Current_Node, Rec_Decl);
8099       Current_Node := Rec_Decl;
8100
8101       --  Analyze the record declaration immediately after construction,
8102       --  because the initialization procedure is needed for single object
8103       --  declarations before the next entity is analyzed (the freeze call
8104       --  that generates this initialization procedure is found below).
8105
8106       Analyze (Rec_Decl, Suppress => All_Checks);
8107
8108       --  Ada 2005 (AI-345): Construct the primitive entry wrappers before
8109       --  the corresponding record is frozen. If any wrappers are generated,
8110       --  Current_Node is updated accordingly.
8111
8112       if Ada_Version >= Ada_2005 then
8113          Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
8114       end if;
8115
8116       --  Collect pointers to entry bodies and their barriers, to be placed
8117       --  in the Entry_Bodies_Array for the type. For each entry/family we
8118       --  add an expression to the aggregate which is the initial value of
8119       --  this array. The array is declared after all protected subprograms.
8120
8121       if Has_Entries (Prot_Typ) then
8122          Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
8123       else
8124          Entries_Aggr := Empty;
8125       end if;
8126
8127       --  Build two new procedure specifications for each protected subprogram;
8128       --  one to call from outside the object and one to call from inside.
8129       --  Build a barrier function and an entry body action procedure
8130       --  specification for each protected entry. Initialize the entry body
8131       --  array. If subprogram is flagged as eliminated, do not generate any
8132       --  internal operations.
8133
8134       E_Count := 0;
8135
8136       Comp := First (Visible_Declarations (Pdef));
8137
8138       while Present (Comp) loop
8139          if Nkind (Comp) = N_Subprogram_Declaration then
8140             Sub :=
8141               Make_Subprogram_Declaration (Loc,
8142                 Specification =>
8143                   Build_Protected_Sub_Specification
8144                     (Comp, Prot_Typ, Unprotected_Mode));
8145
8146             Insert_After (Current_Node, Sub);
8147             Analyze (Sub);
8148
8149             Set_Protected_Body_Subprogram
8150               (Defining_Unit_Name (Specification (Comp)),
8151                Defining_Unit_Name (Specification (Sub)));
8152                Check_Inlining (Defining_Unit_Name (Specification (Comp)));
8153
8154             --  Make the protected version of the subprogram available for
8155             --  expansion of external calls.
8156
8157             Current_Node := Sub;
8158
8159             Sub :=
8160               Make_Subprogram_Declaration (Loc,
8161                 Specification =>
8162                   Build_Protected_Sub_Specification
8163                     (Comp, Prot_Typ, Protected_Mode));
8164
8165             Insert_After (Current_Node, Sub);
8166             Analyze (Sub);
8167
8168             Current_Node := Sub;
8169
8170             --  Generate an overriding primitive operation specification for
8171             --  this subprogram if the protected type implements an interface.
8172
8173             if Ada_Version >= Ada_2005
8174               and then
8175                 Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
8176             then
8177                Sub :=
8178                  Make_Subprogram_Declaration (Loc,
8179                    Specification =>
8180                      Build_Protected_Sub_Specification
8181                        (Comp, Prot_Typ, Dispatching_Mode));
8182
8183                Insert_After (Current_Node, Sub);
8184                Analyze (Sub);
8185
8186                Current_Node := Sub;
8187             end if;
8188
8189             --  If a pragma Interrupt_Handler applies, build and add a call to
8190             --  Register_Interrupt_Handler to the freezing actions of the
8191             --  protected version (Current_Node) of the subprogram:
8192
8193             --    system.interrupts.register_interrupt_handler
8194             --       (prot_procP'address);
8195
8196             if not Restricted_Profile
8197               and then Is_Interrupt_Handler
8198                          (Defining_Unit_Name (Specification (Comp)))
8199             then
8200                Register_Handler;
8201             end if;
8202
8203          elsif Nkind (Comp) = N_Entry_Declaration then
8204             E_Count := E_Count + 1;
8205             Comp_Id := Defining_Identifier (Comp);
8206
8207             Edef :=
8208               Make_Defining_Identifier (Loc,
8209                 Build_Selected_Name (Prot_Typ, Comp_Id, 'E'));
8210             Sub :=
8211               Make_Subprogram_Declaration (Loc,
8212                 Specification =>
8213                   Build_Protected_Entry_Specification (Loc, Edef, Comp_Id));
8214
8215             Insert_After (Current_Node, Sub);
8216             Analyze (Sub);
8217
8218             --  build wrapper procedure for pre/postconditions.
8219
8220             Build_PPC_Wrapper (Comp_Id, N);
8221
8222             Set_Protected_Body_Subprogram
8223               (Defining_Identifier (Comp),
8224                Defining_Unit_Name (Specification (Sub)));
8225
8226             Current_Node := Sub;
8227
8228             Bdef :=
8229               Make_Defining_Identifier (Loc,
8230                 Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B'));
8231             Sub :=
8232               Make_Subprogram_Declaration (Loc,
8233                 Specification =>
8234                   Build_Barrier_Function_Specification (Loc, Bdef));
8235
8236             Insert_After (Current_Node, Sub);
8237             Analyze (Sub);
8238             Set_Protected_Body_Subprogram (Bdef, Bdef);
8239             Set_Barrier_Function (Comp_Id, Bdef);
8240             Set_Scope (Bdef, Scope (Comp_Id));
8241             Current_Node := Sub;
8242
8243             --  Collect pointers to the protected subprogram and the barrier
8244             --  of the current entry, for insertion into Entry_Bodies_Array.
8245
8246             Append (
8247               Make_Aggregate (Loc,
8248                 Expressions => New_List (
8249                   Make_Attribute_Reference (Loc,
8250                     Prefix => New_Reference_To (Bdef, Loc),
8251                     Attribute_Name => Name_Unrestricted_Access),
8252                   Make_Attribute_Reference (Loc,
8253                     Prefix => New_Reference_To (Edef, Loc),
8254                     Attribute_Name => Name_Unrestricted_Access))),
8255               Expressions (Entries_Aggr));
8256
8257          end if;
8258
8259          Next (Comp);
8260       end loop;
8261
8262       --  If there are some private entry declarations, expand it as if they
8263       --  were visible entries.
8264
8265       if Present (Private_Declarations (Pdef)) then
8266          Comp := First (Private_Declarations (Pdef));
8267          while Present (Comp) loop
8268             if Nkind (Comp) = N_Entry_Declaration then
8269                E_Count := E_Count + 1;
8270                Comp_Id := Defining_Identifier (Comp);
8271
8272                Edef :=
8273                  Make_Defining_Identifier (Loc,
8274                   Build_Selected_Name (Prot_Typ, Comp_Id, 'E'));
8275                Sub :=
8276                  Make_Subprogram_Declaration (Loc,
8277                    Specification =>
8278                      Build_Protected_Entry_Specification (Loc, Edef, Comp_Id));
8279
8280                Insert_After (Current_Node, Sub);
8281                Analyze (Sub);
8282
8283                Set_Protected_Body_Subprogram
8284                  (Defining_Identifier (Comp),
8285                   Defining_Unit_Name (Specification (Sub)));
8286
8287                Current_Node := Sub;
8288
8289                Bdef :=
8290                  Make_Defining_Identifier (Loc,
8291                    Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E'));
8292
8293                Sub :=
8294                  Make_Subprogram_Declaration (Loc,
8295                    Specification =>
8296                      Build_Barrier_Function_Specification (Loc, Bdef));
8297
8298                Insert_After (Current_Node, Sub);
8299                Analyze (Sub);
8300                Set_Protected_Body_Subprogram (Bdef, Bdef);
8301                Set_Barrier_Function (Comp_Id, Bdef);
8302                Set_Scope (Bdef, Scope (Comp_Id));
8303                Current_Node := Sub;
8304
8305                --  Collect pointers to the protected subprogram and the barrier
8306                --  of the current entry, for insertion into Entry_Bodies_Array.
8307
8308                Append_To (Expressions (Entries_Aggr),
8309                  Make_Aggregate (Loc,
8310                    Expressions => New_List (
8311                      Make_Attribute_Reference (Loc,
8312                        Prefix => New_Reference_To (Bdef, Loc),
8313                        Attribute_Name => Name_Unrestricted_Access),
8314                      Make_Attribute_Reference (Loc,
8315                        Prefix => New_Reference_To (Edef, Loc),
8316                        Attribute_Name => Name_Unrestricted_Access))));
8317             end if;
8318
8319             Next (Comp);
8320          end loop;
8321       end if;
8322
8323       --  Emit declaration for Entry_Bodies_Array, now that the addresses of
8324       --  all protected subprograms have been collected.
8325
8326       if Has_Entries (Prot_Typ) then
8327          Body_Id :=
8328            Make_Defining_Identifier (Sloc (Prot_Typ),
8329              Chars => New_External_Name (Chars (Prot_Typ), 'A'));
8330
8331          case Corresponding_Runtime_Package (Prot_Typ) is
8332             when System_Tasking_Protected_Objects_Entries =>
8333                Body_Arr := Make_Object_Declaration (Loc,
8334                  Defining_Identifier => Body_Id,
8335                  Aliased_Present => True,
8336                  Object_Definition =>
8337                    Make_Subtype_Indication (Loc,
8338                      Subtype_Mark => New_Reference_To (
8339                        RTE (RE_Protected_Entry_Body_Array), Loc),
8340                      Constraint =>
8341                        Make_Index_Or_Discriminant_Constraint (Loc,
8342                          Constraints => New_List (
8343                             Make_Range (Loc,
8344                               Make_Integer_Literal (Loc, 1),
8345                               Make_Integer_Literal (Loc, E_Count))))),
8346                  Expression => Entries_Aggr);
8347
8348             when System_Tasking_Protected_Objects_Single_Entry =>
8349                Body_Arr := Make_Object_Declaration (Loc,
8350                  Defining_Identifier => Body_Id,
8351                  Aliased_Present => True,
8352                  Object_Definition => New_Reference_To
8353                                         (RTE (RE_Entry_Body), Loc),
8354                  Expression =>
8355                    Make_Aggregate (Loc,
8356                      Expressions => New_List (
8357                        Make_Attribute_Reference (Loc,
8358                          Prefix => New_Reference_To (Bdef, Loc),
8359                          Attribute_Name => Name_Unrestricted_Access),
8360                        Make_Attribute_Reference (Loc,
8361                          Prefix => New_Reference_To (Edef, Loc),
8362                          Attribute_Name => Name_Unrestricted_Access))));
8363
8364             when others =>
8365                raise Program_Error;
8366          end case;
8367
8368          --  A pointer to this array will be placed in the corresponding record
8369          --  by its initialization procedure so this needs to be analyzed here.
8370
8371          Insert_After (Current_Node, Body_Arr);
8372          Current_Node := Body_Arr;
8373          Analyze (Body_Arr);
8374
8375          Set_Entry_Bodies_Array (Prot_Typ, Body_Id);
8376
8377          --  Finally, build the function that maps an entry index into the
8378          --  corresponding body. A pointer to this function is placed in each
8379          --  object of the type. Except for a ravenscar-like profile (no abort,
8380          --  no entry queue, 1 entry)
8381
8382          if Corresponding_Runtime_Package (Prot_Typ) =
8383               System_Tasking_Protected_Objects_Entries
8384          then
8385             Sub :=
8386               Make_Subprogram_Declaration (Loc,
8387                 Specification => Build_Find_Body_Index_Spec (Prot_Typ));
8388             Insert_After (Current_Node, Sub);
8389             Analyze (Sub);
8390          end if;
8391       end if;
8392    end Expand_N_Protected_Type_Declaration;
8393
8394    --------------------------------
8395    -- Expand_N_Requeue_Statement --
8396    --------------------------------
8397
8398    --  A non-dispatching requeue statement is expanded into one of four GNARLI
8399    --  operations, depending on the source and destination (task or protected
8400    --  object). A dispatching requeue statement is expanded into a call to the
8401    --  predefined primitive _Disp_Requeue. In addition, code is generated to
8402    --  jump around the remainder of processing for the original entry and, if
8403    --  the destination is (different) protected object, to attempt to service
8404    --  it. The following illustrates the various cases:
8405
8406    --  procedure entE
8407    --    (O : System.Address;
8408    --     P : System.Address;
8409    --     E : Protected_Entry_Index)
8410    --  is
8411    --     <discriminant renamings>
8412    --     <private object renamings>
8413    --     type poVP is access poV;
8414    --     _object : ptVP := ptVP!(O);
8415
8416    --  begin
8417    --     begin
8418    --        <start of statement sequence for entry>
8419
8420    --        -- Requeue from one protected entry body to another protected
8421    --        -- entry.
8422
8423    --        Requeue_Protected_Entry (
8424    --          _object._object'Access,
8425    --          new._object'Access,
8426    --          E,
8427    --          Abort_Present);
8428    --        return;
8429
8430    --        <some more of the statement sequence for entry>
8431
8432    --        --  Requeue from an entry body to a task entry
8433
8434    --        Requeue_Protected_To_Task_Entry (
8435    --          New._task_id,
8436    --          E,
8437    --          Abort_Present);
8438    --        return;
8439
8440    --        <rest of statement sequence for entry>
8441    --        Complete_Entry_Body (_object._object);
8442
8443    --     exception
8444    --        when all others =>
8445    --           Exceptional_Complete_Entry_Body (
8446    --             _object._object, Get_GNAT_Exception);
8447    --     end;
8448    --  end entE;
8449
8450    --  Requeue of a task entry call to a task entry
8451
8452    --  Accept_Call (E, Ann);
8453    --     <start of statement sequence for accept statement>
8454    --     Requeue_Task_Entry (New._task_id, E, Abort_Present);
8455    --     goto Lnn;
8456    --     <rest of statement sequence for accept statement>
8457    --     <<Lnn>>
8458    --     Complete_Rendezvous;
8459
8460    --  exception
8461    --     when all others =>
8462    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8463
8464    --  Requeue of a task entry call to a protected entry
8465
8466    --  Accept_Call (E, Ann);
8467    --     <start of statement sequence for accept statement>
8468    --     Requeue_Task_To_Protected_Entry (
8469    --       new._object'Access,
8470    --       E,
8471    --       Abort_Present);
8472    --     newS (new, Pnn);
8473    --     goto Lnn;
8474    --     <rest of statement sequence for accept statement>
8475    --     <<Lnn>>
8476    --     Complete_Rendezvous;
8477
8478    --  exception
8479    --     when all others =>
8480    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8481
8482    --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8483    --  marked by pragma Implemented (XXX, By_Entry).
8484
8485    --  The requeue is inside a protected entry:
8486
8487    --  procedure entE
8488    --    (O : System.Address;
8489    --     P : System.Address;
8490    --     E : Protected_Entry_Index)
8491    --  is
8492    --     <discriminant renamings>
8493    --     <private object renamings>
8494    --     type poVP is access poV;
8495    --     _object : ptVP := ptVP!(O);
8496
8497    --  begin
8498    --     begin
8499    --        <start of statement sequence for entry>
8500
8501    --        _Disp_Requeue
8502    --          (<interface class-wide object>,
8503    --           True,
8504    --           _object'Address,
8505    --           Ada.Tags.Get_Offset_Index
8506    --             (Tag (_object),
8507    --              <interface dispatch table index of target entry>),
8508    --           Abort_Present);
8509    --        return;
8510
8511    --        <rest of statement sequence for entry>
8512    --        Complete_Entry_Body (_object._object);
8513
8514    --     exception
8515    --        when all others =>
8516    --           Exceptional_Complete_Entry_Body (
8517    --             _object._object, Get_GNAT_Exception);
8518    --     end;
8519    --  end entE;
8520
8521    --  The requeue is inside a task entry:
8522
8523    --    Accept_Call (E, Ann);
8524    --     <start of statement sequence for accept statement>
8525    --     _Disp_Requeue
8526    --       (<interface class-wide object>,
8527    --        False,
8528    --        null,
8529    --        Ada.Tags.Get_Offset_Index
8530    --          (Tag (_object),
8531    --           <interface dispatch table index of target entrt>),
8532    --        Abort_Present);
8533    --     newS (new, Pnn);
8534    --     goto Lnn;
8535    --     <rest of statement sequence for accept statement>
8536    --     <<Lnn>>
8537    --     Complete_Rendezvous;
8538
8539    --  exception
8540    --     when all others =>
8541    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8542
8543    --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8544    --  marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
8545    --  statement is replaced by a dispatching call with actual parameters taken
8546    --  from the inner-most accept statement or entry body.
8547
8548    --    Target.Primitive (Param1, ..., ParamN);
8549
8550    --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8551    --  marked by pragma Implemented (XXX, By_Any) or not marked at all.
8552
8553    --    declare
8554    --       S : constant Offset_Index :=
8555    --             Get_Offset_Index (Tag (Concval), DT_Position (Ename));
8556    --       C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
8557
8558    --    begin
8559    --       if C = POK_Protected_Entry
8560    --         or else C = POK_Task_Entry
8561    --       then
8562    --          <statements for dispatching requeue>
8563
8564    --       elsif C = POK_Protected_Procedure then
8565    --          <dispatching call equivalent>
8566
8567    --       else
8568    --          raise Program_Error;
8569    --       end if;
8570    --    end;
8571
8572    procedure Expand_N_Requeue_Statement (N : Node_Id) is
8573       Loc      : constant Source_Ptr := Sloc (N);
8574       Conc_Typ : Entity_Id;
8575       Concval  : Node_Id;
8576       Ename    : Node_Id;
8577       Index    : Node_Id;
8578       Old_Typ  : Entity_Id;
8579
8580       function Build_Dispatching_Call_Equivalent return Node_Id;
8581       --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8582       --  the form Concval.Ename. It is statically known that Ename is allowed
8583       --  to be implemented by a protected procedure. Create a dispatching call
8584       --  equivalent of Concval.Ename taking the actual parameters from the
8585       --  inner-most accept statement or entry body.
8586
8587       function Build_Dispatching_Requeue return Node_Id;
8588       --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8589       --  the form Concval.Ename. It is statically known that Ename is allowed
8590       --  to be implemented by a protected or a task entry. Create a call to
8591       --  primitive _Disp_Requeue which handles the low-level actions.
8592
8593       function Build_Dispatching_Requeue_To_Any return Node_Id;
8594       --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8595       --  the form Concval.Ename. Ename is either marked by pragma Implemented
8596       --  (XXX, By_Any) or not marked at all. Create a block which determines
8597       --  at runtime whether Ename denotes an entry or a procedure and perform
8598       --  the appropriate kind of dispatching select.
8599
8600       function Build_Normal_Requeue return Node_Id;
8601       --  N denotes a non-dispatching requeue statement to either a task or a
8602       --  protected entry. Build the appropriate runtime call to perform the
8603       --  action.
8604
8605       function Build_Skip_Statement (Search : Node_Id) return Node_Id;
8606       --  For a protected entry, create a return statement to skip the rest of
8607       --  the entry body. Otherwise, create a goto statement to skip the rest
8608       --  of a task accept statement. The lookup for the enclosing entry body
8609       --  or accept statement starts from Search.
8610
8611       ---------------------------------------
8612       -- Build_Dispatching_Call_Equivalent --
8613       ---------------------------------------
8614
8615       function Build_Dispatching_Call_Equivalent return Node_Id is
8616          Call_Ent : constant Entity_Id := Entity (Ename);
8617          Obj      : constant Node_Id   := Original_Node (Concval);
8618          Acc_Ent  : Node_Id;
8619          Actuals  : List_Id;
8620          Formal   : Node_Id;
8621          Formals  : List_Id;
8622
8623       begin
8624          --  Climb the parent chain looking for the inner-most entry body or
8625          --  accept statement.
8626
8627          Acc_Ent := N;
8628          while Present (Acc_Ent)
8629            and then not Nkind_In (Acc_Ent, N_Accept_Statement,
8630                                            N_Entry_Body)
8631          loop
8632             Acc_Ent := Parent (Acc_Ent);
8633          end loop;
8634
8635          --  A requeue statement should be housed inside an entry body or an
8636          --  accept statement at some level. If this is not the case, then the
8637          --  tree is malformed.
8638
8639          pragma Assert (Present (Acc_Ent));
8640
8641          --  Recover the list of formal parameters
8642
8643          if Nkind (Acc_Ent) = N_Entry_Body then
8644             Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
8645          end if;
8646
8647          Formals := Parameter_Specifications (Acc_Ent);
8648
8649          --  Create the actual parameters for the dispatching call. These are
8650          --  simply copies of the entry body or accept statement formals in the
8651          --  same order as they appear.
8652
8653          Actuals := No_List;
8654
8655          if Present (Formals) then
8656             Actuals := New_List;
8657             Formal  := First (Formals);
8658             while Present (Formal) loop
8659                Append_To (Actuals,
8660                  Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
8661                Next (Formal);
8662             end loop;
8663          end if;
8664
8665          --  Generate:
8666          --    Obj.Call_Ent (Actuals);
8667
8668          return
8669            Make_Procedure_Call_Statement (Loc,
8670              Name =>
8671                Make_Selected_Component (Loc,
8672                  Prefix        => Make_Identifier (Loc, Chars (Obj)),
8673                  Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))),
8674
8675              Parameter_Associations => Actuals);
8676       end Build_Dispatching_Call_Equivalent;
8677
8678       -------------------------------
8679       -- Build_Dispatching_Requeue --
8680       -------------------------------
8681
8682       function Build_Dispatching_Requeue return Node_Id is
8683          Params : constant List_Id := New_List;
8684
8685       begin
8686          --  Process the "with abort" parameter
8687
8688          Prepend_To (Params,
8689            New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
8690
8691          --  Process the entry wrapper's position in the primary dispatch
8692          --  table parameter. Generate:
8693
8694          --    Ada.Tags.Get_Offset_Index
8695          --      (Ada.Tags.Tag (Concval),
8696          --       <interface dispatch table position of Ename>)
8697
8698          Prepend_To (Params,
8699            Make_Function_Call (Loc,
8700              Name =>
8701                New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
8702
8703              Parameter_Associations => New_List (
8704                Unchecked_Convert_To (RTE (RE_Tag), Concval),
8705                Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
8706
8707          --  Specific actuals for protected to XXX requeue
8708
8709          if Is_Protected_Type (Old_Typ) then
8710             Prepend_To (Params,
8711               Make_Attribute_Reference (Loc,        --  _object'Address
8712                 Prefix =>
8713                   Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
8714                 Attribute_Name => Name_Address));
8715
8716             Prepend_To (Params,                     --  True
8717               New_Reference_To (Standard_True, Loc));
8718
8719          --  Specific actuals for task to XXX requeue
8720
8721          else
8722             pragma Assert (Is_Task_Type (Old_Typ));
8723
8724             Prepend_To (Params,                     --  null
8725               New_Reference_To (RTE (RE_Null_Address), Loc));
8726
8727             Prepend_To (Params,                     --  False
8728               New_Reference_To (Standard_False, Loc));
8729          end if;
8730
8731          --  Add the object parameter
8732
8733          Prepend_To (Params, New_Copy_Tree (Concval));
8734
8735          --  Generate:
8736          --    _Disp_Requeue (<Params>);
8737
8738          return
8739            Make_Procedure_Call_Statement (Loc,
8740              Name => Make_Identifier (Loc, Name_uDisp_Requeue),
8741              Parameter_Associations => Params);
8742       end Build_Dispatching_Requeue;
8743
8744       --------------------------------------
8745       -- Build_Dispatching_Requeue_To_Any --
8746       --------------------------------------
8747
8748       function Build_Dispatching_Requeue_To_Any return Node_Id is
8749          Call_Ent : constant Entity_Id := Entity (Ename);
8750          Obj      : constant Node_Id   := Original_Node (Concval);
8751          Skip     : constant Node_Id   := Build_Skip_Statement (N);
8752          C        : Entity_Id;
8753          Decls    : List_Id;
8754          S        : Entity_Id;
8755          Stmts    : List_Id;
8756
8757       begin
8758          Decls := New_List;
8759          Stmts := New_List;
8760
8761          --  Dispatch table slot processing, generate:
8762          --    S : Integer;
8763
8764          S := Build_S (Loc, Decls);
8765
8766          --  Call kind processing, generate:
8767          --    C : Ada.Tags.Prim_Op_Kind;
8768
8769          C := Build_C (Loc, Decls);
8770
8771          --  Generate:
8772          --    S := Ada.Tags.Get_Offset_Index
8773          --           (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
8774
8775          Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
8776
8777          --  Generate:
8778          --    _Disp_Get_Prim_Op_Kind (Obj, S, C);
8779
8780          Append_To (Stmts,
8781            Make_Procedure_Call_Statement (Loc,
8782              Name =>
8783                New_Reference_To (
8784                  Find_Prim_Op (Etype (Etype (Obj)),
8785                    Name_uDisp_Get_Prim_Op_Kind),
8786                  Loc),
8787              Parameter_Associations => New_List (
8788                New_Copy_Tree (Obj),
8789                New_Reference_To (S, Loc),
8790                New_Reference_To (C, Loc))));
8791
8792          Append_To (Stmts,
8793
8794             --  if C = POK_Protected_Entry
8795             --    or else C = POK_Task_Entry
8796             --  then
8797
8798            Make_If_Statement (Loc,
8799              Condition =>
8800                Make_Op_Or (Loc,
8801                  Left_Opnd =>
8802                    Make_Op_Eq (Loc,
8803                      Left_Opnd =>
8804                        New_Reference_To (C, Loc),
8805                      Right_Opnd =>
8806                        New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
8807
8808                  Right_Opnd =>
8809                    Make_Op_Eq (Loc,
8810                      Left_Opnd =>
8811                        New_Reference_To (C, Loc),
8812                      Right_Opnd =>
8813                        New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
8814
8815                --  Dispatching requeue equivalent
8816
8817              Then_Statements => New_List (
8818                Build_Dispatching_Requeue,
8819                Skip),
8820
8821                --  elsif C = POK_Protected_Procedure then
8822
8823              Elsif_Parts => New_List (
8824                Make_Elsif_Part (Loc,
8825                  Condition =>
8826                    Make_Op_Eq (Loc,
8827                      Left_Opnd =>
8828                        New_Reference_To (C, Loc),
8829                      Right_Opnd =>
8830                        New_Reference_To (
8831                          RTE (RE_POK_Protected_Procedure), Loc)),
8832
8833                   --  Dispatching call equivalent
8834
8835                  Then_Statements => New_List (
8836                    Build_Dispatching_Call_Equivalent))),
8837
8838             --  else
8839             --     raise Program_Error;
8840             --  end if;
8841
8842              Else_Statements => New_List (
8843                Make_Raise_Program_Error (Loc,
8844                  Reason => PE_Explicit_Raise))));
8845
8846          --  Wrap everything into a block
8847
8848          return
8849            Make_Block_Statement (Loc,
8850              Declarations => Decls,
8851              Handled_Statement_Sequence =>
8852                Make_Handled_Sequence_Of_Statements (Loc,
8853                  Statements => Stmts));
8854       end Build_Dispatching_Requeue_To_Any;
8855
8856       --------------------------
8857       -- Build_Normal_Requeue --
8858       --------------------------
8859
8860       function Build_Normal_Requeue return Node_Id is
8861          Params  : constant List_Id := New_List;
8862          Param   : Node_Id;
8863          RT_Call : Node_Id;
8864
8865       begin
8866          --  Process the "with abort" parameter
8867
8868          Prepend_To (Params,
8869            New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
8870
8871          --  Add the index expression to the parameters. It is common among all
8872          --  four cases.
8873
8874          Prepend_To (Params,
8875            Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
8876
8877          if Is_Protected_Type (Old_Typ) then
8878             declare
8879                Self_Param : Node_Id;
8880
8881             begin
8882                Self_Param :=
8883                  Make_Attribute_Reference (Loc,
8884                    Prefix =>
8885                      Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
8886                    Attribute_Name =>
8887                      Name_Unchecked_Access);
8888
8889                --  Protected to protected requeue
8890
8891                if Is_Protected_Type (Conc_Typ) then
8892                   RT_Call :=
8893                     New_Reference_To (
8894                       RTE (RE_Requeue_Protected_Entry), Loc);
8895
8896                   Param :=
8897                     Make_Attribute_Reference (Loc,
8898                       Prefix =>
8899                         Concurrent_Ref (Concval),
8900                       Attribute_Name =>
8901                         Name_Unchecked_Access);
8902
8903                --  Protected to task requeue
8904
8905                else pragma Assert (Is_Task_Type (Conc_Typ));
8906                   RT_Call :=
8907                     New_Reference_To (
8908                       RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
8909
8910                   Param := Concurrent_Ref (Concval);
8911                end if;
8912
8913                Prepend_To (Params, Param);
8914                Prepend_To (Params, Self_Param);
8915             end;
8916
8917          else pragma Assert (Is_Task_Type (Old_Typ));
8918
8919             --  Task to protected requeue
8920
8921             if Is_Protected_Type (Conc_Typ) then
8922                RT_Call :=
8923                  New_Reference_To (
8924                    RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
8925
8926                Param :=
8927                  Make_Attribute_Reference (Loc,
8928                    Prefix =>
8929                      Concurrent_Ref (Concval),
8930                    Attribute_Name =>
8931                      Name_Unchecked_Access);
8932
8933             --  Task to task requeue
8934
8935             else pragma Assert (Is_Task_Type (Conc_Typ));
8936                RT_Call :=
8937                  New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc);
8938
8939                Param := Concurrent_Ref (Concval);
8940             end if;
8941
8942             Prepend_To (Params, Param);
8943          end if;
8944
8945          return
8946             Make_Procedure_Call_Statement (Loc,
8947               Name => RT_Call,
8948               Parameter_Associations => Params);
8949       end Build_Normal_Requeue;
8950
8951       --------------------------
8952       -- Build_Skip_Statement --
8953       --------------------------
8954
8955       function Build_Skip_Statement (Search : Node_Id) return Node_Id is
8956          Skip_Stmt : Node_Id;
8957
8958       begin
8959          --  Build a return statement to skip the rest of the entire body
8960
8961          if Is_Protected_Type (Old_Typ) then
8962             Skip_Stmt := Make_Simple_Return_Statement (Loc);
8963
8964          --  If the requeue is within a task, find the end label of the
8965          --  enclosing accept statement and create a goto statement to it.
8966
8967          else
8968             declare
8969                Acc   : Node_Id;
8970                Label : Node_Id;
8971
8972             begin
8973                --  Climb the parent chain looking for the enclosing accept
8974                --  statement.
8975
8976                Acc := Parent (Search);
8977                while Present (Acc)
8978                  and then Nkind (Acc) /= N_Accept_Statement
8979                loop
8980                   Acc := Parent (Acc);
8981                end loop;
8982
8983                --  The last statement is the second label used for completing
8984                --  the rendezvous the usual way. The label we are looking for
8985                --  is right before it.
8986
8987                Label :=
8988                  Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
8989
8990                pragma Assert (Nkind (Label) = N_Label);
8991
8992                --  Generate a goto statement to skip the rest of the accept
8993
8994                Skip_Stmt :=
8995                  Make_Goto_Statement (Loc,
8996                    Name =>
8997                      New_Occurrence_Of (Entity (Identifier (Label)), Loc));
8998             end;
8999          end if;
9000
9001          Set_Analyzed (Skip_Stmt);
9002
9003          return Skip_Stmt;
9004       end Build_Skip_Statement;
9005
9006    --  Start of processing for Expand_N_Requeue_Statement
9007
9008    begin
9009       --  Extract the components of the entry call
9010
9011       Extract_Entry (N, Concval, Ename, Index);
9012       Conc_Typ := Etype (Concval);
9013
9014       --  Examine the scope stack in order to find nearest enclosing protected
9015       --  or task type. This will constitute our invocation source.
9016
9017       Old_Typ := Current_Scope;
9018       while Present (Old_Typ)
9019         and then not Is_Protected_Type (Old_Typ)
9020         and then not Is_Task_Type (Old_Typ)
9021       loop
9022          Old_Typ := Scope (Old_Typ);
9023       end loop;
9024
9025       --  Ada 2012 (AI05-0030): We have a dispatching requeue of the form
9026       --  Concval.Ename where the type of Concval is class-wide concurrent
9027       --  interface.
9028
9029       if Ada_Version >= Ada_2012
9030         and then Present (Concval)
9031         and then Is_Class_Wide_Type (Conc_Typ)
9032         and then Is_Concurrent_Interface (Conc_Typ)
9033       then
9034          declare
9035             Has_Impl  : Boolean := False;
9036             Impl_Kind : Name_Id := No_Name;
9037
9038          begin
9039             --  Check whether the Ename is flagged by pragma Implemented
9040
9041             if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
9042                Has_Impl  := True;
9043                Impl_Kind := Implementation_Kind (Entity (Ename));
9044             end if;
9045
9046             --  The procedure_or_entry_NAME is guaranteed to be overridden by
9047             --  an entry. Create a call to predefined primitive _Disp_Requeue.
9048
9049             if Has_Impl
9050               and then Impl_Kind = Name_By_Entry
9051             then
9052                Rewrite (N, Build_Dispatching_Requeue);
9053                Analyze (N);
9054                Insert_After (N, Build_Skip_Statement (N));
9055
9056             --  The procedure_or_entry_NAME is guaranteed to be overridden by
9057             --  a protected procedure. In this case the requeue is transformed
9058             --  into a dispatching call.
9059
9060             elsif Has_Impl
9061               and then Impl_Kind = Name_By_Protected_Procedure
9062             then
9063                Rewrite (N, Build_Dispatching_Call_Equivalent);
9064                Analyze (N);
9065
9066             --  The procedure_or_entry_NAME's implementation kind is either
9067             --  By_Any or pragma Implemented was not applied at all. In this
9068             --  case a runtime test determines whether Ename denotes an entry
9069             --  or a protected procedure and performs the appropriate call.
9070
9071             else
9072                Rewrite (N, Build_Dispatching_Requeue_To_Any);
9073                Analyze (N);
9074             end if;
9075          end;
9076
9077       --  Processing for regular (non-dispatching) requeues
9078
9079       else
9080          Rewrite (N, Build_Normal_Requeue);
9081          Analyze (N);
9082          Insert_After (N, Build_Skip_Statement (N));
9083       end if;
9084    end Expand_N_Requeue_Statement;
9085
9086    -------------------------------
9087    -- Expand_N_Selective_Accept --
9088    -------------------------------
9089
9090    procedure Expand_N_Selective_Accept (N : Node_Id) is
9091       Loc            : constant Source_Ptr := Sloc (N);
9092       Alts           : constant List_Id    := Select_Alternatives (N);
9093
9094       --  Note: in the below declarations a lot of new lists are allocated
9095       --  unconditionally which may well not end up being used. That's
9096       --  not a good idea since it wastes space gratuitously ???
9097
9098       Accept_Case    : List_Id;
9099       Accept_List    : constant List_Id := New_List;
9100
9101       Alt            : Node_Id;
9102       Alt_List       : constant List_Id := New_List;
9103       Alt_Stats      : List_Id;
9104       Ann            : Entity_Id := Empty;
9105
9106       Block          : Node_Id;
9107       Check_Guard    : Boolean := True;
9108
9109       Decls          : constant List_Id := New_List;
9110       Stats          : constant List_Id := New_List;
9111       Body_List      : constant List_Id := New_List;
9112       Trailing_List  : constant List_Id := New_List;
9113
9114       Choices        : List_Id;
9115       Else_Present   : Boolean := False;
9116       Terminate_Alt  : Node_Id := Empty;
9117       Select_Mode    : Node_Id;
9118
9119       Delay_Case     : List_Id;
9120       Delay_Count    : Integer := 0;
9121       Delay_Val      : Entity_Id;
9122       Delay_Index    : Entity_Id;
9123       Delay_Min      : Entity_Id;
9124       Delay_Num      : Int := 1;
9125       Delay_Alt_List : List_Id := New_List;
9126       Delay_List     : constant List_Id := New_List;
9127       D              : Entity_Id;
9128       M              : Entity_Id;
9129
9130       First_Delay    : Boolean := True;
9131       Guard_Open     : Entity_Id;
9132
9133       End_Lab        : Node_Id;
9134       Index          : Int := 1;
9135       Lab            : Node_Id;
9136       Num_Alts       : Int;
9137       Num_Accept     : Nat := 0;
9138       Proc           : Node_Id;
9139       Q              : Node_Id;
9140       Time_Type      : Entity_Id;
9141       X              : Node_Id;
9142       Select_Call    : Node_Id;
9143
9144       Qnam : constant Entity_Id :=
9145                Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
9146
9147       Xnam : constant Entity_Id :=
9148                Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
9149
9150       -----------------------
9151       -- Local subprograms --
9152       -----------------------
9153
9154       function Accept_Or_Raise return List_Id;
9155       --  For the rare case where delay alternatives all have guards, and
9156       --  all of them are closed, it is still possible that there were open
9157       --  accept alternatives with no callers. We must reexamine the
9158       --  Accept_List, and execute a selective wait with no else if some
9159       --  accept is open. If none, we raise program_error.
9160
9161       procedure Add_Accept (Alt : Node_Id);
9162       --  Process a single accept statement in a select alternative. Build
9163       --  procedure for body of accept, and add entry to dispatch table with
9164       --  expression for guard, in preparation for call to run time select.
9165
9166       function Make_And_Declare_Label (Num : Int) return Node_Id;
9167       --  Manufacture a label using Num as a serial number and declare it.
9168       --  The declaration is appended to Decls. The label marks the trailing
9169       --  statements of an accept or delay alternative.
9170
9171       function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
9172       --  Build call to Selective_Wait runtime routine
9173
9174       procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
9175       --  Add code to compare value of delay with previous values, and
9176       --  generate case entry for trailing statements.
9177
9178       procedure Process_Accept_Alternative
9179         (Alt   : Node_Id;
9180          Index : Int;
9181          Proc  : Node_Id);
9182       --  Add code to call corresponding procedure, and branch to
9183       --  trailing statements, if any.
9184
9185       ---------------------
9186       -- Accept_Or_Raise --
9187       ---------------------
9188
9189       function Accept_Or_Raise return List_Id is
9190          Cond  : Node_Id;
9191          Stats : List_Id;
9192          J     : constant Entity_Id := Make_Temporary (Loc, 'J');
9193
9194       begin
9195          --  We generate the following:
9196
9197          --    for J in q'range loop
9198          --       if q(J).S /=null_task_entry then
9199          --          selective_wait (simple_mode,...);
9200          --          done := True;
9201          --          exit;
9202          --       end if;
9203          --    end loop;
9204          --
9205          --    if no rendez_vous then
9206          --       raise program_error;
9207          --    end if;
9208
9209          --    Note that the code needs to know that the selector name
9210          --    in an Accept_Alternative is named S.
9211
9212          Cond := Make_Op_Ne (Loc,
9213            Left_Opnd =>
9214              Make_Selected_Component (Loc,
9215                Prefix        =>
9216                  Make_Indexed_Component (Loc,
9217                    Prefix => New_Reference_To (Qnam, Loc),
9218                      Expressions => New_List (New_Reference_To (J, Loc))),
9219                Selector_Name => Make_Identifier (Loc, Name_S)),
9220            Right_Opnd =>
9221              New_Reference_To (RTE (RE_Null_Task_Entry), Loc));
9222
9223          Stats := New_List (
9224            Make_Implicit_Loop_Statement (N,
9225              Identifier => Empty,
9226              Iteration_Scheme =>
9227                Make_Iteration_Scheme (Loc,
9228                  Loop_Parameter_Specification =>
9229                    Make_Loop_Parameter_Specification (Loc,
9230                      Defining_Identifier => J,
9231                      Discrete_Subtype_Definition =>
9232                        Make_Attribute_Reference (Loc,
9233                          Prefix => New_Reference_To (Qnam, Loc),
9234                          Attribute_Name => Name_Range,
9235                          Expressions => New_List (
9236                            Make_Integer_Literal (Loc, 1))))),
9237
9238              Statements => New_List (
9239                Make_Implicit_If_Statement (N,
9240                  Condition =>  Cond,
9241                  Then_Statements => New_List (
9242                    Make_Select_Call (
9243                     New_Reference_To (RTE (RE_Simple_Mode), Loc)),
9244                    Make_Exit_Statement (Loc))))));
9245
9246          Append_To (Stats,
9247            Make_Raise_Program_Error (Loc,
9248              Condition => Make_Op_Eq (Loc,
9249                Left_Opnd  => New_Reference_To (Xnam, Loc),
9250                Right_Opnd =>
9251                  New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
9252              Reason => PE_All_Guards_Closed));
9253
9254          return Stats;
9255       end Accept_Or_Raise;
9256
9257       ----------------
9258       -- Add_Accept --
9259       ----------------
9260
9261       procedure Add_Accept (Alt : Node_Id) is
9262          Acc_Stm   : constant Node_Id    := Accept_Statement (Alt);
9263          Ename     : constant Node_Id    := Entry_Direct_Name (Acc_Stm);
9264          Eloc      : constant Source_Ptr := Sloc (Ename);
9265          Eent      : constant Entity_Id  := Entity (Ename);
9266          Index     : constant Node_Id    := Entry_Index (Acc_Stm);
9267          Null_Body : Node_Id;
9268          Proc_Body : Node_Id;
9269          PB_Ent    : Entity_Id;
9270          Expr      : Node_Id;
9271          Call      : Node_Id;
9272
9273       begin
9274          if No (Ann) then
9275             Ann := Node (Last_Elmt (Accept_Address (Eent)));
9276          end if;
9277
9278          if Present (Condition (Alt)) then
9279             Expr :=
9280               Make_Conditional_Expression (Eloc, New_List (
9281                 Condition (Alt),
9282                 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
9283                 New_Reference_To (RTE (RE_Null_Task_Entry), Eloc)));
9284          else
9285             Expr :=
9286               Entry_Index_Expression
9287                 (Eloc, Eent, Index, Scope (Eent));
9288          end if;
9289
9290          if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
9291             Null_Body := New_Reference_To (Standard_False, Eloc);
9292
9293             if Abort_Allowed then
9294                Call := Make_Procedure_Call_Statement (Eloc,
9295                  Name => New_Reference_To (RTE (RE_Abort_Undefer), Eloc));
9296                Insert_Before (First (Statements (Handled_Statement_Sequence (
9297                  Accept_Statement (Alt)))), Call);
9298                Analyze (Call);
9299             end if;
9300
9301             PB_Ent :=
9302               Make_Defining_Identifier (Eloc,
9303                 New_External_Name (Chars (Ename), 'A', Num_Accept));
9304
9305             if Comes_From_Source (Alt) then
9306                Set_Debug_Info_Needed (PB_Ent);
9307             end if;
9308
9309             Proc_Body :=
9310               Make_Subprogram_Body (Eloc,
9311                 Specification =>
9312                   Make_Procedure_Specification (Eloc,
9313                     Defining_Unit_Name => PB_Ent),
9314                Declarations => Declarations (Acc_Stm),
9315                Handled_Statement_Sequence =>
9316                  Build_Accept_Body (Accept_Statement (Alt)));
9317
9318             --  During the analysis of the body of the accept statement, any
9319             --  zero cost exception handler records were collected in the
9320             --  Accept_Handler_Records field of the N_Accept_Alternative node.
9321             --  This is where we move them to where they belong, namely the
9322             --  newly created procedure.
9323
9324             Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
9325             Append (Proc_Body, Body_List);
9326
9327          else
9328             Null_Body := New_Reference_To (Standard_True,  Eloc);
9329
9330             --  if accept statement has declarations, insert above, given that
9331             --  we are not creating a body for the accept.
9332
9333             if Present (Declarations (Acc_Stm)) then
9334                Insert_Actions (N, Declarations (Acc_Stm));
9335             end if;
9336          end if;
9337
9338          Append_To (Accept_List,
9339            Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr)));
9340
9341          Num_Accept := Num_Accept + 1;
9342       end Add_Accept;
9343
9344       ----------------------------
9345       -- Make_And_Declare_Label --
9346       ----------------------------
9347
9348       function Make_And_Declare_Label (Num : Int) return Node_Id is
9349          Lab_Id : Node_Id;
9350
9351       begin
9352          Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
9353          Lab :=
9354            Make_Label (Loc, Lab_Id);
9355
9356          Append_To (Decls,
9357            Make_Implicit_Label_Declaration (Loc,
9358              Defining_Identifier  =>
9359                Make_Defining_Identifier (Loc, Chars (Lab_Id)),
9360              Label_Construct => Lab));
9361
9362          return Lab;
9363       end Make_And_Declare_Label;
9364
9365       ----------------------
9366       -- Make_Select_Call --
9367       ----------------------
9368
9369       function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
9370          Params : constant List_Id := New_List;
9371
9372       begin
9373          Append (
9374            Make_Attribute_Reference (Loc,
9375              Prefix => New_Reference_To (Qnam, Loc),
9376              Attribute_Name => Name_Unchecked_Access),
9377            Params);
9378          Append (Select_Mode, Params);
9379          Append (New_Reference_To (Ann, Loc), Params);
9380          Append (New_Reference_To (Xnam, Loc), Params);
9381
9382          return
9383            Make_Procedure_Call_Statement (Loc,
9384              Name => New_Reference_To (RTE (RE_Selective_Wait), Loc),
9385              Parameter_Associations => Params);
9386       end Make_Select_Call;
9387
9388       --------------------------------
9389       -- Process_Accept_Alternative --
9390       --------------------------------
9391
9392       procedure Process_Accept_Alternative
9393         (Alt   : Node_Id;
9394          Index : Int;
9395          Proc  : Node_Id)
9396       is
9397          Choices   : List_Id := No_List;
9398          Alt_Stats : List_Id;
9399
9400       begin
9401          Adjust_Condition (Condition (Alt));
9402          Alt_Stats := No_List;
9403
9404          if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
9405             Choices := New_List (
9406               Make_Integer_Literal (Loc, Index));
9407
9408             Alt_Stats := New_List (
9409               Make_Procedure_Call_Statement (Sloc (Proc),
9410                 Name => New_Reference_To (
9411                   Defining_Unit_Name (Specification (Proc)), Sloc (Proc))));
9412          end if;
9413
9414          if Statements (Alt) /= Empty_List then
9415
9416             if No (Alt_Stats) then
9417
9418                --  Accept with no body, followed by trailing statements
9419
9420                Choices := New_List (
9421                  Make_Integer_Literal (Loc, Index));
9422
9423                Alt_Stats := New_List;
9424             end if;
9425
9426             --  After the call, if any, branch to trailing statements. We
9427             --  create a label for each, as well as the corresponding label
9428             --  declaration.
9429
9430             Lab := Make_And_Declare_Label (Index);
9431             Append_To (Alt_Stats,
9432               Make_Goto_Statement (Loc,
9433                 Name => New_Copy (Identifier (Lab))));
9434
9435             Append (Lab, Trailing_List);
9436             Append_List (Statements (Alt), Trailing_List);
9437             Append_To (Trailing_List,
9438               Make_Goto_Statement (Loc,
9439                 Name => New_Copy (Identifier (End_Lab))));
9440          end if;
9441
9442          if Present (Alt_Stats) then
9443
9444             --  Procedure call. and/or trailing statements
9445
9446             Append_To (Alt_List,
9447               Make_Case_Statement_Alternative (Loc,
9448                 Discrete_Choices => Choices,
9449                 Statements => Alt_Stats));
9450          end if;
9451       end Process_Accept_Alternative;
9452
9453       -------------------------------
9454       -- Process_Delay_Alternative --
9455       -------------------------------
9456
9457       procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
9458          Choices   : List_Id;
9459          Cond      : Node_Id;
9460          Delay_Alt : List_Id;
9461
9462       begin
9463          --  Deal with C/Fortran boolean as delay condition
9464
9465          Adjust_Condition (Condition (Alt));
9466
9467          --  Determine the smallest specified delay
9468
9469          --  for each delay alternative generate:
9470
9471          --    if guard-expression then
9472          --       Delay_Val  := delay-expression;
9473          --       Guard_Open := True;
9474          --       if Delay_Val < Delay_Min then
9475          --          Delay_Min   := Delay_Val;
9476          --          Delay_Index := Index;
9477          --       end if;
9478          --    end if;
9479
9480          --  The enclosing if-statement is omitted if there is no guard
9481
9482          if Delay_Count = 1
9483            or else First_Delay
9484          then
9485             First_Delay := False;
9486
9487             Delay_Alt := New_List (
9488               Make_Assignment_Statement (Loc,
9489                 Name => New_Reference_To (Delay_Min, Loc),
9490                 Expression => Expression (Delay_Statement (Alt))));
9491
9492             if Delay_Count > 1 then
9493                Append_To (Delay_Alt,
9494                  Make_Assignment_Statement (Loc,
9495                    Name       => New_Reference_To (Delay_Index, Loc),
9496                    Expression => Make_Integer_Literal (Loc, Index)));
9497             end if;
9498
9499          else
9500             Delay_Alt := New_List (
9501               Make_Assignment_Statement (Loc,
9502                 Name => New_Reference_To (Delay_Val, Loc),
9503                 Expression => Expression (Delay_Statement (Alt))));
9504
9505             if Time_Type = Standard_Duration then
9506                Cond :=
9507                   Make_Op_Lt (Loc,
9508                     Left_Opnd  => New_Reference_To (Delay_Val, Loc),
9509                     Right_Opnd => New_Reference_To (Delay_Min, Loc));
9510
9511             else
9512                --  The scope of the time type must define a comparison
9513                --  operator. The scope itself may not be visible, so we
9514                --  construct a node with entity information to insure that
9515                --  semantic analysis can find the proper operator.
9516
9517                Cond :=
9518                  Make_Function_Call (Loc,
9519                    Name => Make_Selected_Component (Loc,
9520                      Prefix => New_Reference_To (Scope (Time_Type), Loc),
9521                      Selector_Name =>
9522                        Make_Operator_Symbol (Loc,
9523                          Chars => Name_Op_Lt,
9524                          Strval => No_String)),
9525                     Parameter_Associations =>
9526                       New_List (
9527                         New_Reference_To (Delay_Val, Loc),
9528                         New_Reference_To (Delay_Min, Loc)));
9529
9530                Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
9531             end if;
9532
9533             Append_To (Delay_Alt,
9534               Make_Implicit_If_Statement (N,
9535                 Condition => Cond,
9536                 Then_Statements => New_List (
9537                   Make_Assignment_Statement (Loc,
9538                     Name       => New_Reference_To (Delay_Min, Loc),
9539                     Expression => New_Reference_To (Delay_Val, Loc)),
9540
9541                   Make_Assignment_Statement (Loc,
9542                     Name       => New_Reference_To (Delay_Index, Loc),
9543                     Expression => Make_Integer_Literal (Loc, Index)))));
9544          end if;
9545
9546          if Check_Guard then
9547             Append_To (Delay_Alt,
9548               Make_Assignment_Statement (Loc,
9549                 Name => New_Reference_To (Guard_Open, Loc),
9550                 Expression => New_Reference_To (Standard_True, Loc)));
9551          end if;
9552
9553          if Present (Condition (Alt)) then
9554             Delay_Alt := New_List (
9555               Make_Implicit_If_Statement (N,
9556                 Condition => Condition (Alt),
9557                 Then_Statements => Delay_Alt));
9558          end if;
9559
9560          Append_List (Delay_Alt, Delay_List);
9561
9562          --  If the delay alternative has a statement part, add choice to the
9563          --  case statements for delays.
9564
9565          if Present (Statements (Alt)) then
9566
9567             if Delay_Count = 1 then
9568                Append_List (Statements (Alt), Delay_Alt_List);
9569
9570             else
9571                Choices := New_List (
9572                  Make_Integer_Literal (Loc, Index));
9573
9574                Append_To (Delay_Alt_List,
9575                  Make_Case_Statement_Alternative (Loc,
9576                    Discrete_Choices => Choices,
9577                    Statements => Statements (Alt)));
9578             end if;
9579
9580          elsif Delay_Count = 1 then
9581
9582             --  If the single delay has no trailing statements, add a branch
9583             --  to the exit label to the selective wait.
9584
9585             Delay_Alt_List := New_List (
9586               Make_Goto_Statement (Loc,
9587                 Name => New_Copy (Identifier (End_Lab))));
9588
9589          end if;
9590       end Process_Delay_Alternative;
9591
9592    --  Start of processing for Expand_N_Selective_Accept
9593
9594    begin
9595       --  First insert some declarations before the select. The first is:
9596
9597       --    Ann : Address
9598
9599       --  This variable holds the parameters passed to the accept body. This
9600       --  declaration has already been inserted by the time we get here by
9601       --  a call to Expand_Accept_Declarations made from the semantics when
9602       --  processing the first accept statement contained in the select. We
9603       --  can find this entity as Accept_Address (E), where E is any of the
9604       --  entries references by contained accept statements.
9605
9606       --  The first step is to scan the list of Selective_Accept_Statements
9607       --  to find this entity, and also count the number of accepts, and
9608       --  determine if terminated, delay or else is present:
9609
9610       Num_Alts := 0;
9611
9612       Alt := First (Alts);
9613       while Present (Alt) loop
9614
9615          if Nkind (Alt) = N_Accept_Alternative then
9616             Add_Accept (Alt);
9617
9618          elsif Nkind (Alt) = N_Delay_Alternative then
9619             Delay_Count := Delay_Count + 1;
9620
9621             --  If the delays are relative delays, the delay expressions have
9622             --  type Standard_Duration. Otherwise they must have some time type
9623             --  recognized by GNAT.
9624
9625             if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
9626                Time_Type := Standard_Duration;
9627             else
9628                Time_Type := Etype (Expression (Delay_Statement (Alt)));
9629
9630                if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
9631                  or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
9632                then
9633                   null;
9634                else
9635                   Error_Msg_NE (
9636                     "& is not a time type (RM 9.6(6))",
9637                        Expression (Delay_Statement (Alt)), Time_Type);
9638                   Time_Type := Standard_Duration;
9639                   Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
9640                end if;
9641             end if;
9642
9643             if No (Condition (Alt)) then
9644
9645                --  This guard will always be open
9646
9647                Check_Guard := False;
9648             end if;
9649
9650          elsif Nkind (Alt) = N_Terminate_Alternative then
9651             Adjust_Condition (Condition (Alt));
9652             Terminate_Alt := Alt;
9653          end if;
9654
9655          Num_Alts := Num_Alts + 1;
9656          Next (Alt);
9657       end loop;
9658
9659       Else_Present := Present (Else_Statements (N));
9660
9661       --  At the same time (see procedure Add_Accept) we build the accept list:
9662
9663       --    Qnn : Accept_List (1 .. num-select) := (
9664       --          (null-body, entry-index),
9665       --          (null-body, entry-index),
9666       --          ..
9667       --          (null_body, entry-index));
9668
9669       --  In the above declaration, null-body is True if the corresponding
9670       --  accept has no body, and false otherwise. The entry is either the
9671       --  entry index expression if there is no guard, or if a guard is
9672       --  present, then a conditional expression of the form:
9673
9674       --    (if guard then entry-index else Null_Task_Entry)
9675
9676       --  If a guard is statically known to be false, the entry can simply
9677       --  be omitted from the accept list.
9678
9679       Q :=
9680         Make_Object_Declaration (Loc,
9681           Defining_Identifier => Qnam,
9682           Object_Definition =>
9683             New_Reference_To (RTE (RE_Accept_List), Loc),
9684           Aliased_Present => True,
9685
9686           Expression =>
9687              Make_Qualified_Expression (Loc,
9688                Subtype_Mark =>
9689                  New_Reference_To (RTE (RE_Accept_List), Loc),
9690                Expression =>
9691                  Make_Aggregate (Loc, Expressions => Accept_List)));
9692
9693       Append (Q, Decls);
9694
9695       --  Then we declare the variable that holds the index for the accept
9696       --  that will be selected for service:
9697
9698       --    Xnn : Select_Index;
9699
9700       X :=
9701         Make_Object_Declaration (Loc,
9702           Defining_Identifier => Xnam,
9703           Object_Definition =>
9704             New_Reference_To (RTE (RE_Select_Index), Loc),
9705           Expression =>
9706             New_Reference_To (RTE (RE_No_Rendezvous), Loc));
9707
9708       Append (X, Decls);
9709
9710       --  After this follow procedure declarations for each accept body
9711
9712       --    procedure Pnn is
9713       --    begin
9714       --       ...
9715       --    end;
9716
9717       --  where the ... are statements from the corresponding procedure body.
9718       --  No parameters are involved, since the parameters are passed via Ann
9719       --  and the parameter references have already been expanded to be direct
9720       --  references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
9721       --  any embedded tasking statements (which would normally be illegal in
9722       --  procedures), have been converted to calls to the tasking runtime so
9723       --  there is no problem in putting them into procedures.
9724
9725       --  The original accept statement has been expanded into a block in
9726       --  the same fashion as for simple accepts (see Build_Accept_Body).
9727
9728       --  Note: we don't really need to build these procedures for the case
9729       --  where no delay statement is present, but it is just as easy to
9730       --  build them unconditionally, and not significantly inefficient,
9731       --  since if they are short they will be inlined anyway.
9732
9733       --  The procedure declarations have been assembled in Body_List
9734
9735       --  If delays are present, we must compute the required delay.
9736       --  We first generate the declarations:
9737
9738       --    Delay_Index : Boolean := 0;
9739       --    Delay_Min   : Some_Time_Type.Time;
9740       --    Delay_Val   : Some_Time_Type.Time;
9741
9742       --  Delay_Index will be set to the index of the minimum delay, i.e. the
9743       --  active delay that is actually chosen as the basis for the possible
9744       --  delay if an immediate rendez-vous is not possible.
9745
9746       --  In the most common case there is a single delay statement, and this
9747       --  is handled specially.
9748
9749       if Delay_Count > 0 then
9750
9751          --  Generate the required declarations
9752
9753          Delay_Val :=
9754            Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
9755          Delay_Index :=
9756            Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
9757          Delay_Min :=
9758            Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
9759
9760          Append_To (Decls,
9761            Make_Object_Declaration (Loc,
9762              Defining_Identifier => Delay_Val,
9763              Object_Definition   => New_Reference_To (Time_Type, Loc)));
9764
9765          Append_To (Decls,
9766            Make_Object_Declaration (Loc,
9767              Defining_Identifier => Delay_Index,
9768              Object_Definition   => New_Reference_To (Standard_Integer, Loc),
9769              Expression          => Make_Integer_Literal (Loc, 0)));
9770
9771          Append_To (Decls,
9772            Make_Object_Declaration (Loc,
9773              Defining_Identifier => Delay_Min,
9774              Object_Definition   => New_Reference_To (Time_Type, Loc),
9775              Expression          =>
9776                Unchecked_Convert_To (Time_Type,
9777                  Make_Attribute_Reference (Loc,
9778                    Prefix =>
9779                      New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
9780                    Attribute_Name => Name_Last))));
9781
9782          --  Create Duration and Delay_Mode objects used for passing a delay
9783          --  value to RTS
9784
9785          D := Make_Temporary (Loc, 'D');
9786          M := Make_Temporary (Loc, 'M');
9787
9788          declare
9789             Discr : Entity_Id;
9790
9791          begin
9792             --  Note that these values are defined in s-osprim.ads and must
9793             --  be kept in sync:
9794             --
9795             --     Relative          : constant := 0;
9796             --     Absolute_Calendar : constant := 1;
9797             --     Absolute_RT       : constant := 2;
9798
9799             if Time_Type = Standard_Duration then
9800                Discr := Make_Integer_Literal (Loc, 0);
9801
9802             elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
9803                Discr := Make_Integer_Literal (Loc, 1);
9804
9805             else
9806                pragma Assert
9807                  (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
9808                Discr := Make_Integer_Literal (Loc, 2);
9809             end if;
9810
9811             Append_To (Decls,
9812               Make_Object_Declaration (Loc,
9813                 Defining_Identifier => D,
9814                 Object_Definition =>
9815                   New_Reference_To (Standard_Duration, Loc)));
9816
9817             Append_To (Decls,
9818               Make_Object_Declaration (Loc,
9819                 Defining_Identifier => M,
9820                 Object_Definition   =>
9821                   New_Reference_To (Standard_Integer, Loc),
9822                 Expression          => Discr));
9823          end;
9824
9825          if Check_Guard then
9826             Guard_Open :=
9827               Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
9828
9829             Append_To (Decls,
9830               Make_Object_Declaration (Loc,
9831                  Defining_Identifier => Guard_Open,
9832                  Object_Definition => New_Reference_To (Standard_Boolean, Loc),
9833                  Expression        => New_Reference_To (Standard_False, Loc)));
9834          end if;
9835
9836       --  Delay_Count is zero, don't need M and D set (suppress warning)
9837
9838       else
9839          M := Empty;
9840          D := Empty;
9841       end if;
9842
9843       if Present (Terminate_Alt) then
9844
9845          --  If the terminate alternative guard is False, use
9846          --  Simple_Mode; otherwise use Terminate_Mode.
9847
9848          if Present (Condition (Terminate_Alt)) then
9849             Select_Mode := Make_Conditional_Expression (Loc,
9850               New_List (Condition (Terminate_Alt),
9851                         New_Reference_To (RTE (RE_Terminate_Mode), Loc),
9852                         New_Reference_To (RTE (RE_Simple_Mode), Loc)));
9853          else
9854             Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc);
9855          end if;
9856
9857       elsif Else_Present or Delay_Count > 0 then
9858          Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc);
9859
9860       else
9861          Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc);
9862       end if;
9863
9864       Select_Call := Make_Select_Call (Select_Mode);
9865       Append (Select_Call, Stats);
9866
9867       --  Now generate code to act on the result. There is an entry
9868       --  in this case for each accept statement with a non-null body,
9869       --  followed by a branch to the statements that follow the Accept.
9870       --  In the absence of delay alternatives, we generate:
9871
9872       --    case X is
9873       --      when No_Rendezvous =>  --  omitted if simple mode
9874       --         goto Lab0;
9875
9876       --      when 1 =>
9877       --         P1n;
9878       --         goto Lab1;
9879
9880       --      when 2 =>
9881       --         P2n;
9882       --         goto Lab2;
9883
9884       --      when others =>
9885       --         goto Exit;
9886       --    end case;
9887       --
9888       --    Lab0: Else_Statements;
9889       --    goto exit;
9890
9891       --    Lab1:  Trailing_Statements1;
9892       --    goto Exit;
9893       --
9894       --    Lab2:  Trailing_Statements2;
9895       --    goto Exit;
9896       --    ...
9897       --    Exit:
9898
9899       --  Generate label for common exit
9900
9901       End_Lab := Make_And_Declare_Label (Num_Alts + 1);
9902
9903       --  First entry is the default case, when no rendezvous is possible
9904
9905       Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc));
9906
9907       if Else_Present then
9908
9909          --  If no rendezvous is possible, the else part is executed
9910
9911          Lab := Make_And_Declare_Label (0);
9912          Alt_Stats := New_List (
9913            Make_Goto_Statement (Loc,
9914              Name => New_Copy (Identifier (Lab))));
9915
9916          Append (Lab, Trailing_List);
9917          Append_List (Else_Statements (N), Trailing_List);
9918          Append_To (Trailing_List,
9919            Make_Goto_Statement (Loc,
9920              Name => New_Copy (Identifier (End_Lab))));
9921       else
9922          Alt_Stats := New_List (
9923            Make_Goto_Statement (Loc,
9924              Name => New_Copy (Identifier (End_Lab))));
9925       end if;
9926
9927       Append_To (Alt_List,
9928         Make_Case_Statement_Alternative (Loc,
9929           Discrete_Choices => Choices,
9930           Statements => Alt_Stats));
9931
9932       --  We make use of the fact that Accept_Index is an integer type, and
9933       --  generate successive literals for entries for each accept. Only those
9934       --  for which there is a body or trailing statements get a case entry.
9935
9936       Alt := First (Select_Alternatives (N));
9937       Proc := First (Body_List);
9938       while Present (Alt) loop
9939
9940          if Nkind (Alt) = N_Accept_Alternative then
9941             Process_Accept_Alternative (Alt, Index, Proc);
9942             Index := Index + 1;
9943
9944             if Present
9945               (Handled_Statement_Sequence (Accept_Statement (Alt)))
9946             then
9947                Next (Proc);
9948             end if;
9949
9950          elsif Nkind (Alt) = N_Delay_Alternative then
9951             Process_Delay_Alternative (Alt, Delay_Num);
9952             Delay_Num := Delay_Num + 1;
9953          end if;
9954
9955          Next (Alt);
9956       end loop;
9957
9958       --  An others choice is always added to the main case, as well
9959       --  as the delay case (to satisfy the compiler).
9960
9961       Append_To (Alt_List,
9962         Make_Case_Statement_Alternative (Loc,
9963           Discrete_Choices =>
9964             New_List (Make_Others_Choice (Loc)),
9965           Statements       =>
9966             New_List (Make_Goto_Statement (Loc,
9967               Name => New_Copy (Identifier (End_Lab))))));
9968
9969       Accept_Case := New_List (
9970         Make_Case_Statement (Loc,
9971           Expression   => New_Reference_To (Xnam, Loc),
9972           Alternatives => Alt_List));
9973
9974       Append_List (Trailing_List, Accept_Case);
9975       Append (End_Lab, Accept_Case);
9976       Append_List (Body_List, Decls);
9977
9978       --  Construct case statement for trailing statements of delay
9979       --  alternatives, if there are several of them.
9980
9981       if Delay_Count > 1 then
9982          Append_To (Delay_Alt_List,
9983            Make_Case_Statement_Alternative (Loc,
9984              Discrete_Choices =>
9985                New_List (Make_Others_Choice (Loc)),
9986              Statements       =>
9987                New_List (Make_Null_Statement (Loc))));
9988
9989          Delay_Case := New_List (
9990            Make_Case_Statement (Loc,
9991              Expression   => New_Reference_To (Delay_Index, Loc),
9992              Alternatives => Delay_Alt_List));
9993       else
9994          Delay_Case := Delay_Alt_List;
9995       end if;
9996
9997       --  If there are no delay alternatives, we append the case statement
9998       --  to the statement list.
9999
10000       if Delay_Count = 0 then
10001          Append_List (Accept_Case, Stats);
10002
10003       --  Delay alternatives present
10004
10005       else
10006          --  If delay alternatives are present we generate:
10007
10008          --    find minimum delay.
10009          --    DX := minimum delay;
10010          --    M := <delay mode>;
10011          --    Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
10012          --      DX, MX, X);
10013          --
10014          --    if X = No_Rendezvous then
10015          --      case statement for delay statements.
10016          --    else
10017          --      case statement for accept alternatives.
10018          --    end if;
10019
10020          declare
10021             Cases : Node_Id;
10022             Stmt  : Node_Id;
10023             Parms : List_Id;
10024             Parm  : Node_Id;
10025             Conv  : Node_Id;
10026
10027          begin
10028             --  The type of the delay expression is known to be legal
10029
10030             if Time_Type = Standard_Duration then
10031                Conv := New_Reference_To (Delay_Min, Loc);
10032
10033             elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
10034                Conv := Make_Function_Call (Loc,
10035                  New_Reference_To (RTE (RO_CA_To_Duration), Loc),
10036                  New_List (New_Reference_To (Delay_Min, Loc)));
10037
10038             else
10039                pragma Assert
10040                  (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
10041
10042                Conv := Make_Function_Call (Loc,
10043                  New_Reference_To (RTE (RO_RT_To_Duration), Loc),
10044                  New_List (New_Reference_To (Delay_Min, Loc)));
10045             end if;
10046
10047             Stmt := Make_Assignment_Statement (Loc,
10048               Name => New_Reference_To (D, Loc),
10049               Expression => Conv);
10050
10051             --  Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
10052
10053             Parms := Parameter_Associations (Select_Call);
10054             Parm := First (Parms);
10055
10056             while Present (Parm)
10057               and then Parm /= Select_Mode
10058             loop
10059                Next (Parm);
10060             end loop;
10061
10062             pragma Assert (Present (Parm));
10063             Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc));
10064             Analyze (Parm);
10065
10066             --  Prepare two new parameters of Duration and Delay_Mode type
10067             --  which represent the value and the mode of the minimum delay.
10068
10069             Next (Parm);
10070             Insert_After (Parm, New_Reference_To (M, Loc));
10071             Insert_After (Parm, New_Reference_To (D, Loc));
10072
10073             --  Create a call to RTS
10074
10075             Rewrite (Select_Call,
10076               Make_Procedure_Call_Statement (Loc,
10077                 Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc),
10078                 Parameter_Associations => Parms));
10079
10080             --  This new call should follow the calculation of the minimum
10081             --  delay.
10082
10083             Insert_List_Before (Select_Call, Delay_List);
10084
10085             if Check_Guard then
10086                Stmt :=
10087                  Make_Implicit_If_Statement (N,
10088                    Condition => New_Reference_To (Guard_Open, Loc),
10089                    Then_Statements =>
10090                      New_List (New_Copy_Tree (Stmt),
10091                        New_Copy_Tree (Select_Call)),
10092                    Else_Statements => Accept_Or_Raise);
10093                Rewrite (Select_Call, Stmt);
10094             else
10095                Insert_Before (Select_Call, Stmt);
10096             end if;
10097
10098             Cases :=
10099               Make_Implicit_If_Statement (N,
10100                 Condition => Make_Op_Eq (Loc,
10101                   Left_Opnd  => New_Reference_To (Xnam, Loc),
10102                   Right_Opnd =>
10103                     New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
10104
10105                 Then_Statements => Delay_Case,
10106                 Else_Statements => Accept_Case);
10107
10108             Append (Cases, Stats);
10109          end;
10110       end if;
10111
10112       --  Replace accept statement with appropriate block
10113
10114       Block :=
10115         Make_Block_Statement (Loc,
10116           Declarations => Decls,
10117           Handled_Statement_Sequence =>
10118             Make_Handled_Sequence_Of_Statements (Loc,
10119               Statements => Stats));
10120
10121       Rewrite (N, Block);
10122       Analyze (N);
10123
10124       --  Note: have to worry more about abort deferral in above code ???
10125
10126       --  Final step is to unstack the Accept_Address entries for all accept
10127       --  statements appearing in accept alternatives in the select statement
10128
10129       Alt := First (Alts);
10130       while Present (Alt) loop
10131          if Nkind (Alt) = N_Accept_Alternative then
10132             Remove_Last_Elmt (Accept_Address
10133               (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
10134          end if;
10135
10136          Next (Alt);
10137       end loop;
10138    end Expand_N_Selective_Accept;
10139
10140    --------------------------------------
10141    -- Expand_N_Single_Task_Declaration --
10142    --------------------------------------
10143
10144    --  Single task declarations should never be present after semantic
10145    --  analysis, since we expect them to be replaced by a declaration of an
10146    --  anonymous task type, followed by a declaration of the task object. We
10147    --  include this routine to make sure that is happening!
10148
10149    procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
10150    begin
10151       raise Program_Error;
10152    end Expand_N_Single_Task_Declaration;
10153
10154    ------------------------
10155    -- Expand_N_Task_Body --
10156    ------------------------
10157
10158    --  Given a task body
10159
10160    --    task body tname is
10161    --       <declarations>
10162    --    begin
10163    --       <statements>
10164    --    end x;
10165
10166    --  This expansion routine converts it into a procedure and sets the
10167    --  elaboration flag for the procedure to true, to represent the fact
10168    --  that the task body is now elaborated:
10169
10170    --    procedure tnameB (_Task : access tnameV) is
10171    --       discriminal : dtype renames _Task.discriminant;
10172
10173    --       procedure _clean is
10174    --       begin
10175    --          Abort_Defer.all;
10176    --          Complete_Task;
10177    --          Abort_Undefer.all;
10178    --          return;
10179    --       end _clean;
10180
10181    --    begin
10182    --       Abort_Undefer.all;
10183    --       <declarations>
10184    --       System.Task_Stages.Complete_Activation;
10185    --       <statements>
10186    --    at end
10187    --       _clean;
10188    --    end tnameB;
10189
10190    --    tnameE := True;
10191
10192    --  In addition, if the task body is an activator, then a call to activate
10193    --  tasks is added at the start of the statements, before the call to
10194    --  Complete_Activation, and if in addition the task is a master then it
10195    --  must be established as a master. These calls are inserted and analyzed
10196    --  in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
10197    --  expanded.
10198
10199    --  There is one discriminal declaration line generated for each
10200    --  discriminant that is present to provide an easy reference point for
10201    --  discriminant references inside the body (see Exp_Ch2.Expand_Name).
10202
10203    --  Note on relationship to GNARLI definition. In the GNARLI definition,
10204    --  task body procedures have a profile (Arg : System.Address). That is
10205    --  needed because GNARLI has to use the same access-to-subprogram type
10206    --  for all task types. We depend here on knowing that in GNAT, passing
10207    --  an address argument by value is identical to passing a record value
10208    --  by access (in either case a single pointer is passed), so even though
10209    --  this procedure has the wrong profile. In fact it's all OK, since the
10210    --  callings sequence is identical.
10211
10212    procedure Expand_N_Task_Body (N : Node_Id) is
10213       Loc   : constant Source_Ptr := Sloc (N);
10214       Ttyp  : constant Entity_Id  := Corresponding_Spec (N);
10215       Call  : Node_Id;
10216       New_N : Node_Id;
10217
10218       Insert_Nod : Node_Id;
10219       --  Used to determine the proper location of wrapper body insertions
10220
10221    begin
10222       --  Add renaming declarations for discriminals and a declaration for the
10223       --  entry family index (if applicable).
10224
10225       Install_Private_Data_Declarations
10226         (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N));
10227
10228       --  Add a call to Abort_Undefer at the very beginning of the task
10229       --  body since this body is called with abort still deferred.
10230
10231       if Abort_Allowed then
10232          Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
10233          Insert_Before
10234            (First (Statements (Handled_Statement_Sequence (N))), Call);
10235          Analyze (Call);
10236       end if;
10237
10238       --  The statement part has already been protected with an at_end and
10239       --  cleanup actions. The call to Complete_Activation must be placed
10240       --  at the head of the sequence of statements of that block. The
10241       --  declarations have been merged in this sequence of statements but
10242       --  the first real statement is accessible from the First_Real_Statement
10243       --  field (which was set for exactly this purpose).
10244
10245       if Restricted_Profile then
10246          Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
10247       else
10248          Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
10249       end if;
10250
10251       Insert_Before
10252         (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
10253       Analyze (Call);
10254
10255       New_N :=
10256         Make_Subprogram_Body (Loc,
10257           Specification              => Build_Task_Proc_Specification (Ttyp),
10258           Declarations               => Declarations (N),
10259           Handled_Statement_Sequence => Handled_Statement_Sequence (N));
10260
10261       --  If the task contains generic instantiations, cleanup actions are
10262       --  delayed until after instantiation. Transfer the activation chain to
10263       --  the subprogram, to insure that the activation call is properly
10264       --  generated. It the task body contains inner tasks, indicate that the
10265       --  subprogram is a task master.
10266
10267       if Delay_Cleanups (Ttyp) then
10268          Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
10269          Set_Is_Task_Master  (New_N, Is_Task_Master (N));
10270       end if;
10271
10272       Rewrite (N, New_N);
10273       Analyze (N);
10274
10275       --  Set elaboration flag immediately after task body. If the body is a
10276       --  subunit, the flag is set in the declarative part containing the stub.
10277
10278       if Nkind (Parent (N)) /= N_Subunit then
10279          Insert_After (N,
10280            Make_Assignment_Statement (Loc,
10281              Name =>
10282                Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
10283              Expression => New_Reference_To (Standard_True, Loc)));
10284       end if;
10285
10286       --  Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
10287       --  the task body. At this point all wrapper specs have been created,
10288       --  frozen and included in the dispatch table for the task type.
10289
10290       if Ada_Version >= Ada_2005 then
10291          if Nkind (Parent (N)) = N_Subunit then
10292             Insert_Nod := Corresponding_Stub (Parent (N));
10293          else
10294             Insert_Nod := N;
10295          end if;
10296
10297          Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
10298       end if;
10299    end Expand_N_Task_Body;
10300
10301    ------------------------------------
10302    -- Expand_N_Task_Type_Declaration --
10303    ------------------------------------
10304
10305    --  We have several things to do. First we must create a Boolean flag used
10306    --  to mark if the body is elaborated yet. This variable gets set to True
10307    --  when the body of the task is elaborated (we can't rely on the normal
10308    --  ABE mechanism for the task body, since we need to pass an access to
10309    --  this elaboration boolean to the runtime routines).
10310
10311    --    taskE : aliased Boolean := False;
10312
10313    --  Next a variable is declared to hold the task stack size (either the
10314    --  default : Unspecified_Size, or a value that is set by a pragma
10315    --  Storage_Size). If the value of the pragma Storage_Size is static, then
10316    --  the variable is initialized with this value:
10317
10318    --    taskZ : Size_Type := Unspecified_Size;
10319    --  or
10320    --    taskZ : Size_Type := Size_Type (size_expression);
10321
10322    --  Note: No variable is needed to hold the task relative deadline since
10323    --  its value would never be static because the parameter is of a private
10324    --  type (Ada.Real_Time.Time_Span).
10325
10326    --  Next we create a corresponding record type declaration used to represent
10327    --  values of this task. The general form of this type declaration is
10328
10329    --    type taskV (discriminants) is record
10330    --      _Task_Id     : Task_Id;
10331    --      entry_family : array (bounds) of Void;
10332    --      _Priority    : Integer         := priority_expression;
10333    --      _Size        : Size_Type       := Size_Type (size_expression);
10334    --      _Task_Info   : Task_Info_Type  := task_info_expression;
10335    --      _CPU         : Integer         := cpu_range_expression;
10336    --    end record;
10337
10338    --  The discriminants are present only if the corresponding task type has
10339    --  discriminants, and they exactly mirror the task type discriminants.
10340
10341    --  The Id field is always present. It contains the Task_Id value, as set by
10342    --  the call to Create_Task. Note that although the task is limited, the
10343    --  task value record type is not limited, so there is no problem in passing
10344    --  this field as an out parameter to Create_Task.
10345
10346    --  One entry_family component is present for each entry family in the task
10347    --  definition. The bounds correspond to the bounds of the entry family
10348    --  (which may depend on discriminants). The element type is void, since we
10349    --  only need the bounds information for determining the entry index. Note
10350    --  that the use of an anonymous array would normally be illegal in this
10351    --  context, but this is a parser check, and the semantics is quite prepared
10352    --  to handle such a case.
10353
10354    --  The _Size field is present only if a Storage_Size pragma appears in the
10355    --  task definition. The expression captures the argument that was present
10356    --  in the pragma, and is used to override the task stack size otherwise
10357    --  associated with the task type.
10358
10359    --  The _Priority field is present only if a Priority or Interrupt_Priority
10360    --  pragma appears in the task definition. The expression captures the
10361    --  argument that was present in the pragma, and is used to provide the Size
10362    --  parameter to the call to Create_Task.
10363
10364    --  The _Task_Info field is present only if a Task_Info pragma appears in
10365    --  the task definition. The expression captures the argument that was
10366    --  present in the pragma, and is used to provide the Task_Image parameter
10367    --  to the call to Create_Task.
10368
10369    --  The _CPU field is present only if a CPU pragma appears in the task
10370    --  definition. The expression captures the argument that was present in
10371    --  the pragma, and is used to provide the CPU parameter to the call to
10372    --  Create_Task.
10373
10374    --  The _Relative_Deadline field is present only if a Relative_Deadline
10375    --  pragma appears in the task definition. The expression captures the
10376    --  argument that was present in the pragma, and is used to provide the
10377    --  Relative_Deadline parameter to the call to Create_Task.
10378
10379    --  When a task is declared, an instance of the task value record is
10380    --  created. The elaboration of this declaration creates the correct bounds
10381    --  for the entry families, and also evaluates the size, priority, and
10382    --  task_Info expressions if needed. The initialization routine for the task
10383    --  type itself then calls Create_Task with appropriate parameters to
10384    --  initialize the value of the Task_Id field.
10385
10386    --  Note: the address of this record is passed as the "Discriminants"
10387    --  parameter for Create_Task. Since Create_Task merely passes this onto the
10388    --  body procedure, it does not matter that it does not quite match the
10389    --  GNARLI model of what is being passed (the record contains more than just
10390    --  the discriminants, but the discriminants can be found from the record
10391    --  value).
10392
10393    --  The Entity_Id for this created record type is placed in the
10394    --  Corresponding_Record_Type field of the associated task type entity.
10395
10396    --  Next we create a procedure specification for the task body procedure:
10397
10398    --    procedure taskB (_Task : access taskV);
10399
10400    --  Note that this must come after the record type declaration, since
10401    --  the spec refers to this type. It turns out that the initialization
10402    --  procedure for the value type references the task body spec, but that's
10403    --  fine, since it won't be generated till the freeze point for the type,
10404    --  which is certainly after the task body spec declaration.
10405
10406    --  Finally, we set the task index value field of the entry attribute in
10407    --  the case of a simple entry.
10408
10409    procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
10410       Loc     : constant Source_Ptr := Sloc (N);
10411       Tasktyp : constant Entity_Id  := Etype (Defining_Identifier (N));
10412       Tasknm  : constant Name_Id    := Chars (Tasktyp);
10413       Taskdef : constant Node_Id    := Task_Definition (N);
10414
10415       Proc_Spec  : Node_Id;
10416       Rec_Decl   : Node_Id;
10417       Rec_Ent    : Entity_Id;
10418       Cdecls     : List_Id;
10419       Elab_Decl  : Node_Id;
10420       Size_Decl  : Node_Id;
10421       Body_Decl  : Node_Id;
10422       Task_Size  : Node_Id;
10423       Ent_Stack  : Entity_Id;
10424       Decl_Stack : Node_Id;
10425
10426    begin
10427       --  If already expanded, nothing to do
10428
10429       if Present (Corresponding_Record_Type (Tasktyp)) then
10430          return;
10431       end if;
10432
10433       --  Here we will do the expansion
10434
10435       Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
10436
10437       Rec_Ent  := Defining_Identifier (Rec_Decl);
10438       Cdecls   := Component_Items (Component_List
10439                                      (Type_Definition (Rec_Decl)));
10440
10441       Qualify_Entity_Names (N);
10442
10443       --  First create the elaboration variable
10444
10445       Elab_Decl :=
10446         Make_Object_Declaration (Loc,
10447           Defining_Identifier =>
10448             Make_Defining_Identifier (Sloc (Tasktyp),
10449               Chars => New_External_Name (Tasknm, 'E')),
10450           Aliased_Present      => True,
10451           Object_Definition    => New_Reference_To (Standard_Boolean, Loc),
10452           Expression           => New_Reference_To (Standard_False, Loc));
10453       Insert_After (N, Elab_Decl);
10454
10455       --  Next create the declaration of the size variable (tasknmZ)
10456
10457       Set_Storage_Size_Variable (Tasktyp,
10458         Make_Defining_Identifier (Sloc (Tasktyp),
10459           Chars => New_External_Name (Tasknm, 'Z')));
10460
10461       if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then
10462         Is_Static_Expression (Expression (First (
10463           Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma (
10464             Taskdef, Name_Storage_Size)))))
10465       then
10466          Size_Decl :=
10467            Make_Object_Declaration (Loc,
10468              Defining_Identifier => Storage_Size_Variable (Tasktyp),
10469              Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
10470              Expression =>
10471                Convert_To (RTE (RE_Size_Type),
10472                  Relocate_Node (
10473                    Expression (First (
10474                      Pragma_Argument_Associations (
10475                        Find_Task_Or_Protected_Pragma
10476                          (Taskdef, Name_Storage_Size)))))));
10477
10478       else
10479          Size_Decl :=
10480            Make_Object_Declaration (Loc,
10481              Defining_Identifier => Storage_Size_Variable (Tasktyp),
10482              Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
10483              Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc));
10484       end if;
10485
10486       Insert_After (Elab_Decl, Size_Decl);
10487
10488       --  Next build the rest of the corresponding record declaration. This is
10489       --  done last, since the corresponding record initialization procedure
10490       --  will reference the previously created entities.
10491
10492       --  Fill in the component declarations -- first the _Task_Id field
10493
10494       Append_To (Cdecls,
10495         Make_Component_Declaration (Loc,
10496           Defining_Identifier =>
10497             Make_Defining_Identifier (Loc, Name_uTask_Id),
10498           Component_Definition =>
10499             Make_Component_Definition (Loc,
10500               Aliased_Present    => False,
10501               Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id),
10502                                     Loc))));
10503
10504       --  Declare static ATCB (that is, created by the expander) if we are
10505       --  using the Restricted run time.
10506
10507       if Restricted_Profile then
10508          Append_To (Cdecls,
10509            Make_Component_Declaration (Loc,
10510              Defining_Identifier  =>
10511                Make_Defining_Identifier (Loc, Name_uATCB),
10512
10513              Component_Definition =>
10514                Make_Component_Definition (Loc,
10515                  Aliased_Present     => True,
10516                  Subtype_Indication  => Make_Subtype_Indication (Loc,
10517                    Subtype_Mark => New_Occurrence_Of
10518                      (RTE (RE_Ada_Task_Control_Block), Loc),
10519
10520                    Constraint   =>
10521                      Make_Index_Or_Discriminant_Constraint (Loc,
10522                        Constraints =>
10523                          New_List (Make_Integer_Literal (Loc, 0)))))));
10524
10525       end if;
10526
10527       --  Declare static stack (that is, created by the expander) if we are
10528       --  using the Restricted run time on a bare board configuration.
10529
10530       if Restricted_Profile
10531         and then Preallocated_Stacks_On_Target
10532       then
10533          --  First we need to extract the appropriate stack size
10534
10535          Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
10536
10537          if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
10538             declare
10539                Expr_N : constant Node_Id :=
10540                           Expression (First (
10541                             Pragma_Argument_Associations (
10542                               Find_Task_Or_Protected_Pragma
10543                                 (Taskdef, Name_Storage_Size))));
10544                Etyp   : constant Entity_Id := Etype (Expr_N);
10545                P      : constant Node_Id   := Parent (Expr_N);
10546
10547             begin
10548                --  The stack is defined inside the corresponding record.
10549                --  Therefore if the size of the stack is set by means of
10550                --  a discriminant, we must reference the discriminant of the
10551                --  corresponding record type.
10552
10553                if Nkind (Expr_N) in N_Has_Entity
10554                  and then Present (Discriminal_Link (Entity (Expr_N)))
10555                then
10556                   Task_Size :=
10557                     New_Reference_To
10558                       (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
10559                        Loc);
10560                   Set_Parent   (Task_Size, P);
10561                   Set_Etype    (Task_Size, Etyp);
10562                   Set_Analyzed (Task_Size);
10563
10564                else
10565                   Task_Size := Relocate_Node (Expr_N);
10566                end if;
10567             end;
10568
10569          else
10570             Task_Size :=
10571               New_Reference_To (RTE (RE_Default_Stack_Size), Loc);
10572          end if;
10573
10574          Decl_Stack := Make_Component_Declaration (Loc,
10575            Defining_Identifier  => Ent_Stack,
10576
10577            Component_Definition =>
10578              Make_Component_Definition (Loc,
10579                Aliased_Present     => True,
10580                Subtype_Indication  => Make_Subtype_Indication (Loc,
10581                  Subtype_Mark =>
10582                    New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
10583
10584                  Constraint   =>
10585                    Make_Index_Or_Discriminant_Constraint (Loc,
10586                      Constraints  => New_List (Make_Range (Loc,
10587                        Low_Bound  => Make_Integer_Literal (Loc, 1),
10588                        High_Bound => Convert_To (RTE (RE_Storage_Offset),
10589                          Task_Size)))))));
10590
10591          Append_To (Cdecls, Decl_Stack);
10592
10593          --  The appropriate alignment for the stack is ensured by the run-time
10594          --  code in charge of task creation.
10595
10596       end if;
10597
10598       --  Add components for entry families
10599
10600       Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
10601
10602       --  Add the _Priority component if a Priority pragma is present
10603
10604       if Present (Taskdef) and then Has_Pragma_Priority (Taskdef) then
10605          declare
10606             Prag : constant Node_Id :=
10607                      Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
10608             Expr : Node_Id;
10609
10610          begin
10611             Expr := First (Pragma_Argument_Associations (Prag));
10612
10613             if Nkind (Expr) = N_Pragma_Argument_Association then
10614                Expr := Expression (Expr);
10615             end if;
10616
10617             Expr := New_Copy_Tree (Expr);
10618
10619             --  Add conversion to proper type to do range check if required
10620             --  Note that for runtime units, we allow out of range interrupt
10621             --  priority values to be used in a priority pragma. This is for
10622             --  the benefit of some versions of System.Interrupts which use
10623             --  a special server task with maximum interrupt priority.
10624
10625             if Pragma_Name (Prag) = Name_Priority
10626               and then not GNAT_Mode
10627             then
10628                Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
10629             else
10630                Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
10631             end if;
10632
10633             Append_To (Cdecls,
10634               Make_Component_Declaration (Loc,
10635                 Defining_Identifier =>
10636                   Make_Defining_Identifier (Loc, Name_uPriority),
10637                 Component_Definition =>
10638                   Make_Component_Definition (Loc,
10639                     Aliased_Present    => False,
10640                     Subtype_Indication => New_Reference_To (Standard_Integer,
10641                                                             Loc)),
10642                 Expression => Expr));
10643          end;
10644       end if;
10645
10646       --  Add the _Task_Size component if a Storage_Size pragma is present
10647
10648       if Present (Taskdef)
10649         and then Has_Storage_Size_Pragma (Taskdef)
10650       then
10651          Append_To (Cdecls,
10652            Make_Component_Declaration (Loc,
10653              Defining_Identifier =>
10654                Make_Defining_Identifier (Loc, Name_uSize),
10655
10656              Component_Definition =>
10657                Make_Component_Definition (Loc,
10658                  Aliased_Present    => False,
10659                  Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
10660                                                          Loc)),
10661
10662              Expression =>
10663                Convert_To (RTE (RE_Size_Type),
10664                  Relocate_Node (
10665                    Expression (First (
10666                      Pragma_Argument_Associations (
10667                        Find_Task_Or_Protected_Pragma
10668                          (Taskdef, Name_Storage_Size))))))));
10669       end if;
10670
10671       --  Add the _Task_Info component if a Task_Info pragma is present
10672
10673       if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then
10674          Append_To (Cdecls,
10675            Make_Component_Declaration (Loc,
10676              Defining_Identifier =>
10677                Make_Defining_Identifier (Loc, Name_uTask_Info),
10678
10679              Component_Definition =>
10680                Make_Component_Definition (Loc,
10681                  Aliased_Present    => False,
10682                  Subtype_Indication =>
10683                    New_Reference_To (RTE (RE_Task_Info_Type), Loc)),
10684
10685              Expression => New_Copy (
10686                Expression (First (
10687                  Pragma_Argument_Associations (
10688                    Find_Task_Or_Protected_Pragma
10689                      (Taskdef, Name_Task_Info)))))));
10690       end if;
10691
10692       --  Add the _CPU component if a CPU pragma is present
10693
10694       if Present (Taskdef) and then Has_Pragma_CPU (Taskdef) then
10695          Append_To (Cdecls,
10696            Make_Component_Declaration (Loc,
10697              Defining_Identifier =>
10698                Make_Defining_Identifier (Loc, Name_uCPU),
10699
10700              Component_Definition =>
10701                Make_Component_Definition (Loc,
10702                  Aliased_Present    => False,
10703                  Subtype_Indication =>
10704                    New_Reference_To (RTE (RE_CPU_Range), Loc)),
10705
10706              Expression => New_Copy (
10707                Expression (First (
10708                  Pragma_Argument_Associations (
10709                    Find_Task_Or_Protected_Pragma
10710                      (Taskdef, Name_CPU)))))));
10711       end if;
10712
10713       --  Add the _Relative_Deadline component if a Relative_Deadline pragma is
10714       --  present. If we are using a restricted run time this component will
10715       --  not be added (deadlines are not allowed by the Ravenscar profile).
10716
10717       if not Restricted_Profile
10718         and then Present (Taskdef)
10719         and then Has_Relative_Deadline_Pragma (Taskdef)
10720       then
10721          Append_To (Cdecls,
10722            Make_Component_Declaration (Loc,
10723              Defining_Identifier =>
10724                Make_Defining_Identifier (Loc, Name_uRelative_Deadline),
10725
10726              Component_Definition =>
10727                Make_Component_Definition (Loc,
10728                  Aliased_Present    => False,
10729                  Subtype_Indication =>
10730                    New_Reference_To (RTE (RE_Time_Span), Loc)),
10731
10732              Expression =>
10733                Convert_To (RTE (RE_Time_Span),
10734                  Relocate_Node (
10735                    Expression (First (
10736                      Pragma_Argument_Associations (
10737                        Find_Task_Or_Protected_Pragma
10738                          (Taskdef, Name_Relative_Deadline))))))));
10739       end if;
10740
10741       Insert_After (Size_Decl, Rec_Decl);
10742
10743       --  Analyze the record declaration immediately after construction,
10744       --  because the initialization procedure is needed for single task
10745       --  declarations before the next entity is analyzed.
10746
10747       Analyze (Rec_Decl);
10748
10749       --  Create the declaration of the task body procedure
10750
10751       Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
10752       Body_Decl :=
10753         Make_Subprogram_Declaration (Loc,
10754           Specification => Proc_Spec);
10755
10756       Insert_After (Rec_Decl, Body_Decl);
10757
10758       --  The subprogram does not comes from source, so we have to indicate the
10759       --  need for debugging information explicitly.
10760
10761       if Comes_From_Source (Original_Node (N)) then
10762          Set_Debug_Info_Needed (Defining_Entity (Proc_Spec));
10763       end if;
10764
10765       --  Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
10766       --  the corresponding record has been frozen.
10767
10768       if Ada_Version >= Ada_2005 then
10769          Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
10770       end if;
10771
10772       --  Ada 2005 (AI-345): We must defer freezing to allow further
10773       --  declaration of primitive subprograms covering task interfaces
10774
10775       if Ada_Version <= Ada_95 then
10776
10777          --  Now we can freeze the corresponding record. This needs manually
10778          --  freezing, since it is really part of the task type, and the task
10779          --  type is frozen at this stage. We of course need the initialization
10780          --  procedure for this corresponding record type and we won't get it
10781          --  in time if we don't freeze now.
10782
10783          declare
10784             L : constant List_Id := Freeze_Entity (Rec_Ent, N);
10785          begin
10786             if Is_Non_Empty_List (L) then
10787                Insert_List_After (Body_Decl, L);
10788             end if;
10789          end;
10790       end if;
10791
10792       --  Complete the expansion of access types to the current task type, if
10793       --  any were declared.
10794
10795       Expand_Previous_Access_Type (Tasktyp);
10796
10797       --  Create wrappers for entries that have pre/postconditions
10798
10799       declare
10800          Ent : Entity_Id;
10801
10802       begin
10803          Ent := First_Entity (Tasktyp);
10804          while Present (Ent) loop
10805             if Ekind_In (Ent, E_Entry, E_Entry_Family)
10806               and then Present (Spec_PPC_List (Ent))
10807             then
10808                Build_PPC_Wrapper (Ent, N);
10809             end if;
10810
10811             Next_Entity (Ent);
10812          end loop;
10813       end;
10814    end Expand_N_Task_Type_Declaration;
10815
10816    -------------------------------
10817    -- Expand_N_Timed_Entry_Call --
10818    -------------------------------
10819
10820    --  A timed entry call in normal case is not implemented using ATC mechanism
10821    --  anymore for efficiency reason.
10822
10823    --     select
10824    --        T.E;
10825    --        S1;
10826    --     or
10827    --        Delay D;
10828    --        S2;
10829    --     end select;
10830
10831    --  is expanded as follow:
10832
10833    --  1) When T.E is a task entry_call;
10834
10835    --    declare
10836    --       B  : Boolean;
10837    --       X  : Task_Entry_Index := <entry index>;
10838    --       DX : Duration := To_Duration (D);
10839    --       M  : Delay_Mode := <discriminant>;
10840    --       P  : parms := (parm, parm, parm);
10841
10842    --    begin
10843    --       Timed_Protected_Entry_Call
10844    --         (<acceptor-task>, X, P'Address, DX, M, B);
10845    --       if B then
10846    --          S1;
10847    --       else
10848    --          S2;
10849    --       end if;
10850    --    end;
10851
10852    --  2) When T.E is a protected entry_call;
10853
10854    --    declare
10855    --       B  : Boolean;
10856    --       X  : Protected_Entry_Index := <entry index>;
10857    --       DX : Duration := To_Duration (D);
10858    --       M  : Delay_Mode := <discriminant>;
10859    --       P  : parms := (parm, parm, parm);
10860
10861    --    begin
10862    --       Timed_Protected_Entry_Call
10863    --         (<object>'unchecked_access, X, P'Address, DX, M, B);
10864    --       if B then
10865    --          S1;
10866    --       else
10867    --          S2;
10868    --       end if;
10869    --    end;
10870
10871    --  3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
10872
10873    --    declare
10874    --       B  : Boolean := False;
10875    --       C  : Ada.Tags.Prim_Op_Kind;
10876    --       DX : Duration := To_Duration (D)
10877    --       K  : Ada.Tags.Tagged_Kind :=
10878    --              Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
10879    --       M  : Integer :=...;
10880    --       P  : Parameters := (Param1 .. ParamN);
10881    --       S  : Iteger;
10882
10883    --    begin
10884    --       if K = Ada.Tags.TK_Limited_Tagged then
10885    --          <dispatching-call>;
10886    --          <triggering-statements>
10887
10888    --       else
10889    --          S :=
10890    --            Ada.Tags.Get_Offset_Index
10891    --              (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
10892
10893    --          _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
10894
10895    --          if C = POK_Protected_Entry
10896    --            or else C = POK_Task_Entry
10897    --          then
10898    --             Param1 := P.Param1;
10899    --             ...
10900    --             ParamN := P.ParamN;
10901    --          end if;
10902
10903    --          if B then
10904    --             if C = POK_Procedure
10905    --               or else C = POK_Protected_Procedure
10906    --               or else C = POK_Task_Procedure
10907    --             then
10908    --                <dispatching-call>;
10909    --             end if;
10910
10911    --             <triggering-statements>
10912    --          else
10913    --             <timed-statements>
10914    --          end if;
10915    --       end if;
10916    --    end;
10917
10918    procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
10919       Loc : constant Source_Ptr := Sloc (N);
10920
10921       E_Call  : Node_Id :=
10922                   Entry_Call_Statement (Entry_Call_Alternative (N));
10923       E_Stats : constant List_Id :=
10924                   Statements (Entry_Call_Alternative (N));
10925       D_Stat  : Node_Id :=
10926                   Delay_Statement (Delay_Alternative (N));
10927       D_Stats : constant List_Id :=
10928                   Statements (Delay_Alternative (N));
10929
10930       Actuals        : List_Id;
10931       Blk_Typ        : Entity_Id;
10932       Call           : Node_Id;
10933       Call_Ent       : Entity_Id;
10934       Conc_Typ_Stmts : List_Id;
10935       Concval        : Node_Id;
10936       D_Conv         : Node_Id;
10937       D_Disc         : Node_Id;
10938       D_Type         : Entity_Id;
10939       Decls          : List_Id;
10940       Dummy          : Node_Id;
10941       Ename          : Node_Id;
10942       Formals        : List_Id;
10943       Index          : Node_Id;
10944       Is_Disp_Select : Boolean;
10945       Lim_Typ_Stmts  : List_Id;
10946       N_Stats        : List_Id;
10947       Obj            : Entity_Id;
10948       Param          : Node_Id;
10949       Params         : List_Id;
10950       Stmt           : Node_Id;
10951       Stmts          : List_Id;
10952       Unpack         : List_Id;
10953
10954       B : Entity_Id;  --  Call status flag
10955       C : Entity_Id;  --  Call kind
10956       D : Entity_Id;  --  Delay
10957       K : Entity_Id;  --  Tagged kind
10958       M : Entity_Id;  --  Delay mode
10959       P : Entity_Id;  --  Parameter block
10960       S : Entity_Id;  --  Primitive operation slot
10961
10962    begin
10963       --  Under the Ravenscar profile, timed entry calls are excluded. An error
10964       --  was already reported on spec, so do not attempt to expand the call.
10965
10966       if Restriction_Active (No_Select_Statements) then
10967          return;
10968       end if;
10969
10970       --  The arguments in the call may require dynamic allocation, and the
10971       --  call statement may have been transformed into a block. The block
10972       --  may contain additional declarations for internal entities, and the
10973       --  original call is found by sequential search.
10974
10975       if Nkind (E_Call) = N_Block_Statement then
10976          E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
10977          while not Nkind_In (E_Call, N_Procedure_Call_Statement,
10978                                      N_Entry_Call_Statement)
10979          loop
10980             Next (E_Call);
10981          end loop;
10982       end if;
10983
10984       Is_Disp_Select :=
10985         Ada_Version >= Ada_2005
10986           and then Nkind (E_Call) = N_Procedure_Call_Statement;
10987
10988       if Is_Disp_Select then
10989          Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
10990
10991          Decls := New_List;
10992          Stmts := New_List;
10993
10994          --  Generate:
10995          --    B : Boolean := False;
10996
10997          B := Build_B (Loc, Decls);
10998
10999          --  Generate:
11000          --    C : Ada.Tags.Prim_Op_Kind;
11001
11002          C := Build_C (Loc, Decls);
11003
11004          --  Because the analysis of all statements was disabled, manually
11005          --  analyze the delay statement.
11006
11007          Analyze (D_Stat);
11008          D_Stat := Original_Node (D_Stat);
11009
11010       else
11011          --  Build an entry call using Simple_Entry_Call
11012
11013          Extract_Entry (E_Call, Concval, Ename, Index);
11014          Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
11015
11016          Decls := Declarations (E_Call);
11017          Stmts := Statements (Handled_Statement_Sequence (E_Call));
11018
11019          if No (Decls) then
11020             Decls := New_List;
11021          end if;
11022
11023          --  Generate:
11024          --    B : Boolean;
11025
11026          B := Make_Defining_Identifier (Loc, Name_uB);
11027
11028          Prepend_To (Decls,
11029            Make_Object_Declaration (Loc,
11030              Defining_Identifier =>
11031                B,
11032              Object_Definition =>
11033                New_Reference_To (Standard_Boolean, Loc)));
11034       end if;
11035
11036       --  Duration and mode processing
11037
11038       D_Type := Base_Type (Etype (Expression (D_Stat)));
11039
11040       --  Use the type of the delay expression (Calendar or Real_Time) to
11041       --  generate the appropriate conversion.
11042
11043       if Nkind (D_Stat) = N_Delay_Relative_Statement then
11044          D_Disc := Make_Integer_Literal (Loc, 0);
11045          D_Conv := Relocate_Node (Expression (D_Stat));
11046
11047       elsif Is_RTE (D_Type, RO_CA_Time) then
11048          D_Disc := Make_Integer_Literal (Loc, 1);
11049          D_Conv := Make_Function_Call (Loc,
11050            New_Reference_To (RTE (RO_CA_To_Duration), Loc),
11051            New_List (New_Copy (Expression (D_Stat))));
11052
11053       else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
11054          D_Disc := Make_Integer_Literal (Loc, 2);
11055          D_Conv := Make_Function_Call (Loc,
11056            New_Reference_To (RTE (RO_RT_To_Duration), Loc),
11057            New_List (New_Copy (Expression (D_Stat))));
11058       end if;
11059
11060       D := Make_Temporary (Loc, 'D');
11061
11062       --  Generate:
11063       --    D : Duration;
11064
11065       Append_To (Decls,
11066         Make_Object_Declaration (Loc,
11067           Defining_Identifier =>
11068             D,
11069           Object_Definition =>
11070             New_Reference_To (Standard_Duration, Loc)));
11071
11072       M := Make_Temporary (Loc, 'M');
11073
11074       --  Generate:
11075       --    M : Integer := (0 | 1 | 2);
11076
11077       Append_To (Decls,
11078         Make_Object_Declaration (Loc,
11079           Defining_Identifier =>
11080             M,
11081           Object_Definition =>
11082             New_Reference_To (Standard_Integer, Loc),
11083           Expression =>
11084             D_Disc));
11085
11086       --  Do the assignment at this stage only because the evaluation of the
11087       --  expression must not occur before (see ACVC C97302A).
11088
11089       Append_To (Stmts,
11090         Make_Assignment_Statement (Loc,
11091           Name =>
11092             New_Reference_To (D, Loc),
11093           Expression =>
11094             D_Conv));
11095
11096       --  Parameter block processing
11097
11098       --  Manually create the parameter block for dispatching calls. In the
11099       --  case of entries, the block has already been created during the call
11100       --  to Build_Simple_Entry_Call.
11101
11102       if Is_Disp_Select then
11103
11104          --  Tagged kind processing, generate:
11105          --    K : Ada.Tags.Tagged_Kind :=
11106          --          Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
11107
11108          K := Build_K (Loc, Decls, Obj);
11109
11110          Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
11111          P := Parameter_Block_Pack
11112                 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
11113
11114          --  Dispatch table slot processing, generate:
11115          --    S : Integer;
11116
11117          S := Build_S (Loc, Decls);
11118
11119          --  Generate:
11120          --    S := Ada.Tags.Get_Offset_Index
11121          --           (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
11122
11123          Conc_Typ_Stmts :=
11124            New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
11125
11126          --  Generate:
11127          --    _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
11128
11129          --  where Obj is the controlling formal parameter, S is the dispatch
11130          --  table slot number of the dispatching operation, P is the wrapped
11131          --  parameter block, D is the duration, M is the duration mode, C is
11132          --  the call kind and B is the call status.
11133
11134          Params := New_List;
11135
11136          Append_To (Params, New_Copy_Tree (Obj));
11137          Append_To (Params, New_Reference_To (S, Loc));
11138          Append_To (Params, Make_Attribute_Reference (Loc,
11139                               Prefix => New_Reference_To (P, Loc),
11140                               Attribute_Name => Name_Address));
11141          Append_To (Params, New_Reference_To (D, Loc));
11142          Append_To (Params, New_Reference_To (M, Loc));
11143          Append_To (Params, New_Reference_To (C, Loc));
11144          Append_To (Params, New_Reference_To (B, Loc));
11145
11146          Append_To (Conc_Typ_Stmts,
11147            Make_Procedure_Call_Statement (Loc,
11148              Name =>
11149                New_Reference_To (
11150                  Find_Prim_Op (Etype (Etype (Obj)),
11151                    Name_uDisp_Timed_Select),
11152                  Loc),
11153              Parameter_Associations =>
11154                Params));
11155
11156          --  Generate:
11157          --    if C = POK_Protected_Entry
11158          --      or else C = POK_Task_Entry
11159          --    then
11160          --       Param1 := P.Param1;
11161          --       ...
11162          --       ParamN := P.ParamN;
11163          --    end if;
11164
11165          Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
11166
11167          --  Generate the if statement only when the packed parameters need
11168          --  explicit assignments to their corresponding actuals.
11169
11170          if Present (Unpack) then
11171             Append_To (Conc_Typ_Stmts,
11172               Make_If_Statement (Loc,
11173
11174                 Condition =>
11175                   Make_Or_Else (Loc,
11176                     Left_Opnd =>
11177                       Make_Op_Eq (Loc,
11178                         Left_Opnd =>
11179                           New_Reference_To (C, Loc),
11180                         Right_Opnd =>
11181                           New_Reference_To (RTE (
11182                             RE_POK_Protected_Entry), Loc)),
11183                     Right_Opnd =>
11184                       Make_Op_Eq (Loc,
11185                         Left_Opnd =>
11186                           New_Reference_To (C, Loc),
11187                         Right_Opnd =>
11188                           New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
11189
11190                 Then_Statements =>
11191                   Unpack));
11192          end if;
11193
11194          --  Generate:
11195
11196          --    if B then
11197          --       if C = POK_Procedure
11198          --         or else C = POK_Protected_Procedure
11199          --         or else C = POK_Task_Procedure
11200          --       then
11201          --          <dispatching-call>
11202          --       end if;
11203          --       <triggering-statements>
11204          --    else
11205          --       <timed-statements>
11206          --    end if;
11207
11208          N_Stats := New_Copy_List_Tree (E_Stats);
11209
11210          Prepend_To (N_Stats,
11211            Make_If_Statement (Loc,
11212
11213              Condition =>
11214                Make_Or_Else (Loc,
11215                  Left_Opnd =>
11216                    Make_Op_Eq (Loc,
11217                      Left_Opnd =>
11218                        New_Reference_To (C, Loc),
11219                      Right_Opnd =>
11220                        New_Reference_To (RTE (RE_POK_Procedure), Loc)),
11221                  Right_Opnd =>
11222                    Make_Or_Else (Loc,
11223                      Left_Opnd =>
11224                        Make_Op_Eq (Loc,
11225                          Left_Opnd =>
11226                            New_Reference_To (C, Loc),
11227                          Right_Opnd =>
11228                            New_Reference_To (RTE (
11229                              RE_POK_Protected_Procedure), Loc)),
11230                      Right_Opnd =>
11231                        Make_Op_Eq (Loc,
11232                          Left_Opnd =>
11233                            New_Reference_To (C, Loc),
11234                          Right_Opnd =>
11235                            New_Reference_To (RTE (
11236                              RE_POK_Task_Procedure), Loc)))),
11237
11238              Then_Statements =>
11239                New_List (E_Call)));
11240
11241          Append_To (Conc_Typ_Stmts,
11242            Make_If_Statement (Loc,
11243              Condition => New_Reference_To (B, Loc),
11244              Then_Statements => N_Stats,
11245              Else_Statements => D_Stats));
11246
11247          --  Generate:
11248          --    <dispatching-call>;
11249          --    <triggering-statements>
11250
11251          Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
11252          Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
11253
11254          --  Generate:
11255          --    if K = Ada.Tags.TK_Limited_Tagged then
11256          --       Lim_Typ_Stmts
11257          --    else
11258          --       Conc_Typ_Stmts
11259          --    end if;
11260
11261          Append_To (Stmts,
11262            Make_If_Statement (Loc,
11263              Condition =>
11264                Make_Op_Eq (Loc,
11265                  Left_Opnd =>
11266                    New_Reference_To (K, Loc),
11267                  Right_Opnd =>
11268                    New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
11269
11270              Then_Statements =>
11271                Lim_Typ_Stmts,
11272
11273              Else_Statements =>
11274                Conc_Typ_Stmts));
11275
11276       else
11277          --  Skip assignments to temporaries created for in-out parameters.
11278          --  This makes unwarranted assumptions about the shape of the expanded
11279          --  tree for the call, and should be cleaned up ???
11280
11281          Stmt := First (Stmts);
11282          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
11283             Next (Stmt);
11284          end loop;
11285
11286          --  Do the assignment at this stage only because the evaluation
11287          --  of the expression must not occur before (see ACVC C97302A).
11288
11289          Insert_Before (Stmt,
11290            Make_Assignment_Statement (Loc,
11291              Name => New_Reference_To (D, Loc),
11292              Expression => D_Conv));
11293
11294          Call   := Stmt;
11295          Params := Parameter_Associations (Call);
11296
11297          --  For a protected type, we build a Timed_Protected_Entry_Call
11298
11299          if Is_Protected_Type (Etype (Concval)) then
11300
11301             --  Create a new call statement
11302
11303             Param := First (Params);
11304             while Present (Param)
11305               and then not Is_RTE (Etype (Param), RE_Call_Modes)
11306             loop
11307                Next (Param);
11308             end loop;
11309
11310             Dummy := Remove_Next (Next (Param));
11311
11312             --  Remove garbage is following the Cancel_Param if present
11313
11314             Dummy := Next (Param);
11315
11316             --  Remove the mode of the Protected_Entry_Call call, then remove
11317             --  the Communication_Block of the Protected_Entry_Call call, and
11318             --  finally add Duration and a Delay_Mode parameter
11319
11320             pragma Assert (Present (Param));
11321             Rewrite (Param, New_Reference_To (D, Loc));
11322
11323             Rewrite (Dummy, New_Reference_To (M, Loc));
11324
11325             --  Add a Boolean flag for successful entry call
11326
11327             Append_To (Params, New_Reference_To (B, Loc));
11328
11329             case Corresponding_Runtime_Package (Etype (Concval)) is
11330                when System_Tasking_Protected_Objects_Entries =>
11331                   Rewrite (Call,
11332                     Make_Procedure_Call_Statement (Loc,
11333                       Name =>
11334                         New_Reference_To
11335                           (RTE (RE_Timed_Protected_Entry_Call), Loc),
11336                       Parameter_Associations => Params));
11337
11338                when System_Tasking_Protected_Objects_Single_Entry =>
11339                   Param := First (Params);
11340                   while Present (Param)
11341                     and then not
11342                       Is_RTE (Etype (Param), RE_Protected_Entry_Index)
11343                   loop
11344                      Next (Param);
11345                   end loop;
11346
11347                   Remove (Param);
11348
11349                   Rewrite (Call,
11350                     Make_Procedure_Call_Statement (Loc,
11351                       Name => New_Reference_To (
11352                         RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
11353                       Parameter_Associations => Params));
11354
11355                when others =>
11356                   raise Program_Error;
11357             end case;
11358
11359          --  For the task case, build a Timed_Task_Entry_Call
11360
11361          else
11362             --  Create a new call statement
11363
11364             Append_To (Params, New_Reference_To (D, Loc));
11365             Append_To (Params, New_Reference_To (M, Loc));
11366             Append_To (Params, New_Reference_To (B, Loc));
11367
11368             Rewrite (Call,
11369               Make_Procedure_Call_Statement (Loc,
11370                 Name =>
11371                   New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
11372                 Parameter_Associations => Params));
11373          end if;
11374
11375          Append_To (Stmts,
11376            Make_Implicit_If_Statement (N,
11377              Condition => New_Reference_To (B, Loc),
11378              Then_Statements => E_Stats,
11379              Else_Statements => D_Stats));
11380       end if;
11381
11382       Rewrite (N,
11383         Make_Block_Statement (Loc,
11384           Declarations => Decls,
11385           Handled_Statement_Sequence =>
11386             Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
11387
11388       Analyze (N);
11389    end Expand_N_Timed_Entry_Call;
11390
11391    ----------------------------------------
11392    -- Expand_Protected_Body_Declarations --
11393    ----------------------------------------
11394
11395    procedure Expand_Protected_Body_Declarations
11396      (N       : Node_Id;
11397       Spec_Id : Entity_Id)
11398    is
11399    begin
11400       if No_Run_Time_Mode then
11401          Error_Msg_CRT ("protected body", N);
11402          return;
11403
11404       elsif Expander_Active then
11405
11406          --  Associate discriminals with the first subprogram or entry body to
11407          --  be expanded.
11408
11409          if Present (First_Protected_Operation (Declarations (N))) then
11410             Set_Discriminals (Parent (Spec_Id));
11411          end if;
11412       end if;
11413    end Expand_Protected_Body_Declarations;
11414
11415    -------------------------
11416    -- External_Subprogram --
11417    -------------------------
11418
11419    function External_Subprogram (E : Entity_Id) return Entity_Id is
11420       Subp : constant Entity_Id := Protected_Body_Subprogram (E);
11421
11422    begin
11423       --  The internal and external subprograms follow each other on the entity
11424       --  chain. Note that previously private operations had no separate
11425       --  external subprogram. We now create one in all cases, because a
11426       --  private operation may actually appear in an external call, through
11427       --  a 'Access reference used for a callback.
11428
11429       --  If the operation is a function that returns an anonymous access type,
11430       --  the corresponding itype appears before the operation, and must be
11431       --  skipped.
11432
11433       --  This mechanism is fragile, there should be a real link between the
11434       --  two versions of the operation, but there is no place to put it ???
11435
11436       if Is_Access_Type (Next_Entity (Subp)) then
11437          return Next_Entity (Next_Entity (Subp));
11438       else
11439          return Next_Entity (Subp);
11440       end if;
11441    end External_Subprogram;
11442
11443    ------------------------------
11444    -- Extract_Dispatching_Call --
11445    ------------------------------
11446
11447    procedure Extract_Dispatching_Call
11448      (N        : Node_Id;
11449       Call_Ent : out Entity_Id;
11450       Object   : out Entity_Id;
11451       Actuals  : out List_Id;
11452       Formals  : out List_Id)
11453    is
11454       Call_Nam : Node_Id;
11455
11456    begin
11457       pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
11458
11459       if Present (Original_Node (N)) then
11460          Call_Nam := Name (Original_Node (N));
11461       else
11462          Call_Nam := Name (N);
11463       end if;
11464
11465       --  Retrieve the name of the dispatching procedure. It contains the
11466       --  dispatch table slot number.
11467
11468       loop
11469          case Nkind (Call_Nam) is
11470             when N_Identifier =>
11471                exit;
11472
11473             when N_Selected_Component =>
11474                Call_Nam := Selector_Name (Call_Nam);
11475
11476             when others =>
11477                raise Program_Error;
11478
11479          end case;
11480       end loop;
11481
11482       Actuals  := Parameter_Associations (N);
11483       Call_Ent := Entity (Call_Nam);
11484       Formals  := Parameter_Specifications (Parent (Call_Ent));
11485       Object   := First (Actuals);
11486
11487       if Present (Original_Node (Object)) then
11488          Object := Original_Node (Object);
11489       end if;
11490    end Extract_Dispatching_Call;
11491
11492    -------------------
11493    -- Extract_Entry --
11494    -------------------
11495
11496    procedure Extract_Entry
11497      (N       : Node_Id;
11498       Concval : out Node_Id;
11499       Ename   : out Node_Id;
11500       Index   : out Node_Id)
11501    is
11502       Nam : constant Node_Id := Name (N);
11503
11504    begin
11505       --  For a simple entry, the name is a selected component, with the
11506       --  prefix being the task value, and the selector being the entry.
11507
11508       if Nkind (Nam) = N_Selected_Component then
11509          Concval := Prefix (Nam);
11510          Ename   := Selector_Name (Nam);
11511          Index   := Empty;
11512
11513       --  For a member of an entry family, the name is an indexed component
11514       --  where the prefix is a selected component, whose prefix in turn is
11515       --  the task value, and whose selector is the entry family. The single
11516       --  expression in the expressions list of the indexed component is the
11517       --  subscript for the family.
11518
11519       else pragma Assert (Nkind (Nam) = N_Indexed_Component);
11520          Concval := Prefix (Prefix (Nam));
11521          Ename   := Selector_Name (Prefix (Nam));
11522          Index   := First (Expressions (Nam));
11523       end if;
11524    end Extract_Entry;
11525
11526    -------------------
11527    -- Family_Offset --
11528    -------------------
11529
11530    function Family_Offset
11531      (Loc  : Source_Ptr;
11532       Hi   : Node_Id;
11533       Lo   : Node_Id;
11534       Ttyp : Entity_Id;
11535       Cap  : Boolean) return Node_Id
11536    is
11537       Ityp : Entity_Id;
11538       Real_Hi : Node_Id;
11539       Real_Lo : Node_Id;
11540
11541       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
11542       --  If one of the bounds is a reference to a discriminant, replace with
11543       --  corresponding discriminal of type. Within the body of a task retrieve
11544       --  the renamed discriminant by simple visibility, using its generated
11545       --  name. Within a protected object, find the original discriminant and
11546       --  replace it with the discriminal of the current protected operation.
11547
11548       ------------------------------
11549       -- Convert_Discriminant_Ref --
11550       ------------------------------
11551
11552       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
11553          Loc : constant Source_Ptr := Sloc (Bound);
11554          B   : Node_Id;
11555          D   : Entity_Id;
11556
11557       begin
11558          if Is_Entity_Name (Bound)
11559            and then Ekind (Entity (Bound)) = E_Discriminant
11560          then
11561             if Is_Task_Type (Ttyp)
11562               and then Has_Completion (Ttyp)
11563             then
11564                B := Make_Identifier (Loc, Chars (Entity (Bound)));
11565                Find_Direct_Name (B);
11566
11567             elsif Is_Protected_Type (Ttyp) then
11568                D := First_Discriminant (Ttyp);
11569                while Chars (D) /= Chars (Entity (Bound)) loop
11570                   Next_Discriminant (D);
11571                end loop;
11572
11573                B := New_Reference_To  (Discriminal (D), Loc);
11574
11575             else
11576                B := New_Reference_To (Discriminal (Entity (Bound)), Loc);
11577             end if;
11578
11579          elsif Nkind (Bound) = N_Attribute_Reference then
11580             return Bound;
11581
11582          else
11583             B := New_Copy_Tree (Bound);
11584          end if;
11585
11586          return
11587            Make_Attribute_Reference (Loc,
11588              Attribute_Name => Name_Pos,
11589              Prefix => New_Occurrence_Of (Etype (Bound), Loc),
11590              Expressions    => New_List (B));
11591       end Convert_Discriminant_Ref;
11592
11593    --  Start of processing for Family_Offset
11594
11595    begin
11596       Real_Hi := Convert_Discriminant_Ref (Hi);
11597       Real_Lo := Convert_Discriminant_Ref (Lo);
11598
11599       if Cap then
11600          if Is_Task_Type (Ttyp) then
11601             Ityp := RTE (RE_Task_Entry_Index);
11602          else
11603             Ityp := RTE (RE_Protected_Entry_Index);
11604          end if;
11605
11606          Real_Hi :=
11607            Make_Attribute_Reference (Loc,
11608              Prefix         => New_Reference_To (Ityp, Loc),
11609              Attribute_Name => Name_Min,
11610              Expressions    => New_List (
11611                Real_Hi,
11612                Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
11613
11614          Real_Lo :=
11615            Make_Attribute_Reference (Loc,
11616              Prefix         => New_Reference_To (Ityp, Loc),
11617              Attribute_Name => Name_Max,
11618              Expressions    => New_List (
11619                Real_Lo,
11620                Make_Integer_Literal (Loc, -Entry_Family_Bound)));
11621       end if;
11622
11623       return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
11624    end Family_Offset;
11625
11626    -----------------
11627    -- Family_Size --
11628    -----------------
11629
11630    function Family_Size
11631      (Loc  : Source_Ptr;
11632       Hi   : Node_Id;
11633       Lo   : Node_Id;
11634       Ttyp : Entity_Id;
11635       Cap  : Boolean) return Node_Id
11636    is
11637       Ityp : Entity_Id;
11638
11639    begin
11640       if Is_Task_Type (Ttyp) then
11641          Ityp := RTE (RE_Task_Entry_Index);
11642       else
11643          Ityp := RTE (RE_Protected_Entry_Index);
11644       end if;
11645
11646       return
11647         Make_Attribute_Reference (Loc,
11648           Prefix         => New_Reference_To (Ityp, Loc),
11649           Attribute_Name => Name_Max,
11650           Expressions    => New_List (
11651             Make_Op_Add (Loc,
11652               Left_Opnd  =>
11653                 Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
11654               Right_Opnd =>
11655                 Make_Integer_Literal (Loc, 1)),
11656             Make_Integer_Literal (Loc, 0)));
11657    end Family_Size;
11658
11659    -----------------------
11660    -- Find_Master_Scope --
11661    -----------------------
11662
11663    function Find_Master_Scope (E : Entity_Id) return Entity_Id is
11664       S : Entity_Id;
11665
11666    begin
11667       --  In Ada2005, the master is the innermost enclosing scope that is not
11668       --  transient. If the enclosing block is the rewriting of a call or the
11669       --  scope is an extended return statement this is valid master. The
11670       --  master in an extended return is only used within the return, and is
11671       --  subsequently overwritten in Move_Activation_Chain, but it must exist
11672       --  now before that overwriting occurs.
11673
11674       S := Scope (E);
11675
11676       if Ada_Version >= Ada_2005 then
11677          while Is_Internal (S) loop
11678             if Nkind (Parent (S)) = N_Block_Statement
11679               and then
11680                 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
11681             then
11682                exit;
11683
11684             elsif Ekind (S) = E_Return_Statement then
11685                exit;
11686
11687             else
11688                S := Scope (S);
11689             end if;
11690          end loop;
11691       end if;
11692
11693       return S;
11694    end Find_Master_Scope;
11695
11696    -----------------------------------
11697    -- Find_Task_Or_Protected_Pragma --
11698    -----------------------------------
11699
11700    function Find_Task_Or_Protected_Pragma
11701      (T : Node_Id;
11702       P : Name_Id) return Node_Id
11703    is
11704       N : Node_Id;
11705
11706    begin
11707       N := First (Visible_Declarations (T));
11708       while Present (N) loop
11709          if Nkind (N) = N_Pragma then
11710             if Pragma_Name (N) = P then
11711                return N;
11712
11713             elsif P = Name_Priority
11714               and then Pragma_Name (N) = Name_Interrupt_Priority
11715             then
11716                return N;
11717
11718             else
11719                Next (N);
11720             end if;
11721
11722          else
11723             Next (N);
11724          end if;
11725       end loop;
11726
11727       N := First (Private_Declarations (T));
11728       while Present (N) loop
11729          if Nkind (N) = N_Pragma then
11730             if Pragma_Name (N) = P then
11731                return N;
11732
11733             elsif P = Name_Priority
11734               and then Pragma_Name (N) = Name_Interrupt_Priority
11735             then
11736                return N;
11737
11738             else
11739                Next (N);
11740             end if;
11741
11742          else
11743             Next (N);
11744          end if;
11745       end loop;
11746
11747       raise Program_Error;
11748    end Find_Task_Or_Protected_Pragma;
11749
11750    -------------------------------
11751    -- First_Protected_Operation --
11752    -------------------------------
11753
11754    function First_Protected_Operation (D : List_Id) return Node_Id is
11755       First_Op : Node_Id;
11756
11757    begin
11758       First_Op := First (D);
11759       while Present (First_Op)
11760         and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body)
11761       loop
11762          Next (First_Op);
11763       end loop;
11764
11765       return First_Op;
11766    end First_Protected_Operation;
11767
11768    ---------------------------------------
11769    -- Install_Private_Data_Declarations --
11770    ---------------------------------------
11771
11772    procedure Install_Private_Data_Declarations
11773      (Loc      : Source_Ptr;
11774       Spec_Id  : Entity_Id;
11775       Conc_Typ : Entity_Id;
11776       Body_Nod : Node_Id;
11777       Decls    : List_Id;
11778       Barrier  : Boolean := False;
11779       Family   : Boolean := False)
11780    is
11781       Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ);
11782       Decl         : Node_Id;
11783       Def          : Node_Id;
11784       Insert_Node  : Node_Id := Empty;
11785       Obj_Ent      : Entity_Id;
11786
11787       procedure Add (Decl : Node_Id);
11788       --  Add a single declaration after Insert_Node. If this is the first
11789       --  addition, Decl is added to the front of Decls and it becomes the
11790       --  insertion node.
11791
11792       function Replace_Bound (Bound : Node_Id) return Node_Id;
11793       --  The bounds of an entry index may depend on discriminants, create a
11794       --  reference to the corresponding prival. Otherwise return a duplicate
11795       --  of the original bound.
11796
11797       ---------
11798       -- Add --
11799       ---------
11800
11801       procedure Add (Decl : Node_Id) is
11802       begin
11803          if No (Insert_Node) then
11804             Prepend_To (Decls, Decl);
11805          else
11806             Insert_After (Insert_Node, Decl);
11807          end if;
11808
11809          Insert_Node := Decl;
11810       end Add;
11811
11812       --------------------------
11813       -- Replace_Discriminant --
11814       --------------------------
11815
11816       function Replace_Bound (Bound : Node_Id) return Node_Id is
11817       begin
11818          if Nkind (Bound) = N_Identifier
11819            and then Is_Discriminal (Entity (Bound))
11820          then
11821             return Make_Identifier (Loc, Chars (Entity (Bound)));
11822          else
11823             return Duplicate_Subexpr (Bound);
11824          end if;
11825       end Replace_Bound;
11826
11827    --  Start of processing for Install_Private_Data_Declarations
11828
11829    begin
11830       --  Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
11831       --  formal parameter _O, _object or _task depending on the context.
11832
11833       Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ);
11834
11835       --  Special processing of _O for barrier functions, protected entries
11836       --  and families.
11837
11838       if Barrier
11839         or else
11840           (Is_Protected
11841              and then
11842                (Ekind (Spec_Id) = E_Entry
11843                   or else Ekind (Spec_Id) = E_Entry_Family))
11844       then
11845          declare
11846             Conc_Rec : constant Entity_Id :=
11847                          Corresponding_Record_Type (Conc_Typ);
11848             Typ_Id   : constant Entity_Id :=
11849                          Make_Defining_Identifier (Loc,
11850                            New_External_Name (Chars (Conc_Rec), 'P'));
11851          begin
11852             --  Generate:
11853             --    type prot_typVP is access prot_typV;
11854
11855             Decl :=
11856               Make_Full_Type_Declaration (Loc,
11857                 Defining_Identifier => Typ_Id,
11858                 Type_Definition     =>
11859                   Make_Access_To_Object_Definition (Loc,
11860                     Subtype_Indication =>
11861                       New_Reference_To (Conc_Rec, Loc)));
11862             Add (Decl);
11863
11864             --  Generate:
11865             --    _object : prot_typVP := prot_typV (_O);
11866
11867             Decl :=
11868               Make_Object_Declaration (Loc,
11869                 Defining_Identifier =>
11870                   Make_Defining_Identifier (Loc, Name_uObject),
11871                 Object_Definition   => New_Reference_To (Typ_Id, Loc),
11872                 Expression          =>
11873                   Unchecked_Convert_To (Typ_Id,
11874                     New_Reference_To (Obj_Ent, Loc)));
11875             Add (Decl);
11876
11877             --  Set the reference to the concurrent object
11878
11879             Obj_Ent := Defining_Identifier (Decl);
11880          end;
11881       end if;
11882
11883       --  Step 2: Create the Protection object and build its declaration for
11884       --  any protected entry (family) of subprogram.
11885
11886       if Is_Protected then
11887          declare
11888             Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
11889             Prot_Typ : RE_Id;
11890
11891          begin
11892             Set_Protection_Object (Spec_Id, Prot_Ent);
11893
11894             --  Determine the proper protection type
11895
11896             if Has_Attach_Handler (Conc_Typ)
11897               and then not Restricted_Profile
11898             then
11899                Prot_Typ := RE_Static_Interrupt_Protection;
11900
11901             elsif Has_Interrupt_Handler (Conc_Typ) then
11902                Prot_Typ := RE_Dynamic_Interrupt_Protection;
11903
11904             --  The type has explicit entries or generated primitive entry
11905             --  wrappers.
11906
11907             elsif Has_Entries (Conc_Typ)
11908               or else
11909                 (Ada_Version >= Ada_2005
11910                    and then Present (Interface_List (Parent (Conc_Typ))))
11911             then
11912                case Corresponding_Runtime_Package (Conc_Typ) is
11913                   when System_Tasking_Protected_Objects_Entries =>
11914                      Prot_Typ := RE_Protection_Entries;
11915
11916                   when System_Tasking_Protected_Objects_Single_Entry =>
11917                      Prot_Typ := RE_Protection_Entry;
11918
11919                   when others =>
11920                      raise Program_Error;
11921                end case;
11922
11923             else
11924                Prot_Typ := RE_Protection;
11925             end if;
11926
11927             --  Generate:
11928             --    conc_typR : protection_typ renames _object._object;
11929
11930             Decl :=
11931               Make_Object_Renaming_Declaration (Loc,
11932                 Defining_Identifier => Prot_Ent,
11933                 Subtype_Mark =>
11934                   New_Reference_To (RTE (Prot_Typ), Loc),
11935                 Name =>
11936                   Make_Selected_Component (Loc,
11937                     Prefix        => New_Reference_To (Obj_Ent, Loc),
11938                     Selector_Name => Make_Identifier (Loc, Name_uObject)));
11939             Add (Decl);
11940          end;
11941       end if;
11942
11943       --  Step 3: Add discriminant renamings (if any)
11944
11945       if Has_Discriminants (Conc_Typ) then
11946          declare
11947             D : Entity_Id;
11948
11949          begin
11950             D := First_Discriminant (Conc_Typ);
11951             while Present (D) loop
11952
11953                --  Adjust the source location
11954
11955                Set_Sloc (Discriminal (D), Loc);
11956
11957                --  Generate:
11958                --    discr_name : discr_typ renames _object.discr_name;
11959                --      or
11960                --    discr_name : discr_typ renames _task.discr_name;
11961
11962                Decl :=
11963                  Make_Object_Renaming_Declaration (Loc,
11964                    Defining_Identifier => Discriminal (D),
11965                    Subtype_Mark        => New_Reference_To (Etype (D), Loc),
11966                    Name                =>
11967                      Make_Selected_Component (Loc,
11968                        Prefix        => New_Reference_To (Obj_Ent, Loc),
11969                        Selector_Name => Make_Identifier (Loc, Chars (D))));
11970                Add (Decl);
11971
11972                Next_Discriminant (D);
11973             end loop;
11974          end;
11975       end if;
11976
11977       --  Step 4: Add private component renamings (if any)
11978
11979       if Is_Protected then
11980          Def := Protected_Definition (Parent (Conc_Typ));
11981
11982          if Present (Private_Declarations (Def)) then
11983             declare
11984                Comp    : Node_Id;
11985                Comp_Id : Entity_Id;
11986                Decl_Id : Entity_Id;
11987
11988             begin
11989                Comp := First (Private_Declarations (Def));
11990                while Present (Comp) loop
11991                   if Nkind (Comp) = N_Component_Declaration then
11992                      Comp_Id := Defining_Identifier (Comp);
11993                      Decl_Id :=
11994                        Make_Defining_Identifier (Loc, Chars (Comp_Id));
11995
11996                      --  Minimal decoration
11997
11998                      if Ekind (Spec_Id) = E_Function then
11999                         Set_Ekind (Decl_Id, E_Constant);
12000                      else
12001                         Set_Ekind (Decl_Id, E_Variable);
12002                      end if;
12003
12004                      Set_Prival      (Comp_Id, Decl_Id);
12005                      Set_Prival_Link (Decl_Id, Comp_Id);
12006                      Set_Is_Aliased  (Decl_Id, Is_Aliased (Comp_Id));
12007
12008                      --  Generate:
12009                      --    comp_name : comp_typ renames _object.comp_name;
12010
12011                      Decl :=
12012                        Make_Object_Renaming_Declaration (Loc,
12013                          Defining_Identifier => Decl_Id,
12014                          Subtype_Mark =>
12015                            New_Reference_To (Etype (Comp_Id), Loc),
12016                          Name =>
12017                            Make_Selected_Component (Loc,
12018                              Prefix =>
12019                                New_Reference_To (Obj_Ent, Loc),
12020                              Selector_Name =>
12021                                Make_Identifier (Loc, Chars (Comp_Id))));
12022                      Add (Decl);
12023                   end if;
12024
12025                   Next (Comp);
12026                end loop;
12027             end;
12028          end if;
12029       end if;
12030
12031       --  Step 5: Add the declaration of the entry index and the associated
12032       --  type for barrier functions and entry families.
12033
12034       if (Barrier and then Family)
12035         or else Ekind (Spec_Id) = E_Entry_Family
12036       then
12037          declare
12038             E         : constant Entity_Id := Index_Object (Spec_Id);
12039             Index     : constant Entity_Id :=
12040                           Defining_Identifier (
12041                             Entry_Index_Specification (
12042                               Entry_Body_Formal_Part (Body_Nod)));
12043             Index_Con : constant Entity_Id :=
12044                           Make_Defining_Identifier (Loc, Chars (Index));
12045             High      : Node_Id;
12046             Index_Typ : Entity_Id;
12047             Low       : Node_Id;
12048
12049          begin
12050             --  Minimal decoration
12051
12052             Set_Ekind                (Index_Con, E_Constant);
12053             Set_Entry_Index_Constant (Index, Index_Con);
12054             Set_Discriminal_Link     (Index_Con, Index);
12055
12056             --  Retrieve the bounds of the entry family
12057
12058             High := Type_High_Bound (Etype (Index));
12059             Low  := Type_Low_Bound  (Etype (Index));
12060
12061             --  In the simple case the entry family is given by a subtype
12062             --  mark and the index constant has the same type.
12063
12064             if Is_Entity_Name (Original_Node (
12065                  Discrete_Subtype_Definition (Parent (Index))))
12066             then
12067                Index_Typ := Etype (Index);
12068
12069             --  Otherwise a new subtype declaration is required
12070
12071             else
12072                High := Replace_Bound (High);
12073                Low  := Replace_Bound (Low);
12074
12075                Index_Typ := Make_Temporary (Loc, 'J');
12076
12077                --  Generate:
12078                --    subtype Jnn is <Etype of Index> range Low .. High;
12079
12080                Decl :=
12081                  Make_Subtype_Declaration (Loc,
12082                    Defining_Identifier => Index_Typ,
12083                    Subtype_Indication =>
12084                      Make_Subtype_Indication (Loc,
12085                        Subtype_Mark =>
12086                          New_Reference_To (Base_Type (Etype (Index)), Loc),
12087                        Constraint =>
12088                          Make_Range_Constraint (Loc,
12089                            Range_Expression =>
12090                              Make_Range (Loc, Low, High))));
12091                Add (Decl);
12092             end if;
12093
12094             Set_Etype (Index_Con, Index_Typ);
12095
12096             --  Create the object which designates the index:
12097             --    J : constant Jnn :=
12098             --          Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
12099             --
12100             --  where Jnn is the subtype created above or the original type of
12101             --  the index, _E is a formal of the protected body subprogram and
12102             --  <index expr> is the index of the first family member.
12103
12104             Decl :=
12105               Make_Object_Declaration (Loc,
12106                 Defining_Identifier => Index_Con,
12107                 Constant_Present => True,
12108                 Object_Definition =>
12109                   New_Reference_To (Index_Typ, Loc),
12110
12111                 Expression =>
12112                   Make_Attribute_Reference (Loc,
12113                     Prefix =>
12114                       New_Reference_To (Index_Typ, Loc),
12115                     Attribute_Name => Name_Val,
12116
12117                     Expressions => New_List (
12118
12119                       Make_Op_Add (Loc,
12120                         Left_Opnd =>
12121                           Make_Op_Subtract (Loc,
12122                             Left_Opnd =>
12123                               New_Reference_To (E, Loc),
12124                             Right_Opnd =>
12125                               Entry_Index_Expression (Loc,
12126                                 Defining_Identifier (Body_Nod),
12127                                 Empty, Conc_Typ)),
12128
12129                         Right_Opnd =>
12130                           Make_Attribute_Reference (Loc,
12131                             Prefix =>
12132                               New_Reference_To (Index_Typ, Loc),
12133                             Attribute_Name => Name_Pos,
12134                             Expressions => New_List (
12135                               Make_Attribute_Reference (Loc,
12136                                 Prefix =>
12137                                   New_Reference_To (Index_Typ, Loc),
12138                                 Attribute_Name => Name_First)))))));
12139             Add (Decl);
12140          end;
12141       end if;
12142    end Install_Private_Data_Declarations;
12143
12144    ---------------------------------
12145    -- Is_Potentially_Large_Family --
12146    ---------------------------------
12147
12148    function Is_Potentially_Large_Family
12149      (Base_Index : Entity_Id;
12150       Conctyp    : Entity_Id;
12151       Lo         : Node_Id;
12152       Hi         : Node_Id) return Boolean
12153    is
12154    begin
12155       return Scope (Base_Index) = Standard_Standard
12156         and then Base_Index = Base_Type (Standard_Integer)
12157         and then Has_Discriminants (Conctyp)
12158         and then Present
12159           (Discriminant_Default_Value (First_Discriminant (Conctyp)))
12160         and then
12161           (Denotes_Discriminant (Lo, True)
12162             or else Denotes_Discriminant (Hi, True));
12163    end Is_Potentially_Large_Family;
12164
12165    -------------------------------------
12166    -- Is_Private_Primitive_Subprogram --
12167    -------------------------------------
12168
12169    function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
12170    begin
12171       return
12172         (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
12173           and then Is_Private_Primitive (Id);
12174    end Is_Private_Primitive_Subprogram;
12175
12176    ------------------
12177    -- Index_Object --
12178    ------------------
12179
12180    function Index_Object (Spec_Id : Entity_Id) return Entity_Id is
12181       Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id);
12182       Formal   : Entity_Id;
12183
12184    begin
12185       Formal := First_Formal (Bod_Subp);
12186       while Present (Formal) loop
12187
12188          --  Look for formal parameter _E
12189
12190          if Chars (Formal) = Name_uE then
12191             return Formal;
12192          end if;
12193
12194          Next_Formal (Formal);
12195       end loop;
12196
12197       --  A protected body subprogram should always have the parameter in
12198       --  question.
12199
12200       raise Program_Error;
12201    end Index_Object;
12202
12203    --------------------------------
12204    -- Make_Initialize_Protection --
12205    --------------------------------
12206
12207    function Make_Initialize_Protection
12208      (Protect_Rec : Entity_Id) return List_Id
12209    is
12210       Loc         : constant Source_Ptr := Sloc (Protect_Rec);
12211       P_Arr       : Entity_Id;
12212       Pdef        : Node_Id;
12213       Pdec        : Node_Id;
12214       Ptyp        : constant Node_Id :=
12215                       Corresponding_Concurrent_Type (Protect_Rec);
12216       Args        : List_Id;
12217       L           : constant List_Id := New_List;
12218       Has_Entry   : constant Boolean := Has_Entries (Ptyp);
12219       Restricted  : constant Boolean := Restricted_Profile;
12220
12221    begin
12222       --  We may need two calls to properly initialize the object, one to
12223       --  Initialize_Protection, and possibly one to Install_Handlers if we
12224       --  have a pragma Attach_Handler.
12225
12226       --  Get protected declaration. In the case of a task type declaration,
12227       --  this is simply the parent of the protected type entity. In the single
12228       --  protected object declaration, this parent will be the implicit type,
12229       --  and we can find the corresponding single protected object declaration
12230       --  by searching forward in the declaration list in the tree.
12231
12232       --  Is the test for N_Single_Protected_Declaration needed here??? Nodes
12233       --  of this type should have been removed during semantic analysis.
12234
12235       Pdec := Parent (Ptyp);
12236       while not Nkind_In (Pdec, N_Protected_Type_Declaration,
12237                                 N_Single_Protected_Declaration)
12238       loop
12239          Next (Pdec);
12240       end loop;
12241
12242       --  Now we can find the object definition from this declaration
12243
12244       Pdef := Protected_Definition (Pdec);
12245
12246       --  Build the parameter list for the call. Note that _Init is the name
12247       --  of the formal for the object to be initialized, which is the task
12248       --  value record itself.
12249
12250       Args := New_List;
12251
12252       --  Object parameter. This is a pointer to the object of type
12253       --  Protection used by the GNARL to control the protected object.
12254
12255       Append_To (Args,
12256         Make_Attribute_Reference (Loc,
12257           Prefix =>
12258             Make_Selected_Component (Loc,
12259               Prefix        => Make_Identifier (Loc, Name_uInit),
12260               Selector_Name => Make_Identifier (Loc, Name_uObject)),
12261           Attribute_Name => Name_Unchecked_Access));
12262
12263       --  Priority parameter. Set to Unspecified_Priority unless there is a
12264       --  priority pragma, in which case we take the value from the pragma,
12265       --  or there is an interrupt pragma and no priority pragma, and we
12266       --  set the ceiling to Interrupt_Priority'Last, an implementation-
12267       --  defined value, see D.3(10).
12268
12269       if Present (Pdef)
12270         and then Has_Pragma_Priority (Pdef)
12271       then
12272          declare
12273             Prio : constant Node_Id :=
12274                      Expression
12275                        (First
12276                           (Pragma_Argument_Associations
12277                              (Find_Task_Or_Protected_Pragma
12278                                 (Pdef, Name_Priority))));
12279             Temp : Entity_Id;
12280
12281          begin
12282             --  If priority is a static expression, then we can duplicate it
12283             --  with no problem and simply append it to the argument list.
12284
12285             if Is_Static_Expression (Prio) then
12286                Append_To (Args,
12287                           Duplicate_Subexpr_No_Checks (Prio));
12288
12289             --  Otherwise, the priority may be a per-object expression, if it
12290             --  depends on a discriminant of the type. In this case, create
12291             --  local variable to capture the expression. Note that it is
12292             --  really necessary to create this variable explicitly. It might
12293             --  be thought that removing side effects would the appropriate
12294             --  approach, but that could generate declarations improperly
12295             --  placed in the enclosing scope.
12296
12297             --  Note: Use System.Any_Priority as the expected type for the
12298             --  non-static priority expression, in case the expression has not
12299             --  been analyzed yet (as occurs for example with pragma
12300             --  Interrupt_Priority).
12301
12302             else
12303                Temp := Make_Temporary (Loc, 'R', Prio);
12304                Append_To (L,
12305                   Make_Object_Declaration (Loc,
12306                      Defining_Identifier => Temp,
12307                      Object_Definition   =>
12308                        New_Occurrence_Of (RTE (RE_Any_Priority), Loc),
12309                      Expression          => Relocate_Node (Prio)));
12310
12311                Append_To (Args, New_Occurrence_Of (Temp, Loc));
12312             end if;
12313          end;
12314
12315       --  When no priority is specified but an xx_Handler pragma is, we default
12316       --  to System.Interrupts.Default_Interrupt_Priority, see D.3(10).
12317
12318       elsif Has_Interrupt_Handler (Ptyp)
12319         or else Has_Attach_Handler (Ptyp)
12320       then
12321          Append_To (Args,
12322            New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
12323
12324       --  Normal case, no priority or xx_Handler specified, default priority
12325
12326       else
12327          Append_To (Args,
12328            New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
12329       end if;
12330
12331       --  Test for Compiler_Info parameter. This parameter allows entry body
12332       --  procedures and barrier functions to be called from the runtime. It
12333       --  is a pointer to the record generated by the compiler to represent
12334       --  the protected object.
12335
12336       --  A protected type without entries that covers an interface and
12337       --  overrides the abstract routines with protected procedures is
12338       --  considered equivalent to a protected type with entries in the
12339       --  context of dispatching select statements.
12340
12341       if Has_Entry
12342         or else Has_Interrupt_Handler (Ptyp)
12343         or else Has_Attach_Handler (Ptyp)
12344         or else Has_Interfaces (Protect_Rec)
12345       then
12346          declare
12347             Pkg_Id      : constant RTU_Id  :=
12348                             Corresponding_Runtime_Package (Ptyp);
12349             Called_Subp : RE_Id;
12350
12351          begin
12352             case Pkg_Id is
12353                when System_Tasking_Protected_Objects_Entries =>
12354                   Called_Subp := RE_Initialize_Protection_Entries;
12355
12356                when System_Tasking_Protected_Objects =>
12357                   Called_Subp := RE_Initialize_Protection;
12358
12359                when System_Tasking_Protected_Objects_Single_Entry =>
12360                   Called_Subp := RE_Initialize_Protection_Entry;
12361
12362                when others =>
12363                   raise Program_Error;
12364             end case;
12365
12366             if Has_Entry
12367               or else not Restricted
12368               or else Has_Interfaces (Protect_Rec)
12369             then
12370                Append_To (Args,
12371                  Make_Attribute_Reference (Loc,
12372                    Prefix         => Make_Identifier (Loc, Name_uInit),
12373                    Attribute_Name => Name_Address));
12374             end if;
12375
12376             --  Entry_Bodies parameter. This is a pointer to an array of
12377             --  pointers to the entry body procedures and barrier functions of
12378             --  the object. If the protected type has no entries this object
12379             --  will not exist, in this case, pass a null.
12380
12381             if Has_Entry then
12382                P_Arr := Entry_Bodies_Array (Ptyp);
12383
12384                Append_To (Args,
12385                  Make_Attribute_Reference (Loc,
12386                    Prefix => New_Reference_To (P_Arr, Loc),
12387                    Attribute_Name => Name_Unrestricted_Access));
12388
12389                if Pkg_Id = System_Tasking_Protected_Objects_Entries then
12390
12391                   --  Find index mapping function (clumsy but ok for now)
12392
12393                   while Ekind (P_Arr) /= E_Function loop
12394                      Next_Entity (P_Arr);
12395                   end loop;
12396
12397                   Append_To (Args,
12398                     Make_Attribute_Reference (Loc,
12399                       Prefix =>
12400                         New_Reference_To (P_Arr, Loc),
12401                       Attribute_Name => Name_Unrestricted_Access));
12402
12403                   --  Build_Entry_Names generation flag. When set to true, the
12404                   --  runtime will allocate an array to hold the string names
12405                   --  of protected entries.
12406
12407                   if not Restricted_Profile then
12408                      if Entry_Names_OK then
12409                         Append_To (Args,
12410                           New_Reference_To (Standard_True, Loc));
12411                      else
12412                         Append_To (Args,
12413                           New_Reference_To (Standard_False, Loc));
12414                      end if;
12415                   end if;
12416                end if;
12417
12418             elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
12419                Append_To (Args, Make_Null (Loc));
12420
12421             elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
12422                Append_To (Args, Make_Null (Loc));
12423                Append_To (Args, Make_Null (Loc));
12424                Append_To (Args, New_Reference_To (Standard_False, Loc));
12425             end if;
12426
12427             Append_To (L,
12428               Make_Procedure_Call_Statement (Loc,
12429                 Name => New_Reference_To (RTE (Called_Subp), Loc),
12430                 Parameter_Associations => Args));
12431          end;
12432       else
12433          Append_To (L,
12434            Make_Procedure_Call_Statement (Loc,
12435              Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
12436              Parameter_Associations => Args));
12437       end if;
12438
12439       if Has_Attach_Handler (Ptyp) then
12440
12441          --  We have a list of N Attach_Handler (ProcI, ExprI), and we have to
12442          --  make the following call:
12443
12444          --  Install_Handlers (_object,
12445          --    ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
12446
12447          --  or, in the case of Ravenscar:
12448
12449          --  Install_Restricted_Handlers
12450          --    ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
12451
12452          declare
12453             Args  : constant List_Id := New_List;
12454             Table : constant List_Id := New_List;
12455             Ritem : Node_Id          := First_Rep_Item (Ptyp);
12456
12457          begin
12458             --  Build the Attach_Handler table argument
12459
12460             while Present (Ritem) loop
12461                if Nkind (Ritem) = N_Pragma
12462                  and then Pragma_Name (Ritem) = Name_Attach_Handler
12463                then
12464                   declare
12465                      Handler : constant Node_Id :=
12466                                  First (Pragma_Argument_Associations (Ritem));
12467
12468                      Interrupt : constant Node_Id := Next (Handler);
12469                      Expr      : constant Node_Id := Expression (Interrupt);
12470
12471                   begin
12472                      Append_To (Table,
12473                        Make_Aggregate (Loc, Expressions => New_List (
12474                          Unchecked_Convert_To
12475                           (RTE (RE_System_Interrupt_Id), Expr),
12476                          Make_Attribute_Reference (Loc,
12477                            Prefix => Make_Selected_Component (Loc,
12478                               Make_Identifier (Loc, Name_uInit),
12479                               Duplicate_Subexpr_No_Checks
12480                                 (Expression (Handler))),
12481                            Attribute_Name => Name_Access))));
12482                   end;
12483                end if;
12484
12485                Next_Rep_Item (Ritem);
12486             end loop;
12487
12488             --  Append the table argument we just built
12489
12490             Append_To (Args, Make_Aggregate (Loc, Table));
12491
12492             --  Append the Install_Handlers (or Install_Restricted_Handlers)
12493             --  call to the statements.
12494
12495             if Restricted then
12496                --  Call a simplified version of Install_Handlers to be used
12497                --  when the Ravenscar restrictions are in effect
12498                --  (Install_Restricted_Handlers).
12499
12500                Append_To (L,
12501                  Make_Procedure_Call_Statement (Loc,
12502                    Name =>
12503                      New_Reference_To
12504                         (RTE (RE_Install_Restricted_Handlers), Loc),
12505                    Parameter_Associations => Args));
12506
12507             else
12508                --  First, prepends the _object argument
12509
12510                Prepend_To (Args,
12511                  Make_Attribute_Reference (Loc,
12512                    Prefix =>
12513                      Make_Selected_Component (Loc,
12514                        Prefix        => Make_Identifier (Loc, Name_uInit),
12515                        Selector_Name => Make_Identifier (Loc, Name_uObject)),
12516                    Attribute_Name => Name_Unchecked_Access));
12517
12518                --  Then, insert call to Install_Handlers
12519
12520                Append_To (L,
12521                  Make_Procedure_Call_Statement (Loc,
12522                    Name => New_Reference_To (RTE (RE_Install_Handlers), Loc),
12523                    Parameter_Associations => Args));
12524             end if;
12525          end;
12526       end if;
12527
12528       return L;
12529    end Make_Initialize_Protection;
12530
12531    ---------------------------
12532    -- Make_Task_Create_Call --
12533    ---------------------------
12534
12535    function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
12536       Loc    : constant Source_Ptr := Sloc (Task_Rec);
12537       Args   : List_Id;
12538       Ecount : Node_Id;
12539       Name   : Node_Id;
12540       Tdec   : Node_Id;
12541       Tdef   : Node_Id;
12542       Tnam   : Name_Id;
12543       Ttyp   : Node_Id;
12544
12545    begin
12546       Ttyp := Corresponding_Concurrent_Type (Task_Rec);
12547       Tnam := Chars (Ttyp);
12548
12549       --  Get task declaration. In the case of a task type declaration, this is
12550       --  simply the parent of the task type entity. In the single task
12551       --  declaration, this parent will be the implicit type, and we can find
12552       --  the corresponding single task declaration by searching forward in the
12553       --  declaration list in the tree.
12554
12555       --  Is the test for N_Single_Task_Declaration needed here??? Nodes of
12556       --  this type should have been removed during semantic analysis.
12557
12558       Tdec := Parent (Ttyp);
12559       while not Nkind_In (Tdec, N_Task_Type_Declaration,
12560                                 N_Single_Task_Declaration)
12561       loop
12562          Next (Tdec);
12563       end loop;
12564
12565       --  Now we can find the task definition from this declaration
12566
12567       Tdef := Task_Definition (Tdec);
12568
12569       --  Build the parameter list for the call. Note that _Init is the name
12570       --  of the formal for the object to be initialized, which is the task
12571       --  value record itself.
12572
12573       Args := New_List;
12574
12575       --  Priority parameter. Set to Unspecified_Priority unless there is a
12576       --  priority pragma, in which case we take the value from the pragma.
12577
12578       if Present (Tdef) and then Has_Pragma_Priority (Tdef) then
12579          Append_To (Args,
12580            Make_Selected_Component (Loc,
12581              Prefix        => Make_Identifier (Loc, Name_uInit),
12582              Selector_Name => Make_Identifier (Loc, Name_uPriority)));
12583       else
12584          Append_To (Args,
12585            New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
12586       end if;
12587
12588       --  Optional Stack parameter
12589
12590       if Restricted_Profile then
12591
12592          --  If the stack has been preallocated by the expander then
12593          --  pass its address. Otherwise, pass a null address.
12594
12595          if Preallocated_Stacks_On_Target then
12596             Append_To (Args,
12597               Make_Attribute_Reference (Loc,
12598                 Prefix         =>
12599                   Make_Selected_Component (Loc,
12600                     Prefix        => Make_Identifier (Loc, Name_uInit),
12601                     Selector_Name => Make_Identifier (Loc, Name_uStack)),
12602                 Attribute_Name => Name_Address));
12603
12604          else
12605             Append_To (Args,
12606               New_Reference_To (RTE (RE_Null_Address), Loc));
12607          end if;
12608       end if;
12609
12610       --  Size parameter. If no Storage_Size pragma is present, then
12611       --  the size is taken from the taskZ variable for the type, which
12612       --  is either Unspecified_Size, or has been reset by the use of
12613       --  a Storage_Size attribute definition clause. If a pragma is
12614       --  present, then the size is taken from the _Size field of the
12615       --  task value record, which was set from the pragma value.
12616
12617       if Present (Tdef)
12618         and then Has_Storage_Size_Pragma (Tdef)
12619       then
12620          Append_To (Args,
12621            Make_Selected_Component (Loc,
12622              Prefix        => Make_Identifier (Loc, Name_uInit),
12623              Selector_Name => Make_Identifier (Loc, Name_uSize)));
12624
12625       else
12626          Append_To (Args,
12627            New_Reference_To (Storage_Size_Variable (Ttyp), Loc));
12628       end if;
12629
12630       --  Task_Info parameter. Set to Unspecified_Task_Info unless there is a
12631       --  Task_Info pragma, in which case we take the value from the pragma.
12632
12633       if Present (Tdef)
12634         and then Has_Task_Info_Pragma (Tdef)
12635       then
12636          Append_To (Args,
12637            Make_Selected_Component (Loc,
12638              Prefix        => Make_Identifier (Loc, Name_uInit),
12639              Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
12640
12641       else
12642          Append_To (Args,
12643            New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc));
12644       end if;
12645
12646       --  CPU parameter. Set to Unspecified_CPU unless there is a CPU pragma,
12647       --  in which case we take the value from the pragma. The parameter is
12648       --  passed as an Integer because in the case of unspecified CPU the
12649       --  value is not in the range of CPU_Range.
12650
12651       if Present (Tdef) and then Has_Pragma_CPU (Tdef) then
12652          Append_To (Args,
12653            Convert_To (Standard_Integer,
12654              Make_Selected_Component (Loc,
12655                Prefix        => Make_Identifier (Loc, Name_uInit),
12656                Selector_Name => Make_Identifier (Loc, Name_uCPU))));
12657
12658       else
12659          Append_To (Args,
12660            New_Reference_To (RTE (RE_Unspecified_CPU), Loc));
12661       end if;
12662
12663       if not Restricted_Profile then
12664
12665          --  Deadline parameter. If no Relative_Deadline pragma is present,
12666          --  then the deadline is Time_Span_Zero. If a pragma is present, then
12667          --  the deadline is taken from the _Relative_Deadline field of the
12668          --  task value record, which was set from the pragma value. Note that
12669          --  this parameter must not be generated for the restricted profiles
12670          --  since Ravenscar does not allow deadlines.
12671
12672          --  Case where pragma Relative_Deadline applies: use given value
12673
12674          if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
12675             Append_To (Args,
12676               Make_Selected_Component (Loc,
12677                 Prefix        =>
12678                   Make_Identifier (Loc, Name_uInit),
12679                 Selector_Name =>
12680                   Make_Identifier (Loc, Name_uRelative_Deadline)));
12681
12682          --  No pragma Relative_Deadline apply to the task
12683
12684          else
12685             Append_To (Args,
12686               New_Reference_To (RTE (RE_Time_Span_Zero), Loc));
12687          end if;
12688
12689          --  Number of entries. This is an expression of the form:
12690
12691          --    n + _Init.a'Length + _Init.a'B'Length + ...
12692
12693          --  where a,b... are the entry family names for the task definition
12694
12695          Ecount :=
12696            Build_Entry_Count_Expression
12697              (Ttyp,
12698               Component_Items
12699                 (Component_List
12700                    (Type_Definition
12701                       (Parent (Corresponding_Record_Type (Ttyp))))),
12702               Loc);
12703          Append_To (Args, Ecount);
12704
12705          --  Master parameter. This is a reference to the _Master parameter of
12706          --  the initialization procedure, except in the case of the pragma
12707          --  Restrictions (No_Task_Hierarchy) where the value is fixed to
12708          --  System.Tasking.Library_Task_Level.
12709
12710          if Restriction_Active (No_Task_Hierarchy) = False then
12711             Append_To (Args, Make_Identifier (Loc, Name_uMaster));
12712          else
12713             Append_To (Args,
12714               New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
12715          end if;
12716       end if;
12717
12718       --  State parameter. This is a pointer to the task body procedure. The
12719       --  required value is obtained by taking 'Unrestricted_Access of the task
12720       --  body procedure and converting it (with an unchecked conversion) to
12721       --  the type required by the task kernel. For further details, see the
12722       --  description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
12723       --  than 'Address in order to avoid creating trampolines.
12724
12725       declare
12726          Body_Proc    : constant Node_Id := Get_Task_Body_Procedure (Ttyp);
12727          Subp_Ptr_Typ : constant Node_Id :=
12728                           Create_Itype (E_Access_Subprogram_Type, Tdec);
12729          Ref          : constant Node_Id := Make_Itype_Reference (Loc);
12730
12731       begin
12732          Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc);
12733          Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
12734
12735          --  Be sure to freeze a reference to the access-to-subprogram type,
12736          --  otherwise gigi will complain that it's in the wrong scope, because
12737          --  it's actually inside the init procedure for the record type that
12738          --  corresponds to the task type.
12739
12740          --  This processing is causing a crash in the .NET/JVM back ends that
12741          --  is not yet understood, so skip it in these cases ???
12742
12743          if VM_Target = No_VM then
12744             Set_Itype (Ref, Subp_Ptr_Typ);
12745             Append_Freeze_Action (Task_Rec, Ref);
12746
12747             Append_To (Args,
12748               Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
12749                 Make_Qualified_Expression (Loc,
12750                   Subtype_Mark => New_Reference_To (Subp_Ptr_Typ, Loc),
12751                   Expression   =>
12752                     Make_Attribute_Reference (Loc,
12753                       Prefix =>
12754                         New_Occurrence_Of (Body_Proc, Loc),
12755                       Attribute_Name => Name_Unrestricted_Access))));
12756
12757          --  For the .NET/JVM cases revert to the original code below ???
12758
12759          else
12760             Append_To (Args,
12761               Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
12762                 Make_Attribute_Reference (Loc,
12763                   Prefix =>
12764                     New_Occurrence_Of (Body_Proc, Loc),
12765                   Attribute_Name => Name_Address)));
12766          end if;
12767       end;
12768
12769       --  Discriminants parameter. This is just the address of the task
12770       --  value record itself (which contains the discriminant values
12771
12772       Append_To (Args,
12773         Make_Attribute_Reference (Loc,
12774           Prefix => Make_Identifier (Loc, Name_uInit),
12775           Attribute_Name => Name_Address));
12776
12777       --  Elaborated parameter. This is an access to the elaboration Boolean
12778
12779       Append_To (Args,
12780         Make_Attribute_Reference (Loc,
12781           Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
12782           Attribute_Name => Name_Unchecked_Access));
12783
12784       --  Chain parameter. This is a reference to the _Chain parameter of
12785       --  the initialization procedure.
12786
12787       Append_To (Args, Make_Identifier (Loc, Name_uChain));
12788
12789       --  Task name parameter. Take this from the _Task_Id parameter to the
12790       --  init call unless there is a Task_Name pragma, in which case we take
12791       --  the value from the pragma.
12792
12793       if Present (Tdef)
12794         and then Has_Task_Name_Pragma (Tdef)
12795       then
12796          --  Copy expression in full, because it may be dynamic and have
12797          --  side effects.
12798
12799          Append_To (Args,
12800            New_Copy_Tree
12801              (Expression (First
12802                            (Pragma_Argument_Associations
12803                              (Find_Task_Or_Protected_Pragma
12804                                (Tdef, Name_Task_Name))))));
12805
12806       else
12807          Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
12808       end if;
12809
12810       --  Created_Task parameter. This is the _Task_Id field of the task
12811       --  record value
12812
12813       Append_To (Args,
12814         Make_Selected_Component (Loc,
12815           Prefix        => Make_Identifier (Loc, Name_uInit),
12816           Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
12817
12818       --  Build_Entry_Names generation flag. When set to true, the runtime
12819       --  will allocate an array to hold the string names of task entries.
12820
12821       if not Restricted_Profile then
12822          if Has_Entries (Ttyp)
12823            and then Entry_Names_OK
12824          then
12825             Append_To (Args, New_Reference_To (Standard_True, Loc));
12826          else
12827             Append_To (Args, New_Reference_To (Standard_False, Loc));
12828          end if;
12829       end if;
12830
12831       if Restricted_Profile then
12832          Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
12833       else
12834          Name := New_Reference_To (RTE (RE_Create_Task), Loc);
12835       end if;
12836
12837       return
12838         Make_Procedure_Call_Statement (Loc,
12839           Name => Name,
12840           Parameter_Associations => Args);
12841    end Make_Task_Create_Call;
12842
12843    ------------------------------
12844    -- Next_Protected_Operation --
12845    ------------------------------
12846
12847    function Next_Protected_Operation (N : Node_Id) return Node_Id is
12848       Next_Op : Node_Id;
12849
12850    begin
12851       Next_Op := Next (N);
12852       while Present (Next_Op)
12853         and then not Nkind_In (Next_Op, N_Subprogram_Body, N_Entry_Body)
12854       loop
12855          Next (Next_Op);
12856       end loop;
12857
12858       return Next_Op;
12859    end Next_Protected_Operation;
12860
12861    ---------------------
12862    -- Null_Statements --
12863    ---------------------
12864
12865    function Null_Statements (Stats : List_Id) return Boolean is
12866       Stmt : Node_Id;
12867
12868    begin
12869       Stmt := First (Stats);
12870       while Nkind (Stmt) /= N_Empty
12871         and then (Nkind_In (Stmt, N_Null_Statement, N_Label)
12872                     or else
12873                       (Nkind (Stmt) = N_Pragma
12874                          and then (Pragma_Name (Stmt) = Name_Unreferenced
12875                                      or else
12876                                    Pragma_Name (Stmt) = Name_Unmodified
12877                                      or else
12878                                    Pragma_Name (Stmt) = Name_Warnings)))
12879       loop
12880          Next (Stmt);
12881       end loop;
12882
12883       return Nkind (Stmt) = N_Empty;
12884    end Null_Statements;
12885
12886    --------------------------
12887    -- Parameter_Block_Pack --
12888    --------------------------
12889
12890    function Parameter_Block_Pack
12891      (Loc     : Source_Ptr;
12892       Blk_Typ : Entity_Id;
12893       Actuals : List_Id;
12894       Formals : List_Id;
12895       Decls   : List_Id;
12896       Stmts   : List_Id) return Node_Id
12897    is
12898       Actual    : Entity_Id;
12899       Expr      : Node_Id := Empty;
12900       Formal    : Entity_Id;
12901       Has_Param : Boolean := False;
12902       P         : Entity_Id;
12903       Params    : List_Id;
12904       Temp_Asn  : Node_Id;
12905       Temp_Nam  : Node_Id;
12906
12907    begin
12908       Actual := First (Actuals);
12909       Formal := Defining_Identifier (First (Formals));
12910       Params := New_List;
12911
12912       while Present (Actual) loop
12913          if Is_By_Copy_Type (Etype (Actual)) then
12914             --  Generate:
12915             --    Jnn : aliased <formal-type>
12916
12917             Temp_Nam := Make_Temporary (Loc, 'J');
12918
12919             Append_To (Decls,
12920               Make_Object_Declaration (Loc,
12921                 Aliased_Present =>
12922                   True,
12923                 Defining_Identifier =>
12924                   Temp_Nam,
12925                 Object_Definition =>
12926                   New_Reference_To (Etype (Formal), Loc)));
12927
12928             if Ekind (Formal) /= E_Out_Parameter then
12929
12930                --  Generate:
12931                --    Jnn := <actual>
12932
12933                Temp_Asn :=
12934                  New_Reference_To (Temp_Nam, Loc);
12935
12936                Set_Assignment_OK (Temp_Asn);
12937
12938                Append_To (Stmts,
12939                  Make_Assignment_Statement (Loc,
12940                    Name =>
12941                      Temp_Asn,
12942                    Expression =>
12943                      New_Copy_Tree (Actual)));
12944             end if;
12945
12946             --  Generate:
12947             --    Jnn'unchecked_access
12948
12949             Append_To (Params,
12950               Make_Attribute_Reference (Loc,
12951                 Attribute_Name =>
12952                   Name_Unchecked_Access,
12953                 Prefix =>
12954                   New_Reference_To (Temp_Nam, Loc)));
12955
12956             Has_Param := True;
12957
12958          --  The controlling parameter is omitted
12959
12960          else
12961             if not Is_Controlling_Actual (Actual) then
12962                Append_To (Params,
12963                  Make_Reference (Loc, New_Copy_Tree (Actual)));
12964
12965                Has_Param := True;
12966             end if;
12967          end if;
12968
12969          Next_Actual (Actual);
12970          Next_Formal_With_Extras (Formal);
12971       end loop;
12972
12973       if Has_Param then
12974          Expr := Make_Aggregate (Loc, Params);
12975       end if;
12976
12977       --  Generate:
12978       --    P : Ann := (
12979       --      J1'unchecked_access;
12980       --      <actual2>'reference;
12981       --      ...);
12982
12983       P := Make_Temporary (Loc, 'P');
12984
12985       Append_To (Decls,
12986         Make_Object_Declaration (Loc,
12987           Defining_Identifier =>
12988             P,
12989           Object_Definition =>
12990             New_Reference_To (Blk_Typ, Loc),
12991           Expression =>
12992             Expr));
12993
12994       return P;
12995    end Parameter_Block_Pack;
12996
12997    ----------------------------
12998    -- Parameter_Block_Unpack --
12999    ----------------------------
13000
13001    function Parameter_Block_Unpack
13002      (Loc     : Source_Ptr;
13003       P       : Entity_Id;
13004       Actuals : List_Id;
13005       Formals : List_Id) return List_Id
13006    is
13007       Actual    : Entity_Id;
13008       Asnmt     : Node_Id;
13009       Formal    : Entity_Id;
13010       Has_Asnmt : Boolean := False;
13011       Result    : constant List_Id := New_List;
13012
13013    begin
13014       Actual := First (Actuals);
13015       Formal := Defining_Identifier (First (Formals));
13016       while Present (Actual) loop
13017          if Is_By_Copy_Type (Etype (Actual))
13018            and then Ekind (Formal) /= E_In_Parameter
13019          then
13020             --  Generate:
13021             --    <actual> := P.<formal>;
13022
13023             Asnmt :=
13024               Make_Assignment_Statement (Loc,
13025                 Name =>
13026                   New_Copy (Actual),
13027                 Expression =>
13028                   Make_Explicit_Dereference (Loc,
13029                     Make_Selected_Component (Loc,
13030                       Prefix        =>
13031                         New_Reference_To (P, Loc),
13032                       Selector_Name =>
13033                         Make_Identifier (Loc, Chars (Formal)))));
13034
13035             Set_Assignment_OK (Name (Asnmt));
13036             Append_To (Result, Asnmt);
13037
13038             Has_Asnmt := True;
13039          end if;
13040
13041          Next_Actual (Actual);
13042          Next_Formal_With_Extras (Formal);
13043       end loop;
13044
13045       if Has_Asnmt then
13046          return Result;
13047       else
13048          return New_List (Make_Null_Statement (Loc));
13049       end if;
13050    end Parameter_Block_Unpack;
13051
13052    ----------------------
13053    -- Set_Discriminals --
13054    ----------------------
13055
13056    procedure Set_Discriminals (Dec : Node_Id) is
13057       D       : Entity_Id;
13058       Pdef    : Entity_Id;
13059       D_Minal : Entity_Id;
13060
13061    begin
13062       pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
13063       Pdef := Defining_Identifier (Dec);
13064
13065       if Has_Discriminants (Pdef) then
13066          D := First_Discriminant (Pdef);
13067          while Present (D) loop
13068             D_Minal :=
13069               Make_Defining_Identifier (Sloc (D),
13070                 Chars => New_External_Name (Chars (D), 'D'));
13071
13072             Set_Ekind (D_Minal, E_Constant);
13073             Set_Etype (D_Minal, Etype (D));
13074             Set_Scope (D_Minal, Pdef);
13075             Set_Discriminal (D, D_Minal);
13076             Set_Discriminal_Link (D_Minal, D);
13077
13078             Next_Discriminant (D);
13079          end loop;
13080       end if;
13081    end Set_Discriminals;
13082
13083    -----------------------
13084    -- Trivial_Accept_OK --
13085    -----------------------
13086
13087    function Trivial_Accept_OK return Boolean is
13088    begin
13089       case Opt.Task_Dispatching_Policy is
13090
13091          --  If we have the default task dispatching policy in effect, we can
13092          --  definitely do the optimization (one way of looking at this is to
13093          --  think of the formal definition of the default policy being allowed
13094          --  to run any task it likes after a rendezvous, so even if notionally
13095          --  a full rescheduling occurs, we can say that our dispatching policy
13096          --  (i.e. the default dispatching policy) reorders the queue to be the
13097          --  same as just before the call.
13098
13099          when ' ' =>
13100             return True;
13101
13102          --  FIFO_Within_Priorities certainly does not permit this
13103          --  optimization since the Rendezvous is a scheduling action that may
13104          --  require some other task to be run.
13105
13106          when 'F' =>
13107             return False;
13108
13109          --  For now, disallow the optimization for all other policies. This
13110          --  may be over-conservative, but it is certainly not incorrect.
13111
13112          when others =>
13113             return False;
13114
13115       end case;
13116    end Trivial_Accept_OK;
13117
13118 end Exp_Ch9;