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