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