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-2005, 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 not Present (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            not Present (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              (not Present (Original_Node (Ecall))
4862                 or else
4863               Nkind (Original_Node (Ecall)) /= N_Delay_Relative_Statement)
4864          then
4865             Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
4866
4867             Decls := New_List;
4868             Stmts := New_List;
4869
4870             --  Call status flag processing, generate:
4871             --    B : Boolean := False;
4872
4873             B := Build_B (Loc, Decls);
4874
4875             --  Communication block processing, generate:
4876             --    Bnn : Communication_Block;
4877
4878             Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
4879
4880             Append_To (Decls,
4881               Make_Object_Declaration (Loc,
4882                 Defining_Identifier =>
4883                   Bnn,
4884                 Object_Definition =>
4885                   New_Reference_To (RTE (RE_Communication_Block), Loc)));
4886
4887             --  Call kind processing, generate:
4888             --    C : Ada.Tags.Prim_Op_Kind;
4889
4890             C := Build_C (Loc, Decls);
4891
4892             --  Tagged kind processing, generate:
4893             --    K : Ada.Tags.Tagged_Kind :=
4894             --          Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
4895
4896             K := Build_K (Loc, Decls, Obj);
4897
4898             --  Parameter block processing
4899
4900             Blk_Typ := Build_Parameter_Block
4901                          (Loc, Actuals, Formals, Decls);
4902             P       := Parameter_Block_Pack
4903                          (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
4904
4905             --  Dispatch table slot processing, generate:
4906             --    S : Integer;
4907
4908             S := Build_S (Loc, Decls);
4909
4910             --  Additional status flag processing, generate:
4911
4912             T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
4913
4914             Append_To (Decls,
4915               Make_Object_Declaration (Loc,
4916                 Defining_Identifier =>
4917                   T,
4918                 Object_Definition =>
4919                   New_Reference_To (Standard_Boolean, Loc)));
4920
4921             --  ---------------------------------------------------------------
4922             --  Protected entry handling
4923
4924             --  Generate:
4925             --    Param1 := P.Param1;
4926             --    ...
4927             --    ParamN := P.ParamN;
4928
4929             Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
4930
4931             --  Generate:
4932             --    _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B);
4933
4934             Prepend_To (Cleanup_Stmts,
4935               Make_Procedure_Call_Statement (Loc,
4936                 Name =>
4937                   New_Reference_To (
4938                     Find_Prim_Op (Etype (Etype (Obj)),
4939                       Name_uDisp_Asynchronous_Select),
4940                     Loc),
4941                 Parameter_Associations =>
4942                   New_List (
4943                     New_Copy_Tree    (Obj),
4944                     New_Reference_To (S, Loc),
4945                     Make_Attribute_Reference (Loc,
4946                       Prefix => New_Reference_To (P, Loc),
4947                       Attribute_Name => Name_Address),
4948                     New_Reference_To (Bnn, Loc),
4949                     New_Reference_To (B, Loc))));
4950
4951             --  Generate:
4952             --    if Enqueued (Bnn) then
4953             --       <abortable-statements>
4954             --    end if;
4955
4956             Append_To (Cleanup_Stmts,
4957               Make_If_Statement (Loc,
4958                 Condition =>
4959                   Make_Function_Call (Loc,
4960                     Name =>
4961                       New_Reference_To (RTE (RE_Enqueued), Loc),
4962                     Parameter_Associations =>
4963                       New_List (
4964                         New_Reference_To (Bnn, Loc))),
4965
4966                 Then_Statements =>
4967                   New_Copy_List_Tree (Astats)));
4968
4969             --  Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
4970             --  will then generate a _clean for the communication block Bnn.
4971
4972             --  Generate:
4973             --    declare
4974             --       procedure _clean is
4975             --       begin
4976             --          if Enqueued (Bnn) then
4977             --             Cancel_Protected_Entry_Call (Bnn);
4978             --          end if;
4979             --       end _clean;
4980             --    begin
4981             --       Cleanup_Stmts
4982             --    at end
4983             --       _clean;
4984             --    end;
4985
4986             Cleanup_Block_Ent :=
4987               Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
4988
4989             Cleanup_Block :=
4990               Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
4991
4992             --  Wrap the cleanup block in an exception handling block
4993
4994             --  Generate:
4995             --    begin
4996             --       Cleanup_Block
4997             --    exception
4998             --       when Abort_Signal => Abort_Undefer;
4999             --    end;
5000
5001             Abort_Block_Ent :=
5002               Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5003
5004             ProtE_Stmts :=
5005               New_List (
5006                 Make_Implicit_Label_Declaration (Loc,
5007                   Defining_Identifier => Abort_Block_Ent),
5008
5009                 Build_Abort_Block
5010                   (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
5011
5012             --  Generate:
5013             --    if not Cancelled (Bnn) then
5014             --       <triggering-statements>
5015             --    end if;
5016
5017             Append_To (ProtE_Stmts,
5018               Make_If_Statement (Loc,
5019                 Condition =>
5020                   Make_Op_Not (Loc,
5021                     Right_Opnd =>
5022                       Make_Function_Call (Loc,
5023                         Name =>
5024                           New_Reference_To (RTE (RE_Cancelled), Loc),
5025                         Parameter_Associations =>
5026                           New_List (
5027                             New_Reference_To (Bnn, Loc)))),
5028
5029                 Then_Statements =>
5030                   New_Copy_List_Tree (Tstats)));
5031
5032             --  ---------------------------------------------------------------
5033             --  Task entry handling
5034
5035             --  Generate:
5036             --    Param1 := P.Param1;
5037             --    ...
5038             --    ParamN := P.ParamN;
5039
5040             TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
5041
5042             --  Generate:
5043             --    _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B);
5044
5045             Prepend_To (TaskE_Stmts,
5046               Make_Procedure_Call_Statement (Loc,
5047                 Name =>
5048                   New_Reference_To (
5049                     Find_Prim_Op (Etype (Etype (Obj)),
5050                       Name_uDisp_Asynchronous_Select),
5051                     Loc),
5052                 Parameter_Associations =>
5053                   New_List (
5054                     New_Copy_Tree    (Obj),
5055                     New_Reference_To (S, Loc),
5056                     Make_Attribute_Reference (Loc,
5057                       Prefix => New_Reference_To (P, Loc),
5058                       Attribute_Name => Name_Address),
5059                     New_Reference_To (Bnn, Loc),
5060                     New_Reference_To (B, Loc))));
5061
5062             --  Generate:
5063             --    Abort_Defer;
5064
5065             Prepend_To (TaskE_Stmts,
5066               Make_Procedure_Call_Statement (Loc,
5067                 Name =>
5068                   New_Reference_To (RTE (RE_Abort_Defer), Loc),
5069                 Parameter_Associations =>
5070                   No_List));
5071
5072             --  Generate:
5073             --    Abort_Undefer;
5074             --    <abortable-statements>
5075
5076             Cleanup_Stmts := New_Copy_List_Tree (Astats);
5077
5078             Prepend_To (Cleanup_Stmts,
5079               Make_Procedure_Call_Statement (Loc,
5080                 Name =>
5081                   New_Reference_To (RTE (RE_Abort_Undefer), Loc),
5082                 Parameter_Associations =>
5083                   No_List));
5084
5085             --  Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
5086             --  will generate a _clean for the additional status flag.
5087
5088             --  Generate:
5089             --    declare
5090             --       procedure _clean is
5091             --       begin
5092             --          Cancel_Task_Entry_Call (U);
5093             --       end _clean;
5094             --    begin
5095             --       Cleanup_Stmts
5096             --    at end
5097             --       _clean;
5098             --    end;
5099
5100             Cleanup_Block_Ent :=
5101               Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
5102
5103             Cleanup_Block :=
5104               Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
5105
5106             --  Wrap the cleanup block in an exception handling block
5107
5108             --  Generate:
5109             --    begin
5110             --       Cleanup_Block
5111             --    exception
5112             --       when Abort_Signal => Abort_Undefer;
5113             --    end;
5114
5115             Abort_Block_Ent :=
5116               Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5117
5118             Append_To (TaskE_Stmts,
5119               Make_Implicit_Label_Declaration (Loc,
5120                 Defining_Identifier => Abort_Block_Ent));
5121
5122             Append_To (TaskE_Stmts,
5123               Build_Abort_Block
5124                 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
5125
5126             --  Generate:
5127             --    if not T then
5128             --       <triggering-statements>
5129             --    end if;
5130
5131             Append_To (TaskE_Stmts,
5132               Make_If_Statement (Loc,
5133                 Condition =>
5134                   Make_Op_Not (Loc,
5135                     Right_Opnd =>
5136                       New_Reference_To (T, Loc)),
5137
5138                 Then_Statements =>
5139                   New_Copy_List_Tree (Tstats)));
5140
5141             -------------------------------------------------------------------
5142             --  Protected procedure handling
5143
5144             --  Generate:
5145             --    <dispatching-call>;
5146             --    <triggering-statements>
5147
5148             ProtP_Stmts := New_Copy_List_Tree (Tstats);
5149             Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
5150
5151             --  Generate:
5152             --    S := Ada.Tags.Get_Offset_Index (
5153             --           Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
5154
5155             Conc_Typ_Stmts := New_List (
5156               Build_S_Assignment (Loc, S, Obj, Call_Ent));
5157
5158             --  Generate:
5159             --    _Disp_Get_Prim_Op_Kind (<object>, S, C);
5160
5161             Append_To (Conc_Typ_Stmts,
5162               Make_Procedure_Call_Statement (Loc,
5163                 Name =>
5164                   New_Reference_To (
5165                     Find_Prim_Op (Etype (Etype (Obj)),
5166                       Name_uDisp_Get_Prim_Op_Kind),
5167                     Loc),
5168                 Parameter_Associations =>
5169                   New_List (
5170                     New_Copy_Tree    (Obj),
5171                     New_Reference_To (S, Loc),
5172                     New_Reference_To (C, Loc))));
5173
5174             --  Generate:
5175             --    if C = POK_Procedure_Entry then
5176             --       ProtE_Stmts
5177             --    elsif C = POK_Task_Entry then
5178             --       TaskE_Stmts
5179             --    else
5180             --       ProtP_Stmts
5181             --    end if;
5182
5183             Append_To (Conc_Typ_Stmts,
5184               Make_If_Statement (Loc,
5185                 Condition =>
5186                   Make_Op_Eq (Loc,
5187                     Left_Opnd =>
5188                       New_Reference_To (C, Loc),
5189                     Right_Opnd =>
5190                       New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
5191
5192                 Then_Statements =>
5193                   ProtE_Stmts,
5194
5195                 Elsif_Parts =>
5196                   New_List (
5197                     Make_Elsif_Part (Loc,
5198                       Condition =>
5199                         Make_Op_Eq (Loc,
5200                           Left_Opnd =>
5201                             New_Reference_To (C, Loc),
5202                           Right_Opnd =>
5203                             New_Reference_To (RTE (RE_POK_Task_Entry), Loc)),
5204
5205                       Then_Statements =>
5206                         TaskE_Stmts)),
5207
5208                 Else_Statements =>
5209                   ProtP_Stmts));
5210
5211             --  Generate:
5212             --    <dispatching-call>;
5213             --    <triggering-statements>
5214
5215             Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
5216             Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
5217
5218             --  Generate:
5219             --    if K = Ada.Tags.TK_Limited_Tagged then
5220             --       Lim_Typ_Stmts
5221             --    else
5222             --       Conc_Typ_Stmts
5223             --    end if;
5224
5225             Append_To (Stmts,
5226               Make_If_Statement (Loc,
5227                 Condition =>
5228                    Make_Op_Eq (Loc,
5229                      Left_Opnd =>
5230                        New_Reference_To (K, Loc),
5231                      Right_Opnd =>
5232                        New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
5233
5234                 Then_Statements =>
5235                   Lim_Typ_Stmts,
5236
5237                 Else_Statements =>
5238                   Conc_Typ_Stmts));
5239
5240             Rewrite (N,
5241               Make_Block_Statement (Loc,
5242                 Declarations =>
5243                   Decls,
5244                 Handled_Statement_Sequence =>
5245                   Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5246
5247             Analyze (N);
5248             return;
5249
5250          --  Delay triggering statement processing
5251
5252          else
5253             --  Add a Delay_Block object to the parameter list of the delay
5254             --  procedure to form the parameter list of the Wait entry call.
5255
5256             Dblock_Ent :=
5257               Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
5258
5259             Pdef := Entity (Name (Ecall));
5260
5261             if Is_RTE (Pdef, RO_CA_Delay_For) then
5262                Enqueue_Call :=
5263                  New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
5264
5265             elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
5266                Enqueue_Call :=
5267                  New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
5268
5269             else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
5270                Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
5271             end if;
5272
5273             Append_To (Parameter_Associations (Ecall),
5274               Make_Attribute_Reference (Loc,
5275                 Prefix => New_Reference_To (Dblock_Ent, Loc),
5276                 Attribute_Name => Name_Unchecked_Access));
5277
5278             --  Create the inner block to protect the abortable part
5279
5280             Hdle := New_List (
5281               Make_Exception_Handler (Loc,
5282                 Exception_Choices =>
5283                   New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
5284                 Statements => New_List (
5285                   Make_Procedure_Call_Statement (Loc,
5286                     Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
5287
5288             Prepend_To (Astats,
5289               Make_Procedure_Call_Statement (Loc,
5290                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
5291
5292             Abortable_Block :=
5293               Make_Block_Statement (Loc,
5294                 Identifier => New_Reference_To (Blk_Ent, Loc),
5295                 Handled_Statement_Sequence =>
5296                   Make_Handled_Sequence_Of_Statements (Loc,
5297                     Statements => Astats),
5298                 Has_Created_Identifier => True,
5299                 Is_Asynchronous_Call_Block => True);
5300
5301             --  Append call to if Enqueue (When, DB'Unchecked_Access) then
5302
5303             Rewrite (Ecall,
5304               Make_Implicit_If_Statement (N,
5305                 Condition => Make_Function_Call (Loc,
5306                   Name => Enqueue_Call,
5307                   Parameter_Associations => Parameter_Associations (Ecall)),
5308                 Then_Statements =>
5309                   New_List (Make_Block_Statement (Loc,
5310                     Handled_Statement_Sequence =>
5311                       Make_Handled_Sequence_Of_Statements (Loc,
5312                         Statements => New_List (
5313                           Make_Implicit_Label_Declaration (Loc,
5314                             Defining_Identifier => Blk_Ent,
5315                             Label_Construct     => Abortable_Block),
5316                           Abortable_Block),
5317                         Exception_Handlers => Hdle)))));
5318
5319             Stmts := New_List (Ecall);
5320
5321             --  Construct statement sequence for new block
5322
5323             Append_To (Stmts,
5324               Make_Implicit_If_Statement (N,
5325                 Condition => Make_Function_Call (Loc,
5326                   Name => New_Reference_To (
5327                     RTE (RE_Timed_Out), Loc),
5328                   Parameter_Associations => New_List (
5329                     Make_Attribute_Reference (Loc,
5330                       Prefix => New_Reference_To (Dblock_Ent, Loc),
5331                       Attribute_Name => Name_Unchecked_Access))),
5332                 Then_Statements => Tstats));
5333
5334             --  The result is the new block
5335
5336             Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
5337
5338             Rewrite (N,
5339               Make_Block_Statement (Loc,
5340                 Declarations => New_List (
5341                   Make_Object_Declaration (Loc,
5342                     Defining_Identifier => Dblock_Ent,
5343                     Aliased_Present => True,
5344                     Object_Definition => New_Reference_To (
5345                       RTE (RE_Delay_Block), Loc))),
5346
5347                 Handled_Statement_Sequence =>
5348                   Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5349
5350             Analyze (N);
5351             return;
5352          end if;
5353
5354       else
5355          N_Orig := N;
5356       end if;
5357
5358       Extract_Entry (Ecall, Concval, Ename, Index);
5359       Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
5360
5361       Stmts := Statements (Handled_Statement_Sequence (Ecall));
5362       Decls := Declarations (Ecall);
5363
5364       if Is_Protected_Type (Etype (Concval)) then
5365
5366          --  Get the declarations of the block expanded from the entry call
5367
5368          Decl := First (Decls);
5369          while Present (Decl)
5370            and then
5371              (Nkind (Decl) /= N_Object_Declaration
5372                or else not Is_RTE (Etype (Object_Definition (Decl)),
5373                                    RE_Communication_Block))
5374          loop
5375             Next (Decl);
5376          end loop;
5377
5378          pragma Assert (Present (Decl));
5379          Cancel_Param := Defining_Identifier (Decl);
5380
5381          --  Change the mode of the Protected_Entry_Call call
5382
5383          --  Protected_Entry_Call (
5384          --    Object => po._object'Access,
5385          --    E => <entry index>;
5386          --    Uninterpreted_Data => P'Address;
5387          --    Mode => Asynchronous_Call;
5388          --    Block => Bnn);
5389
5390          Stmt := First (Stmts);
5391
5392          --  Skip assignments to temporaries created for in-out parameters
5393
5394          --  This makes unwarranted assumptions about the shape of the expanded
5395          --  tree for the call, and should be cleaned up ???
5396
5397          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
5398             Next (Stmt);
5399          end loop;
5400
5401          Call := Stmt;
5402
5403          Param := First (Parameter_Associations (Call));
5404          while Present (Param)
5405            and then not Is_RTE (Etype (Param), RE_Call_Modes)
5406          loop
5407             Next (Param);
5408          end loop;
5409
5410          pragma Assert (Present (Param));
5411          Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
5412          Analyze (Param);
5413
5414          --  Append an if statement to execute the abortable part
5415
5416          --  Generate:
5417          --    if Enqueued (Bnn) then
5418
5419          Append_To (Stmts,
5420            Make_Implicit_If_Statement (N,
5421              Condition => Make_Function_Call (Loc,
5422                Name => New_Reference_To (
5423                  RTE (RE_Enqueued), Loc),
5424                Parameter_Associations => New_List (
5425                  New_Reference_To (Cancel_Param, Loc))),
5426              Then_Statements => Astats));
5427
5428          Abortable_Block :=
5429            Make_Block_Statement (Loc,
5430              Identifier => New_Reference_To (Blk_Ent, Loc),
5431              Handled_Statement_Sequence =>
5432                Make_Handled_Sequence_Of_Statements (Loc,
5433                  Statements => Stmts),
5434              Has_Created_Identifier => True,
5435              Is_Asynchronous_Call_Block => True);
5436
5437          --  For the JVM call Update_Exception instead of Abort_Undefer.
5438          --  See 4jexcept.ads for an explanation.
5439
5440          if Hostparm.Java_VM then
5441             Target_Undefer := RE_Update_Exception;
5442             Undefer_Args :=
5443               New_List (Make_Function_Call (Loc,
5444                           Name => New_Occurrence_Of
5445                                     (RTE (RE_Current_Target_Exception), Loc)));
5446          else
5447             Target_Undefer := RE_Abort_Undefer;
5448          end if;
5449
5450          Stmts := New_List (
5451            Make_Block_Statement (Loc,
5452              Handled_Statement_Sequence =>
5453                Make_Handled_Sequence_Of_Statements (Loc,
5454                  Statements => New_List (
5455                    Make_Implicit_Label_Declaration (Loc,
5456                      Defining_Identifier => Blk_Ent,
5457                      Label_Construct     => Abortable_Block),
5458                    Abortable_Block),
5459
5460                --  exception
5461
5462                  Exception_Handlers => New_List (
5463                    Make_Exception_Handler (Loc,
5464
5465                --  when Abort_Signal =>
5466                --     Abort_Undefer.all;
5467
5468                      Exception_Choices =>
5469                        New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
5470                      Statements => New_List (
5471                        Make_Procedure_Call_Statement (Loc,
5472                          Name => New_Reference_To (
5473                            RTE (Target_Undefer), Loc),
5474                          Parameter_Associations => Undefer_Args)))))),
5475
5476          --  if not Cancelled (Bnn) then
5477          --     triggered statements
5478          --  end if;
5479
5480            Make_Implicit_If_Statement (N,
5481              Condition => Make_Op_Not (Loc,
5482                Right_Opnd =>
5483                  Make_Function_Call (Loc,
5484                    Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
5485                    Parameter_Associations => New_List (
5486                      New_Occurrence_Of (Cancel_Param, Loc)))),
5487              Then_Statements => Tstats));
5488
5489       --  Asynchronous task entry call
5490
5491       else
5492          if No (Decls) then
5493             Decls := New_List;
5494          end if;
5495
5496          B := Make_Defining_Identifier (Loc, Name_uB);
5497
5498          --  Insert declaration of B in declarations of existing block
5499
5500          Prepend_To (Decls,
5501            Make_Object_Declaration (Loc,
5502              Defining_Identifier => B,
5503              Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
5504
5505          Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
5506
5507          --  Insert declaration of C in declarations of existing block
5508
5509          Prepend_To (Decls,
5510            Make_Object_Declaration (Loc,
5511              Defining_Identifier => Cancel_Param,
5512              Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
5513
5514          --  Remove and save the call to Call_Simple
5515
5516          Stmt := First (Stmts);
5517
5518          --  Skip assignments to temporaries created for in-out parameters.
5519          --  This makes unwarranted assumptions about the shape of the expanded
5520          --  tree for the call, and should be cleaned up ???
5521
5522          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
5523             Next (Stmt);
5524          end loop;
5525
5526          Call := Stmt;
5527
5528          --  Create the inner block to protect the abortable part
5529
5530          Hdle :=  New_List (
5531            Make_Exception_Handler (Loc,
5532              Exception_Choices =>
5533                New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
5534              Statements => New_List (
5535                Make_Procedure_Call_Statement (Loc,
5536                  Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
5537
5538          Prepend_To (Astats,
5539            Make_Procedure_Call_Statement (Loc,
5540              Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
5541
5542          Abortable_Block :=
5543            Make_Block_Statement (Loc,
5544              Identifier => New_Reference_To (Blk_Ent, Loc),
5545              Handled_Statement_Sequence =>
5546                Make_Handled_Sequence_Of_Statements (Loc,
5547                  Statements => Astats),
5548              Has_Created_Identifier => True,
5549              Is_Asynchronous_Call_Block => True);
5550
5551          Insert_After (Call,
5552            Make_Block_Statement (Loc,
5553              Handled_Statement_Sequence =>
5554                Make_Handled_Sequence_Of_Statements (Loc,
5555                  Statements => New_List (
5556                    Make_Implicit_Label_Declaration (Loc,
5557                      Defining_Identifier => Blk_Ent,
5558                      Label_Construct     => Abortable_Block),
5559                    Abortable_Block),
5560                  Exception_Handlers => Hdle)));
5561
5562          --  Create new call statement
5563
5564          Params := Parameter_Associations (Call);
5565
5566          Append_To (Params,
5567            New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
5568          Append_To (Params,
5569            New_Reference_To (B, Loc));
5570
5571          Rewrite (Call,
5572            Make_Procedure_Call_Statement (Loc,
5573              Name =>
5574                New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
5575              Parameter_Associations => Params));
5576
5577          --  Construct statement sequence for new block
5578
5579          Append_To (Stmts,
5580            Make_Implicit_If_Statement (N,
5581              Condition =>
5582                Make_Op_Not (Loc,
5583                  New_Reference_To (Cancel_Param, Loc)),
5584              Then_Statements => Tstats));
5585
5586          --  Protected the call against abort
5587
5588          Prepend_To (Stmts,
5589            Make_Procedure_Call_Statement (Loc,
5590              Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
5591              Parameter_Associations => Empty_List));
5592       end if;
5593
5594       Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
5595
5596       --  The result is the new block
5597
5598       Rewrite (N_Orig,
5599         Make_Block_Statement (Loc,
5600           Declarations => Decls,
5601           Handled_Statement_Sequence =>
5602             Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5603
5604       Analyze (N_Orig);
5605    end Expand_N_Asynchronous_Select;
5606
5607    -------------------------------------
5608    -- Expand_N_Conditional_Entry_Call --
5609    -------------------------------------
5610
5611    --  The conditional task entry call is converted to a call to
5612    --  Task_Entry_Call:
5613
5614    --    declare
5615    --       B : Boolean;
5616    --       P : parms := (parm, parm, parm);
5617
5618    --    begin
5619    --       Task_Entry_Call
5620    --         (acceptor-task,
5621    --          entry-index,
5622    --          P'Address,
5623    --          Conditional_Call,
5624    --          B);
5625    --       parm := P.param;
5626    --       parm := P.param;
5627    --       ...
5628    --       if B then
5629    --          normal-statements
5630    --       else
5631    --          else-statements
5632    --       end if;
5633    --    end;
5634
5635    --  For a description of the use of P and the assignments after the
5636    --  call, see Expand_N_Entry_Call_Statement. Note that the entry call
5637    --  of the conditional entry call has already been expanded (by the
5638    --  Expand_N_Entry_Call_Statement procedure) as follows:
5639
5640    --    declare
5641    --       P : parms := (parm, parm, parm);
5642    --    begin
5643    --       ... info for in-out parameters
5644    --       Call_Simple (acceptor-task, entry-index, P'Address);
5645    --       parm := P.param;
5646    --       parm := P.param;
5647    --       ...
5648    --    end;
5649
5650    --  so the task at hand is to convert the latter expansion into the former
5651
5652    --  The conditional protected entry call is converted to a call to
5653    --  Protected_Entry_Call:
5654
5655    --    declare
5656    --       P : parms := (parm, parm, parm);
5657    --       Bnn : Communications_Block;
5658
5659    --    begin
5660    --       Protected_Entry_Call (
5661    --         Object => po._object'Access,
5662    --         E => <entry index>;
5663    --         Uninterpreted_Data => P'Address;
5664    --         Mode => Conditional_Call;
5665    --         Block => Bnn);
5666    --       parm := P.param;
5667    --       parm := P.param;
5668    --       ...
5669    --       if Cancelled (Bnn) then
5670    --          else-statements
5671    --       else
5672    --          normal-statements
5673    --       end if;
5674    --    end;
5675
5676    --  As for tasks, the entry call of the conditional entry call has
5677    --  already been expanded (by the Expand_N_Entry_Call_Statement procedure)
5678    --  as follows:
5679
5680    --    declare
5681    --       P   : E1_Params := (param, param, param);
5682    --       Bnn : Communications_Block;
5683
5684    --    begin
5685    --       Protected_Entry_Call (
5686    --         Object => po._object'Access,
5687    --         E => <entry index>;
5688    --         Uninterpreted_Data => P'Address;
5689    --         Mode => Simple_Call;
5690    --         Block => Bnn);
5691    --       parm := P.param;
5692    --       parm := P.param;
5693    --         ...
5694    --    end;
5695
5696    --  Ada 2005 (AI-345): A dispatching conditional entry call is converted
5697    --  into:
5698
5699    --    declare
5700    --       B : Boolean := False;
5701    --       C : Ada.Tags.Prim_Op_Kind;
5702    --       K : Ada.Tags.Tagged_Kind :=
5703    --             Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5704    --       P : Parameters := (Param1 .. ParamN);
5705    --       S : Integer;
5706
5707    --    begin
5708    --       if K = Ada.Tags.TK_Limited_Tagged then
5709    --          <dispatching-call>;
5710    --          <triggering-statements>
5711
5712    --       else
5713    --          S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>),
5714    --                 DT_Position (<dispatching-call>));
5715
5716    --          _Disp_Conditional_Select (<object>, S, P'address, C, B);
5717
5718    --          if C = POK_Protected_Entry
5719    --            or else C = POK_Task_Entry
5720    --          then
5721    --             Param1 := P.Param1;
5722    --             ...
5723    --             ParamN := P.ParamN;
5724    --          end if;
5725
5726    --          if B then
5727    --             if C = POK_Procedure
5728    --               or else C = POK_Protected_Procedure
5729    --               or else C = POK_Task_Procedure
5730    --             then
5731    --                <dispatching-call>;
5732    --             end if;
5733
5734    --             <triggering-statements>
5735    --          else
5736    --             <else-statements>
5737    --          end if;
5738    --       end if;
5739    --    end;
5740
5741    procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
5742       Loc : constant Source_Ptr := Sloc (N);
5743       Alt : constant Node_Id    := Entry_Call_Alternative (N);
5744       Blk : Node_Id             := Entry_Call_Statement (Alt);
5745       Transient_Blk : Node_Id;
5746
5747       Actuals        : List_Id;
5748       Blk_Typ        : Entity_Id;
5749       Call           : Node_Id;
5750       Call_Ent       : Entity_Id;
5751       Conc_Typ_Stmts : List_Id;
5752       Decl           : Node_Id;
5753       Decls          : List_Id;
5754       Formals        : List_Id;
5755       Lim_Typ_Stmts  : List_Id;
5756       N_Stats        : List_Id;
5757       Obj            : Entity_Id;
5758       Param          : Node_Id;
5759       Params         : List_Id;
5760       Stmt           : Node_Id;
5761       Stmts          : List_Id;
5762       Unpack         : List_Id;
5763
5764       B : Entity_Id;  --  Call status flag
5765       C : Entity_Id;  --  Call kind
5766       K : Entity_Id;  --  Tagged kind
5767       P : Entity_Id;  --  Parameter block
5768       S : Entity_Id;  --  Primitive operation slot
5769
5770    begin
5771       if Ada_Version >= Ada_05
5772         and then Nkind (Blk) = N_Procedure_Call_Statement
5773       then
5774          Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
5775
5776          Decls := New_List;
5777          Stmts := New_List;
5778
5779          --  Call status flag processing, generate:
5780          --    B : Boolean := False;
5781
5782          B := Build_B (Loc, Decls);
5783
5784          --  Call kind processing, generate:
5785          --    C : Ada.Tags.Prim_Op_Kind;
5786
5787          C := Build_C (Loc, Decls);
5788
5789          --  Tagged kind processing, generate:
5790          --    K : Ada.Tags.Tagged_Kind :=
5791          --          Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5792
5793          K := Build_K (Loc, Decls, Obj);
5794
5795          --  Parameter block processing
5796
5797          Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
5798          P       := Parameter_Block_Pack
5799                       (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
5800
5801          --  Dispatch table slot processing, generate:
5802          --    S : Integer;
5803
5804          S := Build_S (Loc, Decls);
5805
5806          --  Generate:
5807          --    S := Ada.Tags.Get_Offset_Index (
5808          --           Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
5809
5810          Conc_Typ_Stmts := New_List (
5811            Build_S_Assignment (Loc, S, Obj, Call_Ent));
5812
5813          --  Generate:
5814          --    _Disp_Conditional_Select (<object>, S, P'address, C, B);
5815
5816          Append_To (Conc_Typ_Stmts,
5817            Make_Procedure_Call_Statement (Loc,
5818              Name =>
5819                New_Reference_To (
5820                  Find_Prim_Op (Etype (Etype (Obj)),
5821                    Name_uDisp_Conditional_Select),
5822                  Loc),
5823              Parameter_Associations =>
5824                New_List (
5825                  New_Copy_Tree    (Obj),
5826                  New_Reference_To (S, Loc),
5827                  Make_Attribute_Reference (Loc,
5828                    Prefix => New_Reference_To (P, Loc),
5829                    Attribute_Name => Name_Address),
5830                  New_Reference_To (C, Loc),
5831                  New_Reference_To (B, Loc))));
5832
5833          --  Generate:
5834          --    if C = POK_Protected_Entry
5835          --      or else C = POK_Task_Entry
5836          --    then
5837          --       Param1 := P.Param1;
5838          --       ...
5839          --       ParamN := P.ParamN;
5840          --    end if;
5841
5842          Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
5843
5844          --  Generate the if statement only when the packed parameters need
5845          --  explicit assignments to their corresponding actuals.
5846
5847          if Present (Unpack) then
5848             Append_To (Conc_Typ_Stmts,
5849               Make_If_Statement (Loc,
5850
5851                 Condition =>
5852                   Make_Or_Else (Loc,
5853                     Left_Opnd =>
5854                       Make_Op_Eq (Loc,
5855                         Left_Opnd =>
5856                           New_Reference_To (C, Loc),
5857                         Right_Opnd =>
5858                           New_Reference_To (RTE (
5859                             RE_POK_Protected_Entry), Loc)),
5860                     Right_Opnd =>
5861                       Make_Op_Eq (Loc,
5862                         Left_Opnd =>
5863                           New_Reference_To (C, Loc),
5864                         Right_Opnd =>
5865                           New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
5866
5867                  Then_Statements =>
5868                    Unpack));
5869          end if;
5870
5871          --  Generate:
5872          --    if B then
5873          --       if C = POK_Procedure
5874          --         or else C = POK_Protected_Procedure
5875          --         or else C = POK_Task_Procedure
5876          --       then
5877          --          <dispatching-call>
5878          --       end if;
5879          --       <normal-statements>
5880          --    else
5881          --       <else-statements>
5882          --    end if;
5883
5884          N_Stats := New_Copy_List_Tree (Statements (Alt));
5885
5886          Prepend_To (N_Stats,
5887            Make_If_Statement (Loc,
5888              Condition =>
5889                Make_Or_Else (Loc,
5890                  Left_Opnd =>
5891                    Make_Op_Eq (Loc,
5892                      Left_Opnd =>
5893                        New_Reference_To (C, Loc),
5894                      Right_Opnd =>
5895                        New_Reference_To (RTE (RE_POK_Procedure), Loc)),
5896
5897                  Right_Opnd =>
5898                    Make_Or_Else (Loc,
5899                      Left_Opnd =>
5900                        Make_Op_Eq (Loc,
5901                          Left_Opnd =>
5902                            New_Reference_To (C, Loc),
5903                          Right_Opnd =>
5904                            New_Reference_To (RTE (
5905                              RE_POK_Protected_Procedure), Loc)),
5906
5907                      Right_Opnd =>
5908                        Make_Op_Eq (Loc,
5909                          Left_Opnd =>
5910                            New_Reference_To (C, Loc),
5911                          Right_Opnd =>
5912                            New_Reference_To (RTE (
5913                              RE_POK_Task_Procedure), Loc)))),
5914
5915              Then_Statements =>
5916                New_List (Blk)));
5917
5918          Append_To (Conc_Typ_Stmts,
5919            Make_If_Statement (Loc,
5920              Condition       => New_Reference_To (B, Loc),
5921              Then_Statements => N_Stats,
5922              Else_Statements => Else_Statements (N)));
5923
5924          --  Generate:
5925          --    <dispatching-call>;
5926          --    <triggering-statements>
5927
5928          Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
5929          Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
5930
5931          --  Generate:
5932          --    if K = Ada.Tags.TK_Limited_Tagged then
5933          --       Lim_Typ_Stmts
5934          --    else
5935          --       Conc_Typ_Stmts
5936          --    end if;
5937
5938          Append_To (Stmts,
5939            Make_If_Statement (Loc,
5940              Condition =>
5941                Make_Op_Eq (Loc,
5942                  Left_Opnd =>
5943                    New_Reference_To (K, Loc),
5944                  Right_Opnd =>
5945                    New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
5946
5947              Then_Statements =>
5948                Lim_Typ_Stmts,
5949
5950              Else_Statements =>
5951                Conc_Typ_Stmts));
5952
5953          Rewrite (N,
5954            Make_Block_Statement (Loc,
5955              Declarations               => Decls,
5956              Handled_Statement_Sequence =>
5957                Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5958
5959       --  As described above, The entry alternative is transformed into a
5960       --  block that contains the gnulli call, and possibly assignment
5961       --  statements for in-out parameters. The gnulli call may itself be
5962       --  rewritten into a transient block if some unconstrained parameters
5963       --  require it. We need to retrieve the call to complete its parameter
5964       --  list.
5965
5966       else
5967          Transient_Blk :=
5968             First_Real_Statement (Handled_Statement_Sequence (Blk));
5969
5970          if Present (Transient_Blk)
5971            and then Nkind (Transient_Blk) = N_Block_Statement
5972          then
5973             Blk := Transient_Blk;
5974          end if;
5975
5976          Stmts := Statements (Handled_Statement_Sequence (Blk));
5977          Stmt  := First (Stmts);
5978          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
5979             Next (Stmt);
5980          end loop;
5981
5982          Call   := Stmt;
5983          Params := Parameter_Associations (Call);
5984
5985          if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
5986
5987             --  Substitute Conditional_Entry_Call for Simple_Call parameter
5988
5989             Param := First (Params);
5990             while Present (Param)
5991               and then not Is_RTE (Etype (Param), RE_Call_Modes)
5992             loop
5993                Next (Param);
5994             end loop;
5995
5996             pragma Assert (Present (Param));
5997             Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc));
5998
5999             Analyze (Param);
6000
6001             --  Find the Communication_Block parameter for the call to the
6002             --  Cancelled function.
6003
6004             Decl := First (Declarations (Blk));
6005             while Present (Decl)
6006               and then not Is_RTE (Etype (Object_Definition (Decl)),
6007                              RE_Communication_Block)
6008             loop
6009                Next (Decl);
6010             end loop;
6011
6012             --  Add an if statement to execute the else part if the call
6013             --  does not succeed (as indicated by the Cancelled predicate).
6014
6015             Append_To (Stmts,
6016               Make_Implicit_If_Statement (N,
6017                 Condition => Make_Function_Call (Loc,
6018                   Name => New_Reference_To (RTE (RE_Cancelled), Loc),
6019                   Parameter_Associations => New_List (
6020                     New_Reference_To (Defining_Identifier (Decl), Loc))),
6021                 Then_Statements => Else_Statements (N),
6022                 Else_Statements => Statements (Alt)));
6023
6024          else
6025             B := Make_Defining_Identifier (Loc, Name_uB);
6026
6027             --  Insert declaration of B in declarations of existing block
6028
6029             if No (Declarations (Blk)) then
6030                Set_Declarations (Blk, New_List);
6031             end if;
6032
6033             Prepend_To (Declarations (Blk),
6034               Make_Object_Declaration (Loc,
6035                 Defining_Identifier => B,
6036                 Object_Definition =>
6037                   New_Reference_To (Standard_Boolean, Loc)));
6038
6039             --  Create new call statement
6040
6041             Append_To (Params,
6042               New_Reference_To (RTE (RE_Conditional_Call), Loc));
6043             Append_To (Params, New_Reference_To (B, Loc));
6044
6045             Rewrite (Call,
6046               Make_Procedure_Call_Statement (Loc,
6047                 Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
6048                 Parameter_Associations => Params));
6049
6050             --  Construct statement sequence for new block
6051
6052             Append_To (Stmts,
6053               Make_Implicit_If_Statement (N,
6054                 Condition => New_Reference_To (B, Loc),
6055                 Then_Statements => Statements (Alt),
6056                 Else_Statements => Else_Statements (N)));
6057          end if;
6058
6059          --  The result is the new block
6060
6061          Rewrite (N,
6062            Make_Block_Statement (Loc,
6063              Declarations => Declarations (Blk),
6064              Handled_Statement_Sequence =>
6065                Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
6066       end if;
6067
6068       Analyze (N);
6069    end Expand_N_Conditional_Entry_Call;
6070
6071    ---------------------------------------
6072    -- Expand_N_Delay_Relative_Statement --
6073    ---------------------------------------
6074
6075    --  Delay statement is implemented as a procedure call to Delay_For
6076    --  defined in Ada.Calendar.Delays in order to reduce the overhead of
6077    --  simple delays imposed by the use of Protected Objects.
6078
6079    procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
6080       Loc : constant Source_Ptr := Sloc (N);
6081    begin
6082       Rewrite (N,
6083         Make_Procedure_Call_Statement (Loc,
6084           Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc),
6085           Parameter_Associations => New_List (Expression (N))));
6086       Analyze (N);
6087    end Expand_N_Delay_Relative_Statement;
6088
6089    ------------------------------------
6090    -- Expand_N_Delay_Until_Statement --
6091    ------------------------------------
6092
6093    --  Delay Until statement is implemented as a procedure call to
6094    --  Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
6095
6096    procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
6097       Loc : constant Source_Ptr := Sloc (N);
6098       Typ : Entity_Id;
6099
6100    begin
6101       if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
6102          Typ := RTE (RO_CA_Delay_Until);
6103       else
6104          Typ := RTE (RO_RT_Delay_Until);
6105       end if;
6106
6107       Rewrite (N,
6108         Make_Procedure_Call_Statement (Loc,
6109           Name => New_Reference_To (Typ, Loc),
6110           Parameter_Associations => New_List (Expression (N))));
6111
6112       Analyze (N);
6113    end Expand_N_Delay_Until_Statement;
6114
6115    -------------------------
6116    -- Expand_N_Entry_Body --
6117    -------------------------
6118
6119    procedure Expand_N_Entry_Body (N : Node_Id) is
6120       Loc         : constant Source_Ptr := Sloc (N);
6121       Dec         : constant Node_Id    := Parent (Current_Scope);
6122       Ent_Formals : constant Node_Id    := Entry_Body_Formal_Part (N);
6123       Index_Spec  : constant Node_Id    :=
6124                       Entry_Index_Specification (Ent_Formals);
6125       Next_Op     : Node_Id;
6126       First_Decl  : constant Node_Id := First (Declarations (N));
6127       Index_Decl  : List_Id;
6128
6129    begin
6130       --  Add the renamings for private declarations and discriminants
6131
6132       Add_Discriminal_Declarations
6133         (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc);
6134       Add_Private_Declarations
6135         (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc);
6136
6137       if Present (Index_Spec) then
6138          Index_Decl :=
6139            Index_Constant_Declaration
6140              (N,
6141                Defining_Identifier (Index_Spec), Defining_Identifier (Dec));
6142
6143          --  If the entry has local declarations, insert index declaration
6144          --  before them, because the index may be used therein.
6145
6146          if Present (First_Decl) then
6147             Insert_List_Before (First_Decl, Index_Decl);
6148          else
6149             Append_List_To (Declarations (N), Index_Decl);
6150          end if;
6151       end if;
6152
6153       --  Associate privals and discriminals with the next protected operation
6154       --  body to be expanded. These are used to expand references to private
6155       --  data objects and discriminants, respectively.
6156
6157       Next_Op := Next_Protected_Operation (N);
6158
6159       if Present (Next_Op) then
6160          Set_Privals (Dec, Next_Op, Loc);
6161          Set_Discriminals (Dec);
6162       end if;
6163    end Expand_N_Entry_Body;
6164
6165    -----------------------------------
6166    -- Expand_N_Entry_Call_Statement --
6167    -----------------------------------
6168
6169    --  An entry call is expanded into GNARLI calls to implement
6170    --  a simple entry call (see Build_Simple_Entry_Call).
6171
6172    procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
6173       Concval : Node_Id;
6174       Ename   : Node_Id;
6175       Index   : Node_Id;
6176
6177    begin
6178       if No_Run_Time_Mode then
6179          Error_Msg_CRT ("entry call", N);
6180          return;
6181       end if;
6182
6183       --  If this entry call is part of an asynchronous select, don't expand it
6184       --  here; it will be expanded with the select statement. Don't expand
6185       --  timed entry calls either, as they are translated into asynchronous
6186       --  entry calls.
6187
6188       --  ??? This whole approach is questionable; it may be better to go back
6189       --  to allowing the expansion to take place and then attempting to fix it
6190       --  up in Expand_N_Asynchronous_Select. The tricky part is figuring out
6191       --  whether the expanded call is on a task or protected entry.
6192
6193       if (Nkind (Parent (N)) /= N_Triggering_Alternative
6194            or else N /= Triggering_Statement (Parent (N)))
6195         and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
6196                    or else N /= Entry_Call_Statement (Parent (N))
6197                    or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
6198       then
6199          Extract_Entry (N, Concval, Ename, Index);
6200          Build_Simple_Entry_Call (N, Concval, Ename, Index);
6201       end if;
6202    end Expand_N_Entry_Call_Statement;
6203
6204    --------------------------------
6205    -- Expand_N_Entry_Declaration --
6206    --------------------------------
6207
6208    --  If there are parameters, then first, each of the formals is marked by
6209    --  setting Is_Entry_Formal. Next a record type is built which is used to
6210    --  hold the parameter values. The name of this record type is entryP where
6211    --  entry is the name of the entry, with an additional corresponding access
6212    --  type called entryPA. The record type has matching components for each
6213    --  formal (the component names are the same as the formal names). For
6214    --  elementary types, the component type matches the formal type. For
6215    --  composite types, an access type is declared (with the name formalA)
6216    --  which designates the formal type, and the type of the component is this
6217    --  access type. Finally the Entry_Component of each formal is set to
6218    --  reference the corresponding record component.
6219
6220    procedure Expand_N_Entry_Declaration (N : Node_Id) is
6221       Loc        : constant Source_Ptr := Sloc (N);
6222       Entry_Ent  : constant Entity_Id  := Defining_Identifier (N);
6223       Components : List_Id;
6224       Formal     : Node_Id;
6225       Ftype      : Entity_Id;
6226       Last_Decl  : Node_Id;
6227       Component  : Entity_Id;
6228       Ctype      : Entity_Id;
6229       Decl       : Node_Id;
6230       Rec_Ent    : Entity_Id;
6231       Acc_Ent    : Entity_Id;
6232
6233    begin
6234       Formal := First_Formal (Entry_Ent);
6235       Last_Decl := N;
6236
6237       --  Most processing is done only if parameters are present
6238
6239       if Present (Formal) then
6240          Components := New_List;
6241
6242          --  Loop through formals
6243
6244          while Present (Formal) loop
6245             Set_Is_Entry_Formal (Formal);
6246             Component :=
6247               Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
6248             Set_Entry_Component (Formal, Component);
6249             Set_Entry_Formal (Component, Formal);
6250             Ftype := Etype (Formal);
6251
6252             --  Declare new access type and then append
6253
6254             Ctype :=
6255               Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6256
6257             Decl :=
6258               Make_Full_Type_Declaration (Loc,
6259                 Defining_Identifier => Ctype,
6260                 Type_Definition     =>
6261                   Make_Access_To_Object_Definition (Loc,
6262                     All_Present        => True,
6263                     Constant_Present   => Ekind (Formal) = E_In_Parameter,
6264                     Subtype_Indication => New_Reference_To (Ftype, Loc)));
6265
6266             Insert_After (Last_Decl, Decl);
6267             Last_Decl := Decl;
6268
6269             Append_To (Components,
6270               Make_Component_Declaration (Loc,
6271                 Defining_Identifier => Component,
6272                 Component_Definition =>
6273                   Make_Component_Definition (Loc,
6274                     Aliased_Present    => False,
6275                     Subtype_Indication => New_Reference_To (Ctype, Loc))));
6276
6277             Next_Formal_With_Extras (Formal);
6278          end loop;
6279
6280          --  Create the Entry_Parameter_Record declaration
6281
6282          Rec_Ent :=
6283            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
6284
6285          Decl :=
6286            Make_Full_Type_Declaration (Loc,
6287              Defining_Identifier => Rec_Ent,
6288              Type_Definition     =>
6289                Make_Record_Definition (Loc,
6290                  Component_List =>
6291                    Make_Component_List (Loc,
6292                      Component_Items => Components)));
6293
6294          Insert_After (Last_Decl, Decl);
6295          Last_Decl := Decl;
6296
6297          --  Construct and link in the corresponding access type
6298
6299          Acc_Ent :=
6300            Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6301
6302          Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
6303
6304          Decl :=
6305            Make_Full_Type_Declaration (Loc,
6306              Defining_Identifier => Acc_Ent,
6307              Type_Definition     =>
6308                Make_Access_To_Object_Definition (Loc,
6309                  All_Present        => True,
6310                  Subtype_Indication => New_Reference_To (Rec_Ent, Loc)));
6311
6312          Insert_After (Last_Decl, Decl);
6313          Last_Decl := Decl;
6314       end if;
6315    end Expand_N_Entry_Declaration;
6316
6317    -----------------------------
6318    -- Expand_N_Protected_Body --
6319    -----------------------------
6320
6321    --  Protected bodies are expanded to the completion of the subprograms
6322    --  created for the corresponding protected type. These are a protected and
6323    --  unprotected version of each protected subprogram in the object, a
6324    --  function to calculate each entry barrier, and a procedure to execute the
6325    --  sequence of statements of each protected entry body. For example, for
6326    --  protected type ptype:
6327
6328    --  function entB
6329    --    (O : System.Address;
6330    --     E : Protected_Entry_Index)
6331    --     return Boolean
6332    --  is
6333    --     <discriminant renamings>
6334    --     <private object renamings>
6335    --  begin
6336    --     return <barrier expression>;
6337    --  end entB;
6338
6339    --  procedure pprocN (_object : in out poV;...) is
6340    --     <discriminant renamings>
6341    --     <private object renamings>
6342    --  begin
6343    --     <sequence of statements>
6344    --  end pprocN;
6345
6346    --  procedure pprocP (_object : in out poV;...) is
6347    --     procedure _clean is
6348    --       Pn : Boolean;
6349    --     begin
6350    --       ptypeS (_object, Pn);
6351    --       Unlock (_object._object'Access);
6352    --       Abort_Undefer.all;
6353    --     end _clean;
6354
6355    --  begin
6356    --     Abort_Defer.all;
6357    --     Lock (_object._object'Access);
6358    --     pprocN (_object;...);
6359    --  at end
6360    --     _clean;
6361    --  end pproc;
6362
6363    --  function pfuncN (_object : poV;...) return Return_Type is
6364    --     <discriminant renamings>
6365    --     <private object renamings>
6366    --  begin
6367    --     <sequence of statements>
6368    --  end pfuncN;
6369
6370    --  function pfuncP (_object : poV) return Return_Type is
6371    --     procedure _clean is
6372    --     begin
6373    --        Unlock (_object._object'Access);
6374    --        Abort_Undefer.all;
6375    --     end _clean;
6376
6377    --  begin
6378    --     Abort_Defer.all;
6379    --     Lock (_object._object'Access);
6380    --     return pfuncN (_object);
6381
6382    --  at end
6383    --     _clean;
6384    --  end pfunc;
6385
6386    --  procedure entE
6387    --    (O : System.Address;
6388    --     P : System.Address;
6389    --     E : Protected_Entry_Index)
6390    --  is
6391    --     <discriminant renamings>
6392    --     <private object renamings>
6393    --     type poVP is access poV;
6394    --     _Object : ptVP := ptVP!(O);
6395
6396    --  begin
6397    --     begin
6398    --        <statement sequence>
6399    --        Complete_Entry_Body (_Object._Object);
6400    --     exception
6401    --        when all others =>
6402    --           Exceptional_Complete_Entry_Body (
6403    --             _Object._Object, Get_GNAT_Exception);
6404    --     end;
6405    --  end entE;
6406
6407    --  The type poV is the record created for the protected type to hold
6408    --  the state of the protected object.
6409
6410    procedure Expand_N_Protected_Body (N : Node_Id) is
6411       Loc          : constant Source_Ptr := Sloc (N);
6412       Pid          : constant Entity_Id  := Corresponding_Spec (N);
6413       Has_Entries  : Boolean := False;
6414       Op_Decl      : Node_Id;
6415       Op_Body      : Node_Id;
6416       Op_Id        : Entity_Id;
6417       Disp_Op_Body : Node_Id;
6418       New_Op_Body  : Node_Id;
6419       Current_Node : Node_Id;
6420       Num_Entries  : Natural := 0;
6421
6422       function Build_Dispatching_Subprogram_Body
6423         (N        : Node_Id;
6424          Pid      : Node_Id;
6425          Prot_Bod : Node_Id) return Node_Id;
6426       --  Build a dispatching version of the protected subprogram body. The
6427       --  newly generated subprogram contains a call to the original protected
6428       --  body. The following code is generated:
6429       --
6430       --  function <protected-function-name> (Param1 .. ParamN) return
6431       --    <return-type> is
6432       --  begin
6433       --     return <protected-function-name>P (Param1 .. ParamN);
6434       --  end <protected-function-name>;
6435       --
6436       --  or
6437       --
6438       --  procedure <protected-procedure-name> (Param1 .. ParamN) is
6439       --  begin
6440       --     <protected-procedure-name>P (Param1 .. ParamN);
6441       --  end <protected-procedure-name>
6442
6443       ---------------------------------------
6444       -- Build_Dispatching_Subprogram_Body --
6445       ---------------------------------------
6446
6447       function Build_Dispatching_Subprogram_Body
6448         (N        : Node_Id;
6449          Pid      : Node_Id;
6450          Prot_Bod : Node_Id) return Node_Id
6451       is
6452          Loc     : constant Source_Ptr := Sloc (N);
6453          Actuals : List_Id;
6454          Formal  : Node_Id;
6455          Spec    : Node_Id;
6456          Stmts   : List_Id;
6457
6458       begin
6459          --  Generate a specification without a letter suffix in order to
6460          --  override an interface function or procedure.
6461
6462          Spec :=
6463            Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
6464
6465          --  The formal parameters become the actuals of the protected
6466          --  function or procedure call.
6467
6468          Actuals := New_List;
6469          Formal  := First (Parameter_Specifications (Spec));
6470          while Present (Formal) loop
6471             Append_To (Actuals,
6472               Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
6473
6474             Next (Formal);
6475          end loop;
6476
6477          if Nkind (Spec) = N_Procedure_Specification then
6478             Stmts :=
6479               New_List (
6480                 Make_Procedure_Call_Statement (Loc,
6481                   Name =>
6482                     New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
6483                   Parameter_Associations => Actuals));
6484          else
6485             pragma Assert (Nkind (Spec) = N_Function_Specification);
6486
6487             Stmts :=
6488               New_List (
6489                 Make_Return_Statement (Loc,
6490                   Expression =>
6491                     Make_Function_Call (Loc,
6492                       Name =>
6493                         New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
6494                       Parameter_Associations => Actuals)));
6495          end if;
6496
6497          return
6498            Make_Subprogram_Body (Loc,
6499              Declarations  => Empty_List,
6500              Specification => Spec,
6501              Handled_Statement_Sequence =>
6502                Make_Handled_Sequence_Of_Statements (Loc, Stmts));
6503       end Build_Dispatching_Subprogram_Body;
6504
6505    --  Start of processing for Expand_N_Protected_Body
6506
6507    begin
6508       if No_Run_Time_Mode then
6509          Error_Msg_CRT ("protected body", N);
6510          return;
6511       end if;
6512
6513       if Nkind (Parent (N)) = N_Subunit then
6514
6515          --  This is the proper body corresponding to a stub. The declarations
6516          --  must be inserted at the point of the stub, which is in the decla-
6517          --  rative part of the parent unit.
6518
6519          Current_Node := Corresponding_Stub (Parent (N));
6520
6521       else
6522          Current_Node := N;
6523       end if;
6524
6525       Op_Body := First (Declarations (N));
6526
6527       --  The protected body is replaced with the bodies of its
6528       --  protected operations, and the declarations for internal objects
6529       --  that may have been created for entry family bounds.
6530
6531       Rewrite (N, Make_Null_Statement (Sloc (N)));
6532       Analyze (N);
6533
6534       while Present (Op_Body) loop
6535          case Nkind (Op_Body) is
6536             when N_Subprogram_Declaration =>
6537                null;
6538
6539             when N_Subprogram_Body =>
6540
6541                --  Exclude functions created to analyze defaults
6542
6543                if not Is_Eliminated (Defining_Entity (Op_Body))
6544                  and then not Is_Eliminated (Corresponding_Spec (Op_Body))
6545                then
6546                   New_Op_Body :=
6547                     Build_Unprotected_Subprogram_Body (Op_Body, Pid);
6548
6549                   Insert_After (Current_Node, New_Op_Body);
6550                   Current_Node := New_Op_Body;
6551                   Analyze (New_Op_Body);
6552
6553                   Update_Prival_Subtypes (New_Op_Body);
6554
6555                   --  Build the corresponding protected operation only if
6556                   --  this is a visible operation of the type, or if it is
6557                   --  an interrupt handler. Otherwise it is only callable
6558                   --  from within the object, and the unprotected version
6559                   --  is sufficient.
6560
6561                   if Present (Corresponding_Spec (Op_Body)) then
6562                      Op_Decl :=
6563                        Unit_Declaration_Node (Corresponding_Spec (Op_Body));
6564
6565                      if Nkind (Parent (Op_Decl)) = N_Protected_Definition
6566                        and then
6567                          (List_Containing (Op_Decl) =
6568                                   Visible_Declarations (Parent (Op_Decl))
6569                            or else
6570                             Is_Interrupt_Handler
6571                               (Corresponding_Spec (Op_Body)))
6572                      then
6573                         New_Op_Body :=
6574                            Build_Protected_Subprogram_Body (
6575                              Op_Body, Pid, Specification (New_Op_Body));
6576
6577                         Insert_After (Current_Node, New_Op_Body);
6578                         Analyze (New_Op_Body);
6579
6580                         Current_Node := New_Op_Body;
6581
6582                         --  Generate an overriding primitive operation body for
6583                         --  this subprogram if the protected type implements
6584                         --  an inerface.
6585
6586                         if Ada_Version >= Ada_05
6587                           and then Present (Abstract_Interfaces (
6588                                      Corresponding_Record_Type (Pid)))
6589                         then
6590                            Disp_Op_Body :=
6591                              Build_Dispatching_Subprogram_Body (
6592                                Op_Body, Pid, New_Op_Body);
6593
6594                            Insert_After (Current_Node, Disp_Op_Body);
6595                            Analyze (Disp_Op_Body);
6596
6597                            Current_Node := Disp_Op_Body;
6598                         end if;
6599                      end if;
6600                   end if;
6601                end if;
6602
6603             when N_Entry_Body =>
6604                Op_Id := Defining_Identifier (Op_Body);
6605                Has_Entries := True;
6606                Num_Entries := Num_Entries + 1;
6607
6608                New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
6609
6610                Insert_After (Current_Node, New_Op_Body);
6611                Current_Node := New_Op_Body;
6612                Analyze (New_Op_Body);
6613
6614                Update_Prival_Subtypes (New_Op_Body);
6615
6616             when N_Implicit_Label_Declaration =>
6617                null;
6618
6619             when N_Itype_Reference =>
6620                Insert_After (Current_Node, New_Copy (Op_Body));
6621
6622             when N_Freeze_Entity =>
6623                New_Op_Body := New_Copy (Op_Body);
6624
6625                if Present (Entity (Op_Body))
6626                  and then Freeze_Node (Entity (Op_Body)) = Op_Body
6627                then
6628                   Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
6629                end if;
6630
6631                Insert_After (Current_Node, New_Op_Body);
6632                Current_Node := New_Op_Body;
6633                Analyze (New_Op_Body);
6634
6635             when N_Pragma =>
6636                New_Op_Body := New_Copy (Op_Body);
6637                Insert_After (Current_Node, New_Op_Body);
6638                Current_Node := New_Op_Body;
6639                Analyze (New_Op_Body);
6640
6641             when N_Object_Declaration =>
6642                pragma Assert (not Comes_From_Source (Op_Body));
6643                New_Op_Body := New_Copy (Op_Body);
6644                Insert_After (Current_Node, New_Op_Body);
6645                Current_Node := New_Op_Body;
6646                Analyze (New_Op_Body);
6647
6648             when others =>
6649                raise Program_Error;
6650
6651          end case;
6652
6653          Next (Op_Body);
6654       end loop;
6655
6656       --  Finally, create the body of the function that maps an entry index
6657       --  into the corresponding body index, except when there is no entry,
6658       --  or in a ravenscar-like profile (no abort, no entry queue, 1 entry)
6659
6660       if Has_Entries
6661         and then (Abort_Allowed
6662                   or else Restriction_Active (No_Entry_Queue) = False
6663                   or else Num_Entries > 1
6664                   or else (Has_Attach_Handler (Pid)
6665                             and then not Restricted_Profile))
6666       then
6667          New_Op_Body := Build_Find_Body_Index (Pid);
6668          Insert_After (Current_Node, New_Op_Body);
6669          Current_Node := New_Op_Body;
6670          Analyze (New_Op_Body);
6671       end if;
6672
6673       --  Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
6674       --  the protected body. At this point the entry specs have been created,
6675       --  frozen and included in the dispatch table for the protected type.
6676
6677       pragma Assert (Present (Corresponding_Record_Type (Pid)));
6678
6679       if Ada_Version >= Ada_05
6680         and then Present (Protected_Definition (Parent (Pid)))
6681         and then Present (Abstract_Interfaces
6682                           (Corresponding_Record_Type (Pid)))
6683       then
6684          declare
6685             Vis_Decl  : Node_Id :=
6686                           First (Visible_Declarations
6687                                  (Protected_Definition (Parent (Pid))));
6688             Wrap_Body : Node_Id;
6689
6690          begin
6691             --  Examine the visible declarations of the protected type, looking
6692             --  for an entry declaration. We do not consider entry families
6693             --  since they cannot have dispatching operations, thus they do not
6694             --  need entry wrappers.
6695
6696             while Present (Vis_Decl) loop
6697                if Nkind (Vis_Decl) = N_Entry_Declaration then
6698                   Wrap_Body :=
6699                     Build_Wrapper_Body (Loc,
6700                       Proc_Nam => Defining_Identifier (Vis_Decl),
6701                       Obj_Typ  => Corresponding_Record_Type (Pid),
6702                       Formals  => Parameter_Specifications (Vis_Decl));
6703
6704                   if Wrap_Body /= Empty then
6705                      Insert_After (Current_Node, Wrap_Body);
6706                      Current_Node := Wrap_Body;
6707
6708                      Analyze (Wrap_Body);
6709                   end if;
6710
6711                elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then
6712                   Wrap_Body :=
6713                     Build_Wrapper_Body (Loc,
6714                       Proc_Nam => Defining_Unit_Name
6715                                         (Specification (Vis_Decl)),
6716                       Obj_Typ  => Corresponding_Record_Type (Pid),
6717                       Formals  => Parameter_Specifications
6718                                         (Specification (Vis_Decl)));
6719
6720                   if Wrap_Body /= Empty then
6721                      Insert_After (Current_Node, Wrap_Body);
6722                      Current_Node := Wrap_Body;
6723
6724                      Analyze (Wrap_Body);
6725                   end if;
6726                end if;
6727
6728                Next (Vis_Decl);
6729             end loop;
6730          end;
6731       end if;
6732    end Expand_N_Protected_Body;
6733
6734    -----------------------------------------
6735    -- Expand_N_Protected_Type_Declaration --
6736    -----------------------------------------
6737
6738    --  First we create a corresponding record type declaration used to
6739    --  represent values of this protected type.
6740    --  The general form of this type declaration is
6741
6742    --    type poV (discriminants) is record
6743    --      _Object       : aliased <kind>Protection
6744    --         [(<entry count> [, <handler count>])];
6745    --      [entry_family  : array (bounds) of Void;]
6746    --      <private data fields>
6747    --    end record;
6748
6749    --  The discriminants are present only if the corresponding protected type
6750    --  has discriminants, and they exactly mirror the protected type
6751    --  discriminants. The private data fields similarly mirror the private
6752    --  declarations of the protected type.
6753
6754    --  The Object field is always present. It contains RTS specific data used
6755    --  to control the protected object. It is declared as Aliased so that it
6756    --  can be passed as a pointer to the RTS. This allows the protected record
6757    --  to be referenced within RTS data structures. An appropriate Protection
6758    --  type and discriminant are generated.
6759
6760    --  The Service field is present for protected objects with entries. It
6761    --  contains sufficient information to allow the entry service procedure for
6762    --  this object to be called when the object is not known till runtime.
6763
6764    --  One entry_family component is present for each entry family in the
6765    --  task definition (see Expand_N_Task_Type_Declaration).
6766
6767    --  When a protected object is declared, an instance of the protected type
6768    --  value record is created. The elaboration of this declaration creates the
6769    --  correct bounds for the entry families, and also evaluates the priority
6770    --  expression if needed. The initialization routine for the protected type
6771    --  itself then calls Initialize_Protection with appropriate parameters to
6772    --  initialize the value of the Task_Id field. Install_Handlers may be also
6773    --  called if a pragma Attach_Handler applies.
6774
6775    --  Note: this record is passed to the subprograms created by the expansion
6776    --  of protected subprograms and entries. It is an in parameter to protected
6777    --  functions and an in out parameter to procedures and entry bodies. The
6778    --  Entity_Id for this created record type is placed in the
6779    --  Corresponding_Record_Type field of the associated protected type entity.
6780
6781    --  Next we create a procedure specifications for protected subprograms and
6782    --  entry bodies. For each protected subprograms two subprograms are
6783    --  created, an unprotected and a protected version. The unprotected version
6784    --  is called from within other operations of the same protected object.
6785
6786    --  We also build the call to register the procedure if a pragma
6787    --  Interrupt_Handler applies.
6788
6789    --  A single subprogram is created to service all entry bodies; it has an
6790    --  additional boolean out parameter indicating that the previous entry call
6791    --  made by the current task was serviced immediately, i.e. not by proxy.
6792    --  The O parameter contains a pointer to a record object of the type
6793    --  described above. An untyped interface is used here to allow this
6794    --  procedure to be called in places where the type of the object to be
6795    --  serviced is not known. This must be done, for example, when a call that
6796    --  may have been requeued is cancelled; the corresponding object must be
6797    --  serviced, but which object that is not known till runtime.
6798
6799    --  procedure ptypeS
6800    --    (O : System.Address; P : out Boolean);
6801    --  procedure pprocN (_object : in out poV);
6802    --  procedure pproc (_object : in out poV);
6803    --  function pfuncN (_object : poV);
6804    --  function pfunc (_object : poV);
6805    --  ...
6806
6807    --  Note that this must come after the record type declaration, since
6808    --  the specs refer to this type.
6809
6810    procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
6811       Loc     : constant Source_Ptr := Sloc (N);
6812       Prottyp : constant Entity_Id  := Defining_Identifier (N);
6813
6814       Pdef : constant Node_Id := Protected_Definition (N);
6815       --  This contains two lists; one for visible and one for private decls
6816
6817       Rec_Decl     : Node_Id;
6818       Cdecls       : List_Id;
6819       Discr_Map    : constant Elist_Id := New_Elmt_List;
6820       Priv         : Node_Id;
6821       Pent         : Entity_Id;
6822       New_Priv     : Node_Id;
6823       Comp         : Node_Id;
6824       Comp_Id      : Entity_Id;
6825       Sub          : Node_Id;
6826       Current_Node : Node_Id := N;
6827       Bdef         : Entity_Id := Empty; -- avoid uninit warning
6828       Edef         : Entity_Id := Empty; -- avoid uninit warning
6829       Entries_Aggr : Node_Id;
6830       Body_Id      : Entity_Id;
6831       Body_Arr     : Node_Id;
6832       E_Count      : Int;
6833       Object_Comp  : Node_Id;
6834
6835       procedure Register_Handler;
6836       --  For a protected operation that is an interrupt handler, add the
6837       --  freeze action that will register it as such.
6838
6839       ----------------------
6840       -- Register_Handler --
6841       ----------------------
6842
6843       procedure Register_Handler is
6844
6845          --  All semantic checks already done in Sem_Prag
6846
6847          Prot_Proc    : constant Entity_Id :=
6848                        Defining_Unit_Name
6849                          (Specification (Current_Node));
6850
6851          Proc_Address : constant Node_Id :=
6852                           Make_Attribute_Reference (Loc,
6853                           Prefix => New_Reference_To (Prot_Proc, Loc),
6854                           Attribute_Name => Name_Address);
6855
6856          RTS_Call     : constant Entity_Id :=
6857                           Make_Procedure_Call_Statement (Loc,
6858                             Name =>
6859                               New_Reference_To (
6860                                 RTE (RE_Register_Interrupt_Handler), Loc),
6861                             Parameter_Associations =>
6862                               New_List (Proc_Address));
6863       begin
6864          Append_Freeze_Action (Prot_Proc, RTS_Call);
6865       end Register_Handler;
6866
6867    --  Start of processing for Expand_N_Protected_Type_Declaration
6868
6869    begin
6870       if Present (Corresponding_Record_Type (Prottyp)) then
6871          return;
6872       else
6873          Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc);
6874          Cdecls   := Component_Items
6875                       (Component_List (Type_Definition (Rec_Decl)));
6876       end if;
6877
6878       --  Ada 2005 (AI-345): Propagate the attribute that contains the list
6879       --  of implemented interfaces.
6880
6881       Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
6882
6883       Qualify_Entity_Names (N);
6884
6885       --  If the type has discriminants, their occurrences in the declaration
6886       --  have been replaced by the corresponding discriminals. For components
6887       --  that are constrained by discriminants, their homologues in the
6888       --  corresponding record type must refer to the discriminants of that
6889       --  record, so we must apply a new renaming to subtypes_indications:
6890
6891       --     protected discriminant => discriminal => record discriminant
6892
6893       --  This replacement is not applied to default expressions, for which
6894       --  the discriminal is correct.
6895
6896       if Has_Discriminants (Prottyp) then
6897          declare
6898             Disc : Entity_Id;
6899             Decl : Node_Id;
6900          begin
6901             Disc := First_Discriminant (Prottyp);
6902             Decl := First (Discriminant_Specifications (Rec_Decl));
6903             while Present (Disc) loop
6904                Append_Elmt (Discriminal (Disc), Discr_Map);
6905                Append_Elmt (Defining_Identifier (Decl), Discr_Map);
6906                Next_Discriminant (Disc);
6907                Next (Decl);
6908             end loop;
6909          end;
6910       end if;
6911
6912       --  Fill in the component declarations
6913
6914       --  Add components for entry families. For each entry family, create an
6915       --  anonymous type declaration with the same size, and analyze the type.
6916
6917       Collect_Entry_Families (Loc, Cdecls, Current_Node, Prottyp);
6918
6919       --  Prepend the _Object field with the right type to the component list.
6920       --  We need to compute the number of entries, and in some cases the
6921       --  number of Attach_Handler pragmas.
6922
6923       declare
6924          Ritem              : Node_Id;
6925          Num_Attach_Handler : Int := 0;
6926          Protection_Subtype : Node_Id;
6927          Entry_Count_Expr   : constant Node_Id :=
6928                                 Build_Entry_Count_Expression
6929                                   (Prottyp, Cdecls, Loc);
6930
6931       begin
6932          if Has_Attach_Handler (Prottyp) then
6933             Ritem := First_Rep_Item (Prottyp);
6934             while Present (Ritem) loop
6935                if Nkind (Ritem) = N_Pragma
6936                  and then Chars (Ritem) = Name_Attach_Handler
6937                then
6938                   Num_Attach_Handler := Num_Attach_Handler + 1;
6939                end if;
6940
6941                Next_Rep_Item (Ritem);
6942             end loop;
6943
6944             if Restricted_Profile then
6945                if Has_Entries (Prottyp) then
6946                   Protection_Subtype :=
6947                     New_Reference_To (RTE (RE_Protection_Entry), Loc);
6948                else
6949                   Protection_Subtype :=
6950                     New_Reference_To (RTE (RE_Protection), Loc);
6951                end if;
6952             else
6953                Protection_Subtype :=
6954                  Make_Subtype_Indication
6955                    (Sloc => Loc,
6956                     Subtype_Mark =>
6957                       New_Reference_To
6958                         (RTE (RE_Static_Interrupt_Protection), Loc),
6959                     Constraint =>
6960                       Make_Index_Or_Discriminant_Constraint (
6961                         Sloc => Loc,
6962                         Constraints => New_List (
6963                           Entry_Count_Expr,
6964                           Make_Integer_Literal (Loc, Num_Attach_Handler))));
6965             end if;
6966
6967          elsif Has_Interrupt_Handler (Prottyp) then
6968             Protection_Subtype :=
6969                Make_Subtype_Indication (
6970                  Sloc => Loc,
6971                  Subtype_Mark => New_Reference_To
6972                    (RTE (RE_Dynamic_Interrupt_Protection), Loc),
6973                  Constraint =>
6974                    Make_Index_Or_Discriminant_Constraint (
6975                      Sloc => Loc,
6976                      Constraints => New_List (Entry_Count_Expr)));
6977
6978          --  Type has explicit entries or generated primitive entry wrappers
6979
6980          elsif Has_Entries (Prottyp)
6981            or else (Ada_Version >= Ada_05
6982                       and then Present (Interface_List (N)))
6983          then
6984             if Abort_Allowed
6985               or else Restriction_Active (No_Entry_Queue) = False
6986               or else Number_Entries (Prottyp) > 1
6987             then
6988                Protection_Subtype :=
6989                   Make_Subtype_Indication (
6990                     Sloc => Loc,
6991                     Subtype_Mark =>
6992                       New_Reference_To (RTE (RE_Protection_Entries), Loc),
6993                     Constraint =>
6994                       Make_Index_Or_Discriminant_Constraint (
6995                         Sloc => Loc,
6996                         Constraints => New_List (Entry_Count_Expr)));
6997
6998             else
6999                Protection_Subtype :=
7000                  New_Reference_To (RTE (RE_Protection_Entry), Loc);
7001             end if;
7002
7003          else
7004             Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc);
7005          end if;
7006
7007          Object_Comp :=
7008            Make_Component_Declaration (Loc,
7009              Defining_Identifier =>
7010                Make_Defining_Identifier (Loc, Name_uObject),
7011              Component_Definition =>
7012                Make_Component_Definition (Loc,
7013                  Aliased_Present    => True,
7014                  Subtype_Indication => Protection_Subtype));
7015       end;
7016
7017       pragma Assert (Present (Pdef));
7018
7019       --  Add private field components
7020
7021       if Present (Private_Declarations (Pdef)) then
7022          Priv := First (Private_Declarations (Pdef));
7023
7024          while Present (Priv) loop
7025
7026             if Nkind (Priv) = N_Component_Declaration then
7027                Pent := Defining_Identifier (Priv);
7028                New_Priv :=
7029                  Make_Component_Declaration (Loc,
7030                    Defining_Identifier =>
7031                      Make_Defining_Identifier (Sloc (Pent), Chars (Pent)),
7032                    Component_Definition =>
7033                      Make_Component_Definition (Sloc (Pent),
7034                        Aliased_Present    => False,
7035                        Subtype_Indication =>
7036                          New_Copy_Tree (Subtype_Indication
7037                                          (Component_Definition (Priv)),
7038                                         Discr_Map)),
7039                    Expression => Expression (Priv));
7040
7041                Append_To (Cdecls, New_Priv);
7042
7043             elsif Nkind (Priv) = N_Subprogram_Declaration then
7044
7045                --  Make the unprotected version of the subprogram available
7046                --  for expansion of intra object calls. There is need for
7047                --  a protected version only if the subprogram is an interrupt
7048                --  handler, otherwise  this operation can only be called from
7049                --  within the body.
7050
7051                Sub :=
7052                  Make_Subprogram_Declaration (Loc,
7053                    Specification =>
7054                      Build_Protected_Sub_Specification
7055                        (Priv, Prottyp, Unprotected_Mode));
7056
7057                Insert_After (Current_Node, Sub);
7058                Analyze (Sub);
7059
7060                Set_Protected_Body_Subprogram
7061                  (Defining_Unit_Name (Specification (Priv)),
7062                   Defining_Unit_Name (Specification (Sub)));
7063
7064                Current_Node := Sub;
7065
7066                if Is_Interrupt_Handler
7067                  (Defining_Unit_Name (Specification (Priv)))
7068                then
7069                   Sub :=
7070                     Make_Subprogram_Declaration (Loc,
7071                       Specification =>
7072                         Build_Protected_Sub_Specification
7073                           (Priv, Prottyp, Protected_Mode));
7074
7075                   Insert_After (Current_Node, Sub);
7076                   Analyze (Sub);
7077                   Current_Node := Sub;
7078
7079                   if not Restricted_Profile then
7080                      Register_Handler;
7081                   end if;
7082                end if;
7083             end if;
7084
7085             Next (Priv);
7086          end loop;
7087       end if;
7088
7089       --  Put the _Object component after the private component so that it
7090       --  be finalized early as required by 9.4 (20)
7091
7092       Append_To (Cdecls, Object_Comp);
7093
7094       Insert_After (Current_Node, Rec_Decl);
7095       Current_Node := Rec_Decl;
7096
7097       --  Analyze the record declaration immediately after construction,
7098       --  because the initialization procedure is needed for single object
7099       --  declarations before the next entity is analyzed (the freeze call
7100       --  that generates this initialization procedure is found below).
7101
7102       Analyze (Rec_Decl, Suppress => All_Checks);
7103
7104       --  Ada 2005 (AI-345): Construct the primitive entry wrappers before
7105       --  the corresponding record is frozen
7106
7107       if Ada_Version >= Ada_05
7108         and then Present (Visible_Declarations (Pdef))
7109         and then Present (Corresponding_Record_Type
7110                           (Defining_Identifier (Parent (Pdef))))
7111         and then Present (Abstract_Interfaces
7112                           (Corresponding_Record_Type
7113                            (Defining_Identifier (Parent (Pdef)))))
7114       then
7115          declare
7116             Current_Node : Node_Id := Rec_Decl;
7117             Vis_Decl     : Node_Id;
7118             Wrap_Spec    : Node_Id;
7119             New_N        : Node_Id;
7120
7121          begin
7122             --  Examine the visible declarations of the protected type, looking
7123             --  for declarations of entries, and subprograms. We do not
7124             --  consider entry families since they cannot have dispatching
7125             --  operations, thus they do not need entry wrappers.
7126
7127             Vis_Decl := First (Visible_Declarations (Pdef));
7128
7129             while Present (Vis_Decl) loop
7130
7131                Wrap_Spec := Empty;
7132
7133                if Nkind (Vis_Decl) = N_Entry_Declaration
7134                  and then not Present (Discrete_Subtype_Definition (Vis_Decl))
7135                then
7136                   Wrap_Spec :=
7137                     Build_Wrapper_Spec (Loc,
7138                       Proc_Nam => Defining_Identifier (Vis_Decl),
7139                       Obj_Typ  => Defining_Identifier (Rec_Decl),
7140                       Formals  => Parameter_Specifications (Vis_Decl));
7141
7142                elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then
7143                   Wrap_Spec :=
7144                     Build_Wrapper_Spec (Loc,
7145                       Proc_Nam => Defining_Unit_Name
7146                                     (Specification (Vis_Decl)),
7147                       Obj_Typ  => Defining_Identifier (Rec_Decl),
7148                       Formals  => Parameter_Specifications
7149                                     (Specification (Vis_Decl)));
7150
7151                end if;
7152
7153                if Wrap_Spec /= Empty then
7154                   New_N := Make_Subprogram_Declaration (Loc,
7155                              Specification => Wrap_Spec);
7156
7157                   Insert_After (Current_Node, New_N);
7158                   Current_Node := New_N;
7159
7160                   Analyze (New_N);
7161                end if;
7162
7163                Next (Vis_Decl);
7164             end loop;
7165          end;
7166       end if;
7167
7168       --  Collect pointers to entry bodies and their barriers, to be placed
7169       --  in the Entry_Bodies_Array for the type. For each entry/family we
7170       --  add an expression to the aggregate which is the initial value of
7171       --  this array. The array is declared after all protected subprograms.
7172
7173       if Has_Entries (Prottyp) then
7174          Entries_Aggr :=
7175            Make_Aggregate (Loc, Expressions => New_List);
7176
7177       else
7178          Entries_Aggr := Empty;
7179       end if;
7180
7181       --  Build two new procedure specifications for each protected subprogram;
7182       --  one to call from outside the object and one to call from inside.
7183       --  Build a barrier function and an entry body action procedure
7184       --  specification for each protected entry. Initialize the entry body
7185       --  array. If subprogram is flagged as eliminated, do not generate any
7186       --  internal operations.
7187
7188       E_Count := 0;
7189
7190       Comp := First (Visible_Declarations (Pdef));
7191
7192       while Present (Comp) loop
7193          if Nkind (Comp) = N_Subprogram_Declaration
7194            and then not Is_Eliminated (Defining_Entity (Comp))
7195          then
7196             Sub :=
7197               Make_Subprogram_Declaration (Loc,
7198                 Specification =>
7199                   Build_Protected_Sub_Specification
7200                     (Comp, Prottyp, Unprotected_Mode));
7201
7202             Insert_After (Current_Node, Sub);
7203             Analyze (Sub);
7204
7205             Set_Protected_Body_Subprogram
7206               (Defining_Unit_Name (Specification (Comp)),
7207                Defining_Unit_Name (Specification (Sub)));
7208
7209             --  Make the protected version of the subprogram available for
7210             --  expansion of external calls.
7211
7212             Current_Node := Sub;
7213
7214             Sub :=
7215               Make_Subprogram_Declaration (Loc,
7216                 Specification =>
7217                   Build_Protected_Sub_Specification
7218                     (Comp, Prottyp, Protected_Mode));
7219
7220             Insert_After (Current_Node, Sub);
7221             Analyze (Sub);
7222
7223             Current_Node := Sub;
7224
7225             --  Generate an overriding primitive operation specification for
7226             --  this subprogram if the protected type implements an inerface.
7227
7228             if Ada_Version >= Ada_05
7229               and then
7230                 Present (Abstract_Interfaces
7231                           (Corresponding_Record_Type (Prottyp)))
7232             then
7233                Sub :=
7234                  Make_Subprogram_Declaration (Loc,
7235                    Specification =>
7236                      Build_Protected_Sub_Specification
7237                        (Comp, Prottyp, Dispatching_Mode));
7238
7239                Insert_After (Current_Node, Sub);
7240                Analyze (Sub);
7241
7242                Current_Node := Sub;
7243             end if;
7244
7245             --  If a pragma Interrupt_Handler applies, build and add a call to
7246             --  Register_Interrupt_Handler to the freezing actions of the
7247             --  protected version (Current_Node) of the subprogram:
7248
7249             --    system.interrupts.register_interrupt_handler
7250             --       (prot_procP'address);
7251
7252             if not Restricted_Profile
7253               and then Is_Interrupt_Handler
7254                          (Defining_Unit_Name (Specification (Comp)))
7255             then
7256                Register_Handler;
7257             end if;
7258
7259          elsif Nkind (Comp) = N_Entry_Declaration then
7260             E_Count := E_Count + 1;
7261             Comp_Id := Defining_Identifier (Comp);
7262             Set_Privals_Chain (Comp_Id, New_Elmt_List);
7263             Edef :=
7264               Make_Defining_Identifier (Loc,
7265                 Build_Selected_Name (Prottyp, Comp_Id, 'E'));
7266             Sub :=
7267               Make_Subprogram_Declaration (Loc,
7268                 Specification =>
7269                   Build_Protected_Entry_Specification (Edef, Comp_Id, Loc));
7270
7271             Insert_After (Current_Node, Sub);
7272             Analyze (Sub);
7273
7274             Set_Protected_Body_Subprogram (
7275               Defining_Identifier (Comp),
7276               Defining_Unit_Name (Specification (Sub)));
7277
7278             Current_Node := Sub;
7279
7280             Bdef :=
7281               Make_Defining_Identifier (Loc,
7282                 Build_Selected_Name (Prottyp, Comp_Id, 'B'));
7283             Sub :=
7284               Make_Subprogram_Declaration (Loc,
7285                 Specification =>
7286                   Build_Barrier_Function_Specification (Bdef, Loc));
7287
7288             Insert_After (Current_Node, Sub);
7289             Analyze (Sub);
7290             Set_Protected_Body_Subprogram (Bdef, Bdef);
7291             Set_Barrier_Function (Comp_Id, Bdef);
7292             Set_Scope (Bdef, Scope (Comp_Id));
7293             Current_Node := Sub;
7294
7295             --  Collect pointers to the protected subprogram and the barrier
7296             --  of the current entry, for insertion into Entry_Bodies_Array.
7297
7298             Append (
7299               Make_Aggregate (Loc,
7300                 Expressions => New_List (
7301                   Make_Attribute_Reference (Loc,
7302                     Prefix => New_Reference_To (Bdef, Loc),
7303                     Attribute_Name => Name_Unrestricted_Access),
7304                   Make_Attribute_Reference (Loc,
7305                     Prefix => New_Reference_To (Edef, Loc),
7306                     Attribute_Name => Name_Unrestricted_Access))),
7307               Expressions (Entries_Aggr));
7308
7309          end if;
7310
7311          Next (Comp);
7312       end loop;
7313
7314       --  If there are some private entry declarations, expand it as if they
7315       --  were visible entries.
7316
7317       if Present (Private_Declarations (Pdef)) then
7318          Comp := First (Private_Declarations (Pdef));
7319          while Present (Comp) loop
7320             if Nkind (Comp) = N_Entry_Declaration then
7321                E_Count := E_Count + 1;
7322                Comp_Id := Defining_Identifier (Comp);
7323                Set_Privals_Chain (Comp_Id, New_Elmt_List);
7324                Edef :=
7325                  Make_Defining_Identifier (Loc,
7326                   Build_Selected_Name (Prottyp, Comp_Id, 'E'));
7327
7328                Sub :=
7329                  Make_Subprogram_Declaration (Loc,
7330                    Specification =>
7331                      Build_Protected_Entry_Specification (Edef, Comp_Id, Loc));
7332
7333                Insert_After (Current_Node, Sub);
7334                Analyze (Sub);
7335
7336                Set_Protected_Body_Subprogram (
7337                  Defining_Identifier (Comp),
7338                  Defining_Unit_Name (Specification (Sub)));
7339
7340                Current_Node := Sub;
7341
7342                Bdef :=
7343                  Make_Defining_Identifier (Loc,
7344                     Build_Selected_Name (Prottyp, Comp_Id, 'E'));
7345
7346                Sub :=
7347                  Make_Subprogram_Declaration (Loc,
7348                    Specification =>
7349                      Build_Barrier_Function_Specification (Bdef, Loc));
7350
7351                Insert_After (Current_Node, Sub);
7352                Analyze (Sub);
7353                Set_Protected_Body_Subprogram (Bdef, Bdef);
7354                Set_Barrier_Function (Comp_Id, Bdef);
7355                Set_Scope (Bdef, Scope (Comp_Id));
7356                Current_Node := Sub;
7357
7358                --  Collect pointers to the protected subprogram and the barrier
7359                --  of the current entry, for insertion into Entry_Bodies_Array.
7360
7361                Append (
7362                  Make_Aggregate (Loc,
7363                    Expressions => New_List (
7364                      Make_Attribute_Reference (Loc,
7365                        Prefix => New_Reference_To (Bdef, Loc),
7366                        Attribute_Name => Name_Unrestricted_Access),
7367                      Make_Attribute_Reference (Loc,
7368                        Prefix => New_Reference_To (Edef, Loc),
7369                        Attribute_Name => Name_Unrestricted_Access))),
7370                  Expressions (Entries_Aggr));
7371             end if;
7372
7373             Next (Comp);
7374          end loop;
7375       end if;
7376
7377       --  Emit declaration for Entry_Bodies_Array, now that the addresses of
7378       --  all protected subprograms have been collected.
7379
7380       if Has_Entries (Prottyp) then
7381          Body_Id := Make_Defining_Identifier (Sloc (Prottyp),
7382            New_External_Name (Chars (Prottyp), 'A'));
7383
7384          if Abort_Allowed
7385            or else Restriction_Active (No_Entry_Queue) = False
7386            or else E_Count > 1
7387            or else (Has_Attach_Handler (Prottyp)
7388                      and then not Restricted_Profile)
7389          then
7390             Body_Arr := Make_Object_Declaration (Loc,
7391               Defining_Identifier => Body_Id,
7392               Aliased_Present => True,
7393               Object_Definition =>
7394                 Make_Subtype_Indication (Loc,
7395                   Subtype_Mark => New_Reference_To (
7396                     RTE (RE_Protected_Entry_Body_Array), Loc),
7397                   Constraint =>
7398                     Make_Index_Or_Discriminant_Constraint (Loc,
7399                       Constraints => New_List (
7400                          Make_Range (Loc,
7401                            Make_Integer_Literal (Loc, 1),
7402                            Make_Integer_Literal (Loc, E_Count))))),
7403               Expression => Entries_Aggr);
7404
7405          else
7406             Body_Arr := Make_Object_Declaration (Loc,
7407               Defining_Identifier => Body_Id,
7408               Aliased_Present => True,
7409               Object_Definition => New_Reference_To (RTE (RE_Entry_Body), Loc),
7410               Expression =>
7411                 Make_Aggregate (Loc,
7412                   Expressions => New_List (
7413                     Make_Attribute_Reference (Loc,
7414                       Prefix => New_Reference_To (Bdef, Loc),
7415                       Attribute_Name => Name_Unrestricted_Access),
7416                     Make_Attribute_Reference (Loc,
7417                       Prefix => New_Reference_To (Edef, Loc),
7418                       Attribute_Name => Name_Unrestricted_Access))));
7419          end if;
7420
7421          --  A pointer to this array will be placed in the corresponding record
7422          --  by its initialization procedure so this needs to be analyzed here.
7423
7424          Insert_After (Current_Node, Body_Arr);
7425          Current_Node := Body_Arr;
7426          Analyze (Body_Arr);
7427
7428          Set_Entry_Bodies_Array (Prottyp, Body_Id);
7429
7430          --  Finally, build the function that maps an entry index into the
7431          --  corresponding body. A pointer to this function is placed in each
7432          --  object of the type. Except for a ravenscar-like profile (no abort,
7433          --  no entry queue, 1 entry)
7434
7435          if Abort_Allowed
7436            or else Restriction_Active (No_Entry_Queue) = False
7437            or else E_Count > 1
7438            or else (Has_Attach_Handler (Prottyp)
7439                      and then not Restricted_Profile)
7440          then
7441             Sub :=
7442               Make_Subprogram_Declaration (Loc,
7443                 Specification => Build_Find_Body_Index_Spec (Prottyp));
7444             Insert_After (Current_Node, Sub);
7445             Analyze (Sub);
7446          end if;
7447       end if;
7448    end Expand_N_Protected_Type_Declaration;
7449
7450    --------------------------------
7451    -- Expand_N_Requeue_Statement --
7452    --------------------------------
7453
7454    --  A requeue statement is expanded into one of four GNARLI operations,
7455    --  depending on the source and destination (task or protected object). In
7456    --  addition, code must be generated to jump around the remainder of
7457    --  processing for the original entry and, if the destination is (different)
7458    --  protected object, to attempt to service it. The following illustrates
7459    --  the various cases:
7460
7461    --  procedure entE
7462    --    (O : System.Address;
7463    --     P : System.Address;
7464    --     E : Protected_Entry_Index)
7465    --  is
7466    --     <discriminant renamings>
7467    --     <private object renamings>
7468    --     type poVP is access poV;
7469    --     _Object : ptVP := ptVP!(O);
7470
7471    --  begin
7472    --     begin
7473    --        <start of statement sequence for entry>
7474
7475    --        -- Requeue from one protected entry body to another protected
7476    --        -- entry.
7477
7478    --        Requeue_Protected_Entry (
7479    --          _object._object'Access,
7480    --          new._object'Access,
7481    --          E,
7482    --          Abort_Present);
7483    --        return;
7484
7485    --        <some more of the statement sequence for entry>
7486
7487    --        --  Requeue from an entry body to a task entry
7488
7489    --        Requeue_Protected_To_Task_Entry (
7490    --          New._task_id,
7491    --          E,
7492    --          Abort_Present);
7493    --        return;
7494
7495    --        <rest of statement sequence for entry>
7496    --        Complete_Entry_Body (_Object._Object);
7497
7498    --     exception
7499    --        when all others =>
7500    --           Exceptional_Complete_Entry_Body (
7501    --             _Object._Object, Get_GNAT_Exception);
7502    --     end;
7503    --  end entE;
7504
7505    --  Requeue of a task entry call to a task entry
7506
7507    --  Accept_Call (E, Ann);
7508    --     <start of statement sequence for accept statement>
7509    --     Requeue_Task_Entry (New._task_id, E, Abort_Present);
7510    --     goto Lnn;
7511    --     <rest of statement sequence for accept statement>
7512    --     <<Lnn>>
7513    --     Complete_Rendezvous;
7514
7515    --  exception
7516    --     when all others =>
7517    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
7518
7519    --  Requeue of a task entry call to a protected entry
7520
7521    --  Accept_Call (E, Ann);
7522    --     <start of statement sequence for accept statement>
7523    --     Requeue_Task_To_Protected_Entry (
7524    --       new._object'Access,
7525    --       E,
7526    --       Abort_Present);
7527    --     newS (new, Pnn);
7528    --     goto Lnn;
7529    --     <rest of statement sequence for accept statement>
7530    --     <<Lnn>>
7531    --     Complete_Rendezvous;
7532
7533    --  exception
7534    --     when all others =>
7535    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
7536
7537    --  Further details on these expansions can be found in
7538    --  Expand_N_Protected_Body and Expand_N_Accept_Statement.
7539
7540    procedure Expand_N_Requeue_Statement (N : Node_Id) is
7541       Loc        : constant Source_Ptr := Sloc (N);
7542       Acc_Stat   : Node_Id;
7543       Concval    : Node_Id;
7544       Ename      : Node_Id;
7545       Index      : Node_Id;
7546       Conctyp    : Entity_Id;
7547       Oldtyp     : Entity_Id;
7548       Lab_Node   : Node_Id;
7549       Rcall      : Node_Id;
7550       Abortable  : Node_Id;
7551       Skip_Stat  : Node_Id;
7552       Self_Param : Node_Id;
7553       New_Param  : Node_Id;
7554       Params     : List_Id;
7555       RTS_Call   : Entity_Id;
7556
7557    begin
7558       Abortable :=
7559         New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc);
7560
7561       --  Set up the target object
7562
7563       Extract_Entry (N, Concval, Ename, Index);
7564       Conctyp := Etype (Concval);
7565       New_Param := Concurrent_Ref (Concval);
7566
7567       --  The target entry index and abortable flag are the same for all cases
7568
7569       Params := New_List (
7570         Entry_Index_Expression (Loc, Entity (Ename), Index, Conctyp),
7571         Abortable);
7572
7573       --  Determine proper GNARLI call and required additional parameters
7574       --  Loop to find nearest enclosing task type or protected type
7575
7576       Oldtyp := Current_Scope;
7577       loop
7578          if Is_Task_Type (Oldtyp) then
7579             if Is_Task_Type (Conctyp) then
7580                RTS_Call := RTE (RE_Requeue_Task_Entry);
7581
7582             else
7583                pragma Assert (Is_Protected_Type (Conctyp));
7584                RTS_Call := RTE (RE_Requeue_Task_To_Protected_Entry);
7585                New_Param :=
7586                  Make_Attribute_Reference (Loc,
7587                    Prefix => New_Param,
7588                    Attribute_Name => Name_Unchecked_Access);
7589             end if;
7590
7591             Prepend (New_Param, Params);
7592             exit;
7593
7594          elsif Is_Protected_Type (Oldtyp) then
7595             Self_Param :=
7596               Make_Attribute_Reference (Loc,
7597                 Prefix => Concurrent_Ref (New_Occurrence_Of (Oldtyp, Loc)),
7598                 Attribute_Name => Name_Unchecked_Access);
7599
7600             if Is_Task_Type (Conctyp) then
7601                RTS_Call := RTE (RE_Requeue_Protected_To_Task_Entry);
7602
7603             else
7604                pragma Assert (Is_Protected_Type (Conctyp));
7605                RTS_Call := RTE (RE_Requeue_Protected_Entry);
7606                New_Param :=
7607                  Make_Attribute_Reference (Loc,
7608                    Prefix => New_Param,
7609                    Attribute_Name => Name_Unchecked_Access);
7610             end if;
7611
7612             Prepend (New_Param, Params);
7613             Prepend (Self_Param, Params);
7614             exit;
7615
7616          --  If neither task type or protected type, must be in some inner
7617          --  enclosing block, so move on out
7618
7619          else
7620             Oldtyp := Scope (Oldtyp);
7621          end if;
7622       end loop;
7623
7624       --  Create the GNARLI call
7625
7626       Rcall := Make_Procedure_Call_Statement (Loc,
7627         Name =>
7628           New_Occurrence_Of (RTS_Call, Loc),
7629         Parameter_Associations => Params);
7630
7631       Rewrite (N, Rcall);
7632       Analyze (N);
7633
7634       if Is_Protected_Type (Oldtyp) then
7635
7636          --  Build the return statement to skip the rest of the entry body
7637
7638          Skip_Stat := Make_Return_Statement (Loc);
7639
7640       else
7641          --  If the requeue is within a task, find the end label of the
7642          --  enclosing accept statement.
7643
7644          Acc_Stat := Parent (N);
7645          while Nkind (Acc_Stat) /= N_Accept_Statement loop
7646             Acc_Stat := Parent (Acc_Stat);
7647          end loop;
7648
7649          --  The last statement is the second label, used for completing the
7650          --  rendezvous the usual way. The label we are looking for is right
7651          --  before it.
7652
7653          Lab_Node :=
7654            Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat))));
7655
7656          pragma Assert (Nkind (Lab_Node) = N_Label);
7657
7658          --  Build the goto statement to skip the rest of the accept
7659          --  statement.
7660
7661          Skip_Stat :=
7662            Make_Goto_Statement (Loc,
7663              Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc));
7664       end if;
7665
7666       Set_Analyzed (Skip_Stat);
7667
7668       Insert_After (N, Skip_Stat);
7669    end Expand_N_Requeue_Statement;
7670
7671    -------------------------------
7672    -- Expand_N_Selective_Accept --
7673    -------------------------------
7674
7675    procedure Expand_N_Selective_Accept (N : Node_Id) is
7676       Loc            : constant Source_Ptr := Sloc (N);
7677       Alts           : constant List_Id    := Select_Alternatives (N);
7678
7679       --  Note: in the below declarations a lot of new lists are allocated
7680       --  unconditionally which may well not end up being used. That's
7681       --  not a good idea since it wastes space gratuitously ???
7682
7683       Accept_Case    : List_Id;
7684       Accept_List    : constant List_Id := New_List;
7685
7686       Alt            : Node_Id;
7687       Alt_List       : constant List_Id := New_List;
7688       Alt_Stats      : List_Id;
7689       Ann            : Entity_Id := Empty;
7690
7691       Block          : Node_Id;
7692       Check_Guard    : Boolean := True;
7693
7694       Decls          : constant List_Id := New_List;
7695       Stats          : constant List_Id := New_List;
7696       Body_List      : constant List_Id := New_List;
7697       Trailing_List  : constant List_Id := New_List;
7698
7699       Choices        : List_Id;
7700       Else_Present   : Boolean := False;
7701       Terminate_Alt  : Node_Id := Empty;
7702       Select_Mode    : Node_Id;
7703
7704       Delay_Case     : List_Id;
7705       Delay_Count    : Integer := 0;
7706       Delay_Val      : Entity_Id;
7707       Delay_Index    : Entity_Id;
7708       Delay_Min      : Entity_Id;
7709       Delay_Num      : Int := 1;
7710       Delay_Alt_List : List_Id := New_List;
7711       Delay_List     : constant List_Id := New_List;
7712       D              : Entity_Id;
7713       M              : Entity_Id;
7714
7715       First_Delay    : Boolean := True;
7716       Guard_Open     : Entity_Id;
7717
7718       End_Lab        : Node_Id;
7719       Index          : Int := 1;
7720       Lab            : Node_Id;
7721       Num_Alts       : Int;
7722       Num_Accept     : Nat := 0;
7723       Proc           : Node_Id;
7724       Q              : Node_Id;
7725       Time_Type      : Entity_Id;
7726       X              : Node_Id;
7727       Select_Call    : Node_Id;
7728
7729       Qnam : constant Entity_Id :=
7730                Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
7731
7732       Xnam : constant Entity_Id :=
7733                Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
7734
7735       -----------------------
7736       -- Local subprograms --
7737       -----------------------
7738
7739       function Accept_Or_Raise return List_Id;
7740       --  For the rare case where delay alternatives all have guards, and
7741       --  all of them are closed, it is still possible that there were open
7742       --  accept alternatives with no callers. We must reexamine the
7743       --  Accept_List, and execute a selective wait with no else if some
7744       --  accept is open. If none, we raise program_error.
7745
7746       procedure Add_Accept (Alt : Node_Id);
7747       --  Process a single accept statement in a select alternative. Build
7748       --  procedure for body of accept, and add entry to dispatch table with
7749       --  expression for guard, in preparation for call to run time select.
7750
7751       function Make_And_Declare_Label (Num : Int) return Node_Id;
7752       --  Manufacture a label using Num as a serial number and declare it.
7753       --  The declaration is appended to Decls. The label marks the trailing
7754       --  statements of an accept or delay alternative.
7755
7756       function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
7757       --  Build call to Selective_Wait runtime routine
7758
7759       procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
7760       --  Add code to compare value of delay with previous values, and
7761       --  generate case entry for trailing statements.
7762
7763       procedure Process_Accept_Alternative
7764         (Alt   : Node_Id;
7765          Index : Int;
7766          Proc  : Node_Id);
7767       --  Add code to call corresponding procedure, and branch to
7768       --  trailing statements, if any.
7769
7770       ---------------------
7771       -- Accept_Or_Raise --
7772       ---------------------
7773
7774       function Accept_Or_Raise return List_Id is
7775          Cond  : Node_Id;
7776          Stats : List_Id;
7777          J     : constant Entity_Id := Make_Defining_Identifier (Loc,
7778                                                   New_Internal_Name ('J'));
7779
7780       begin
7781          --  We generate the following:
7782
7783          --    for J in q'range loop
7784          --       if q(J).S /=null_task_entry then
7785          --          selective_wait (simple_mode,...);
7786          --          done := True;
7787          --          exit;
7788          --       end if;
7789          --    end loop;
7790          --
7791          --    if no rendez_vous then
7792          --       raise program_error;
7793          --    end if;
7794
7795          --    Note that the code needs to know that the selector name
7796          --    in an Accept_Alternative is named S.
7797
7798          Cond := Make_Op_Ne (Loc,
7799            Left_Opnd =>
7800              Make_Selected_Component (Loc,
7801                Prefix => Make_Indexed_Component (Loc,
7802                  Prefix => New_Reference_To (Qnam, Loc),
7803                    Expressions => New_List (New_Reference_To (J, Loc))),
7804              Selector_Name => Make_Identifier (Loc, Name_S)),
7805            Right_Opnd =>
7806              New_Reference_To (RTE (RE_Null_Task_Entry), Loc));
7807
7808          Stats := New_List (
7809            Make_Implicit_Loop_Statement (N,
7810              Identifier => Empty,
7811              Iteration_Scheme =>
7812                Make_Iteration_Scheme (Loc,
7813                  Loop_Parameter_Specification =>
7814                    Make_Loop_Parameter_Specification (Loc,
7815                      Defining_Identifier => J,
7816                      Discrete_Subtype_Definition =>
7817                        Make_Attribute_Reference (Loc,
7818                          Prefix => New_Reference_To (Qnam, Loc),
7819                          Attribute_Name => Name_Range,
7820                          Expressions => New_List (
7821                            Make_Integer_Literal (Loc, 1))))),
7822
7823              Statements => New_List (
7824                Make_Implicit_If_Statement (N,
7825                  Condition =>  Cond,
7826                  Then_Statements => New_List (
7827                    Make_Select_Call (
7828                     New_Reference_To (RTE (RE_Simple_Mode), Loc)),
7829                    Make_Exit_Statement (Loc))))));
7830
7831          Append_To (Stats,
7832            Make_Raise_Program_Error (Loc,
7833              Condition => Make_Op_Eq (Loc,
7834                Left_Opnd  => New_Reference_To (Xnam, Loc),
7835                Right_Opnd =>
7836                  New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
7837              Reason => PE_All_Guards_Closed));
7838
7839          return Stats;
7840       end Accept_Or_Raise;
7841
7842       ----------------
7843       -- Add_Accept --
7844       ----------------
7845
7846       procedure Add_Accept (Alt : Node_Id) is
7847          Acc_Stm   : constant Node_Id    := Accept_Statement (Alt);
7848          Ename     : constant Node_Id    := Entry_Direct_Name (Acc_Stm);
7849          Eent      : constant Entity_Id  := Entity (Ename);
7850          Index     : constant Node_Id    := Entry_Index (Acc_Stm);
7851          Null_Body : Node_Id;
7852          Proc_Body : Node_Id;
7853          PB_Ent    : Entity_Id;
7854          Expr      : Node_Id;
7855          Call      : Node_Id;
7856
7857       begin
7858          if No (Ann) then
7859             Ann := Node (Last_Elmt (Accept_Address (Eent)));
7860          end if;
7861
7862          if Present (Condition (Alt)) then
7863             Expr :=
7864               Make_Conditional_Expression (Loc, New_List (
7865                 Condition (Alt),
7866                 Entry_Index_Expression (Loc, Eent, Index, Scope (Eent)),
7867                 New_Reference_To (RTE (RE_Null_Task_Entry), Loc)));
7868          else
7869             Expr :=
7870               Entry_Index_Expression
7871                 (Loc, Eent, Index, Scope (Eent));
7872          end if;
7873
7874          if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
7875             Null_Body := New_Reference_To (Standard_False, Loc);
7876
7877             if Abort_Allowed then
7878                Call := Make_Procedure_Call_Statement (Loc,
7879                  Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc));
7880                Insert_Before (First (Statements (Handled_Statement_Sequence (
7881                  Accept_Statement (Alt)))), Call);
7882                Analyze (Call);
7883             end if;
7884
7885             PB_Ent :=
7886               Make_Defining_Identifier (Sloc (Ename),
7887                 New_External_Name (Chars (Ename), 'A', Num_Accept));
7888
7889             Set_Needs_Debug_Info (PB_Ent, Comes_From_Source (Alt));
7890
7891             Proc_Body :=
7892               Make_Subprogram_Body (Loc,
7893                 Specification =>
7894                   Make_Procedure_Specification (Loc,
7895                     Defining_Unit_Name => PB_Ent),
7896                Declarations => Declarations (Acc_Stm),
7897                Handled_Statement_Sequence =>
7898                  Build_Accept_Body (Accept_Statement (Alt)));
7899
7900             --  During the analysis of the body of the accept statement, any
7901             --  zero cost exception handler records were collected in the
7902             --  Accept_Handler_Records field of the N_Accept_Alternative node.
7903             --  This is where we move them to where they belong, namely the
7904             --  newly created procedure.
7905
7906             Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
7907             Append (Proc_Body, Body_List);
7908
7909          else
7910             Null_Body := New_Reference_To (Standard_True,  Loc);
7911
7912             --  if accept statement has declarations, insert above, given that
7913             --  we are not creating a body for the accept.
7914
7915             if Present (Declarations (Acc_Stm)) then
7916                Insert_Actions (N, Declarations (Acc_Stm));
7917             end if;
7918          end if;
7919
7920          Append_To (Accept_List,
7921            Make_Aggregate (Loc, Expressions => New_List (Null_Body, Expr)));
7922
7923          Num_Accept := Num_Accept + 1;
7924       end Add_Accept;
7925
7926       ----------------------------
7927       -- Make_And_Declare_Label --
7928       ----------------------------
7929
7930       function Make_And_Declare_Label (Num : Int) return Node_Id is
7931          Lab_Id : Node_Id;
7932
7933       begin
7934          Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
7935          Lab :=
7936            Make_Label (Loc, Lab_Id);
7937
7938          Append_To (Decls,
7939            Make_Implicit_Label_Declaration (Loc,
7940              Defining_Identifier  =>
7941                Make_Defining_Identifier (Loc, Chars (Lab_Id)),
7942              Label_Construct => Lab));
7943
7944          return Lab;
7945       end Make_And_Declare_Label;
7946
7947       ----------------------
7948       -- Make_Select_Call --
7949       ----------------------
7950
7951       function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
7952          Params : constant List_Id := New_List;
7953
7954       begin
7955          Append (
7956            Make_Attribute_Reference (Loc,
7957              Prefix => New_Reference_To (Qnam, Loc),
7958              Attribute_Name => Name_Unchecked_Access),
7959            Params);
7960          Append (Select_Mode, Params);
7961          Append (New_Reference_To (Ann, Loc), Params);
7962          Append (New_Reference_To (Xnam, Loc), Params);
7963
7964          return
7965            Make_Procedure_Call_Statement (Loc,
7966              Name => New_Reference_To (RTE (RE_Selective_Wait), Loc),
7967              Parameter_Associations => Params);
7968       end Make_Select_Call;
7969
7970       --------------------------------
7971       -- Process_Accept_Alternative --
7972       --------------------------------
7973
7974       procedure Process_Accept_Alternative
7975         (Alt   : Node_Id;
7976          Index : Int;
7977          Proc  : Node_Id)
7978       is
7979          Choices   : List_Id := No_List;
7980          Alt_Stats : List_Id;
7981
7982       begin
7983          Adjust_Condition (Condition (Alt));
7984          Alt_Stats := No_List;
7985
7986          if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
7987             Choices := New_List (
7988               Make_Integer_Literal (Loc, Index));
7989
7990             Alt_Stats := New_List (
7991               Make_Procedure_Call_Statement (Loc,
7992                 Name => New_Reference_To (
7993                   Defining_Unit_Name (Specification (Proc)), Loc)));
7994          end if;
7995
7996          if Statements (Alt) /= Empty_List then
7997
7998             if No (Alt_Stats) then
7999
8000                --  Accept with no body, followed by trailing statements
8001
8002                Choices := New_List (
8003                  Make_Integer_Literal (Loc, Index));
8004
8005                Alt_Stats := New_List;
8006             end if;
8007
8008             --  After the call, if any, branch to to trailing statements. We
8009             --  create a label for each, as well as the corresponding label
8010             --  declaration.
8011
8012             Lab := Make_And_Declare_Label (Index);
8013             Append_To (Alt_Stats,
8014               Make_Goto_Statement (Loc,
8015                 Name => New_Copy (Identifier (Lab))));
8016
8017             Append (Lab, Trailing_List);
8018             Append_List (Statements (Alt), Trailing_List);
8019             Append_To (Trailing_List,
8020               Make_Goto_Statement (Loc,
8021                 Name => New_Copy (Identifier (End_Lab))));
8022          end if;
8023
8024          if Present (Alt_Stats) then
8025
8026             --  Procedure call. and/or trailing statements
8027
8028             Append_To (Alt_List,
8029               Make_Case_Statement_Alternative (Loc,
8030                 Discrete_Choices => Choices,
8031                 Statements => Alt_Stats));
8032          end if;
8033       end Process_Accept_Alternative;
8034
8035       -------------------------------
8036       -- Process_Delay_Alternative --
8037       -------------------------------
8038
8039       procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
8040          Choices   : List_Id;
8041          Cond      : Node_Id;
8042          Delay_Alt : List_Id;
8043
8044       begin
8045          --  Deal with C/Fortran boolean as delay condition
8046
8047          Adjust_Condition (Condition (Alt));
8048
8049          --  Determine the smallest specified delay
8050
8051          --  for each delay alternative generate:
8052
8053          --    if guard-expression then
8054          --       Delay_Val  := delay-expression;
8055          --       Guard_Open := True;
8056          --       if Delay_Val < Delay_Min then
8057          --          Delay_Min   := Delay_Val;
8058          --          Delay_Index := Index;
8059          --       end if;
8060          --    end if;
8061
8062          --  The enclosing if-statement is omitted if there is no guard
8063
8064          if Delay_Count = 1
8065            or else First_Delay
8066          then
8067             First_Delay := False;
8068
8069             Delay_Alt := New_List (
8070               Make_Assignment_Statement (Loc,
8071                 Name => New_Reference_To (Delay_Min, Loc),
8072                 Expression => Expression (Delay_Statement (Alt))));
8073
8074             if Delay_Count > 1 then
8075                Append_To (Delay_Alt,
8076                  Make_Assignment_Statement (Loc,
8077                    Name       => New_Reference_To (Delay_Index, Loc),
8078                    Expression => Make_Integer_Literal (Loc, Index)));
8079             end if;
8080
8081          else
8082             Delay_Alt := New_List (
8083               Make_Assignment_Statement (Loc,
8084                 Name => New_Reference_To (Delay_Val, Loc),
8085                 Expression => Expression (Delay_Statement (Alt))));
8086
8087             if Time_Type = Standard_Duration then
8088                Cond :=
8089                   Make_Op_Lt (Loc,
8090                     Left_Opnd  => New_Reference_To (Delay_Val, Loc),
8091                     Right_Opnd => New_Reference_To (Delay_Min, Loc));
8092
8093             else
8094                --  The scope of the time type must define a comparison
8095                --  operator. The scope itself may not be visible, so we
8096                --  construct a node with entity information to insure that
8097                --  semantic analysis can find the proper operator.
8098
8099                Cond :=
8100                  Make_Function_Call (Loc,
8101                    Name => Make_Selected_Component (Loc,
8102                      Prefix => New_Reference_To (Scope (Time_Type), Loc),
8103                      Selector_Name =>
8104                        Make_Operator_Symbol (Loc,
8105                          Chars => Name_Op_Lt,
8106                          Strval => No_String)),
8107                     Parameter_Associations =>
8108                       New_List (
8109                         New_Reference_To (Delay_Val, Loc),
8110                         New_Reference_To (Delay_Min, Loc)));
8111
8112                Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
8113             end if;
8114
8115             Append_To (Delay_Alt,
8116               Make_Implicit_If_Statement (N,
8117                 Condition => Cond,
8118                 Then_Statements => New_List (
8119                   Make_Assignment_Statement (Loc,
8120                     Name       => New_Reference_To (Delay_Min, Loc),
8121                     Expression => New_Reference_To (Delay_Val, Loc)),
8122
8123                   Make_Assignment_Statement (Loc,
8124                     Name       => New_Reference_To (Delay_Index, Loc),
8125                     Expression => Make_Integer_Literal (Loc, Index)))));
8126          end if;
8127
8128          if Check_Guard then
8129             Append_To (Delay_Alt,
8130               Make_Assignment_Statement (Loc,
8131                 Name => New_Reference_To (Guard_Open, Loc),
8132                 Expression => New_Reference_To (Standard_True, Loc)));
8133          end if;
8134
8135          if Present (Condition (Alt)) then
8136             Delay_Alt := New_List (
8137               Make_Implicit_If_Statement (N,
8138                 Condition => Condition (Alt),
8139                 Then_Statements => Delay_Alt));
8140          end if;
8141
8142          Append_List (Delay_Alt, Delay_List);
8143
8144          --  If the delay alternative has a statement part, add choice to the
8145          --  case statements for delays.
8146
8147          if Present (Statements (Alt)) then
8148
8149             if Delay_Count = 1 then
8150                Append_List (Statements (Alt), Delay_Alt_List);
8151
8152             else
8153                Choices := New_List (
8154                  Make_Integer_Literal (Loc, Index));
8155
8156                Append_To (Delay_Alt_List,
8157                  Make_Case_Statement_Alternative (Loc,
8158                    Discrete_Choices => Choices,
8159                    Statements => Statements (Alt)));
8160             end if;
8161
8162          elsif Delay_Count = 1 then
8163
8164             --  If the single delay has no trailing statements, add a branch
8165             --  to the exit label to the selective wait.
8166
8167             Delay_Alt_List := New_List (
8168               Make_Goto_Statement (Loc,
8169                 Name => New_Copy (Identifier (End_Lab))));
8170
8171          end if;
8172       end Process_Delay_Alternative;
8173
8174    --  Start of processing for Expand_N_Selective_Accept
8175
8176    begin
8177       --  First insert some declarations before the select. The first is:
8178
8179       --    Ann : Address
8180
8181       --  This variable holds the parameters passed to the accept body. This
8182       --  declaration has already been inserted by the time we get here by
8183       --  a call to Expand_Accept_Declarations made from the semantics when
8184       --  processing the first accept statement contained in the select. We
8185       --  can find this entity as Accept_Address (E), where E is any of the
8186       --  entries references by contained accept statements.
8187
8188       --  The first step is to scan the list of Selective_Accept_Statements
8189       --  to find this entity, and also count the number of accepts, and
8190       --  determine if terminated, delay or else is present:
8191
8192       Num_Alts := 0;
8193
8194       Alt := First (Alts);
8195       while Present (Alt) loop
8196
8197          if Nkind (Alt) = N_Accept_Alternative then
8198             Add_Accept (Alt);
8199
8200          elsif Nkind (Alt) = N_Delay_Alternative then
8201             Delay_Count   := Delay_Count + 1;
8202
8203             --  If the delays are relative delays, the delay expressions have
8204             --  type Standard_Duration. Otherwise they must have some time type
8205             --  recognized by GNAT.
8206
8207             if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
8208                Time_Type := Standard_Duration;
8209             else
8210                Time_Type := Etype (Expression (Delay_Statement (Alt)));
8211
8212                if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
8213                  or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
8214                then
8215                   null;
8216                else
8217                   Error_Msg_NE (
8218                     "& is not a time type ('R'M 9.6(6))",
8219                        Expression (Delay_Statement (Alt)), Time_Type);
8220                   Time_Type := Standard_Duration;
8221                   Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
8222                end if;
8223             end if;
8224
8225             if No (Condition (Alt)) then
8226
8227                --  This guard will always be open
8228
8229                Check_Guard := False;
8230             end if;
8231
8232          elsif Nkind (Alt) = N_Terminate_Alternative then
8233             Adjust_Condition (Condition (Alt));
8234             Terminate_Alt := Alt;
8235          end if;
8236
8237          Num_Alts := Num_Alts + 1;
8238          Next (Alt);
8239       end loop;
8240
8241       Else_Present := Present (Else_Statements (N));
8242
8243       --  At the same time (see procedure Add_Accept) we build the accept list:
8244
8245       --    Qnn : Accept_List (1 .. num-select) := (
8246       --          (null-body, entry-index),
8247       --          (null-body, entry-index),
8248       --          ..
8249       --          (null_body, entry-index));
8250
8251       --  In the above declaration, null-body is True if the corresponding
8252       --  accept has no body, and false otherwise. The entry is either the
8253       --  entry index expression if there is no guard, or if a guard is
8254       --  present, then a conditional expression of the form:
8255
8256       --    (if guard then entry-index else Null_Task_Entry)
8257
8258       --  If a guard is statically known to be false, the entry can simply
8259       --  be omitted from the accept list.
8260
8261       Q :=
8262         Make_Object_Declaration (Loc,
8263           Defining_Identifier => Qnam,
8264           Object_Definition =>
8265             New_Reference_To (RTE (RE_Accept_List), Loc),
8266           Aliased_Present => True,
8267
8268           Expression =>
8269              Make_Qualified_Expression (Loc,
8270                Subtype_Mark =>
8271                  New_Reference_To (RTE (RE_Accept_List), Loc),
8272                Expression =>
8273                  Make_Aggregate (Loc, Expressions => Accept_List)));
8274
8275       Append (Q, Decls);
8276
8277       --  Then we declare the variable that holds the index for the accept
8278       --  that will be selected for service:
8279
8280       --    Xnn : Select_Index;
8281
8282       X :=
8283         Make_Object_Declaration (Loc,
8284           Defining_Identifier => Xnam,
8285           Object_Definition =>
8286             New_Reference_To (RTE (RE_Select_Index), Loc),
8287           Expression =>
8288             New_Reference_To (RTE (RE_No_Rendezvous), Loc));
8289
8290       Append (X, Decls);
8291
8292       --  After this follow procedure declarations for each accept body
8293
8294       --    procedure Pnn is
8295       --    begin
8296       --       ...
8297       --    end;
8298
8299       --  where the ... are statements from the corresponding procedure body.
8300       --  No parameters are involved, since the parameters are passed via Ann
8301       --  and the parameter references have already been expanded to be direct
8302       --  references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
8303       --  any embedded tasking statements (which would normally be illegal in
8304       --  procedures, have been converted to calls to the tasking runtime so
8305       --  there is no problem in putting them into procedures.
8306
8307       --  The original accept statement has been expanded into a block in
8308       --  the same fashion as for simple accepts (see Build_Accept_Body).
8309
8310       --  Note: we don't really need to build these procedures for the case
8311       --  where no delay statement is present, but it is just as easy to
8312       --  build them unconditionally, and not significantly inefficient,
8313       --  since if they are short they will be inlined anyway.
8314
8315       --  The procedure declarations have been assembled in Body_List
8316
8317       --  If delays are present, we must compute the required delay.
8318       --  We first generate the declarations:
8319
8320       --    Delay_Index : Boolean := 0;
8321       --    Delay_Min   : Some_Time_Type.Time;
8322       --    Delay_Val   : Some_Time_Type.Time;
8323
8324       --  Delay_Index will be set to the index of the minimum delay, i.e. the
8325       --  active delay that is actually chosen as the basis for the possible
8326       --  delay if an immediate rendez-vous is not possible.
8327
8328       --  In the most common case there is a single delay statement, and this
8329       --  is handled specially.
8330
8331       if Delay_Count > 0 then
8332
8333          --  Generate the required declarations
8334
8335          Delay_Val :=
8336            Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
8337          Delay_Index :=
8338            Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
8339          Delay_Min :=
8340            Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
8341
8342          Append_To (Decls,
8343            Make_Object_Declaration (Loc,
8344              Defining_Identifier => Delay_Val,
8345              Object_Definition   => New_Reference_To (Time_Type, Loc)));
8346
8347          Append_To (Decls,
8348            Make_Object_Declaration (Loc,
8349              Defining_Identifier => Delay_Index,
8350              Object_Definition   => New_Reference_To (Standard_Integer, Loc),
8351              Expression          => Make_Integer_Literal (Loc, 0)));
8352
8353          Append_To (Decls,
8354            Make_Object_Declaration (Loc,
8355              Defining_Identifier => Delay_Min,
8356              Object_Definition   => New_Reference_To (Time_Type, Loc),
8357              Expression          =>
8358                Unchecked_Convert_To (Time_Type,
8359                  Make_Attribute_Reference (Loc,
8360                    Prefix =>
8361                      New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
8362                    Attribute_Name => Name_Last))));
8363
8364          --  Create Duration and Delay_Mode objects used for passing a delay
8365          --  value to RTS
8366
8367          D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
8368          M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
8369
8370          declare
8371             Discr : Entity_Id;
8372
8373          begin
8374             --  Note that these values are defined in s-osprim.ads and must
8375             --  be kept in sync:
8376             --
8377             --     Relative          : constant := 0;
8378             --     Absolute_Calendar : constant := 1;
8379             --     Absolute_RT       : constant := 2;
8380
8381             if Time_Type = Standard_Duration then
8382                Discr := Make_Integer_Literal (Loc, 0);
8383
8384             elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
8385                Discr := Make_Integer_Literal (Loc, 1);
8386
8387             else
8388                pragma Assert
8389                  (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
8390                Discr := Make_Integer_Literal (Loc, 2);
8391             end if;
8392
8393             Append_To (Decls,
8394               Make_Object_Declaration (Loc,
8395                 Defining_Identifier => D,
8396                 Object_Definition =>
8397                   New_Reference_To (Standard_Duration, Loc)));
8398
8399             Append_To (Decls,
8400               Make_Object_Declaration (Loc,
8401                 Defining_Identifier => M,
8402                 Object_Definition   =>
8403                   New_Reference_To (Standard_Integer, Loc),
8404                 Expression          => Discr));
8405          end;
8406
8407          if Check_Guard then
8408             Guard_Open :=
8409               Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
8410
8411             Append_To (Decls,
8412               Make_Object_Declaration (Loc,
8413                  Defining_Identifier => Guard_Open,
8414                  Object_Definition => New_Reference_To (Standard_Boolean, Loc),
8415                  Expression        => New_Reference_To (Standard_False, Loc)));
8416          end if;
8417
8418       --  Delay_Count is zero, don't need M and D set (suppress warning)
8419
8420       else
8421          M := Empty;
8422          D := Empty;
8423       end if;
8424
8425       if Present (Terminate_Alt) then
8426
8427          --  If the terminate alternative guard is False, use
8428          --  Simple_Mode; otherwise use Terminate_Mode.
8429
8430          if Present (Condition (Terminate_Alt)) then
8431             Select_Mode := Make_Conditional_Expression (Loc,
8432               New_List (Condition (Terminate_Alt),
8433                         New_Reference_To (RTE (RE_Terminate_Mode), Loc),
8434                         New_Reference_To (RTE (RE_Simple_Mode), Loc)));
8435          else
8436             Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc);
8437          end if;
8438
8439       elsif Else_Present or Delay_Count > 0 then
8440          Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc);
8441
8442       else
8443          Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc);
8444       end if;
8445
8446       Select_Call := Make_Select_Call (Select_Mode);
8447       Append (Select_Call, Stats);
8448
8449       --  Now generate code to act on the result. There is an entry
8450       --  in this case for each accept statement with a non-null body,
8451       --  followed by a branch to the statements that follow the Accept.
8452       --  In the absence of delay alternatives, we generate:
8453
8454       --    case X is
8455       --      when No_Rendezvous =>  --  omitted if simple mode
8456       --         goto Lab0;
8457
8458       --      when 1 =>
8459       --         P1n;
8460       --         goto Lab1;
8461
8462       --      when 2 =>
8463       --         P2n;
8464       --         goto Lab2;
8465
8466       --      when others =>
8467       --         goto Exit;
8468       --    end case;
8469       --
8470       --    Lab0: Else_Statements;
8471       --    goto exit;
8472
8473       --    Lab1:  Trailing_Statements1;
8474       --    goto Exit;
8475       --
8476       --    Lab2:  Trailing_Statements2;
8477       --    goto Exit;
8478       --    ...
8479       --    Exit:
8480
8481       --  Generate label for common exit
8482
8483       End_Lab := Make_And_Declare_Label (Num_Alts + 1);
8484
8485       --  First entry is the default case, when no rendezvous is possible
8486
8487       Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc));
8488
8489       if Else_Present then
8490
8491          --  If no rendezvous is possible, the else part is executed
8492
8493          Lab := Make_And_Declare_Label (0);
8494          Alt_Stats := New_List (
8495            Make_Goto_Statement (Loc,
8496              Name => New_Copy (Identifier (Lab))));
8497
8498          Append (Lab, Trailing_List);
8499          Append_List (Else_Statements (N), Trailing_List);
8500          Append_To (Trailing_List,
8501            Make_Goto_Statement (Loc,
8502              Name => New_Copy (Identifier (End_Lab))));
8503       else
8504          Alt_Stats := New_List (
8505            Make_Goto_Statement (Loc,
8506              Name => New_Copy (Identifier (End_Lab))));
8507       end if;
8508
8509       Append_To (Alt_List,
8510         Make_Case_Statement_Alternative (Loc,
8511           Discrete_Choices => Choices,
8512           Statements => Alt_Stats));
8513
8514       --  We make use of the fact that Accept_Index is an integer type, and
8515       --  generate successive literals for entries for each accept. Only those
8516       --  for which there is a body or trailing statements get a case entry.
8517
8518       Alt := First (Select_Alternatives (N));
8519       Proc := First (Body_List);
8520       while Present (Alt) loop
8521
8522          if Nkind (Alt) = N_Accept_Alternative then
8523             Process_Accept_Alternative (Alt, Index, Proc);
8524             Index := Index + 1;
8525
8526             if Present
8527               (Handled_Statement_Sequence (Accept_Statement (Alt)))
8528             then
8529                Next (Proc);
8530             end if;
8531
8532          elsif Nkind (Alt) = N_Delay_Alternative then
8533             Process_Delay_Alternative (Alt, Delay_Num);
8534             Delay_Num := Delay_Num + 1;
8535          end if;
8536
8537          Next (Alt);
8538       end loop;
8539
8540       --  An others choice is always added to the main case, as well
8541       --  as the delay case (to satisfy the compiler).
8542
8543       Append_To (Alt_List,
8544         Make_Case_Statement_Alternative (Loc,
8545           Discrete_Choices =>
8546             New_List (Make_Others_Choice (Loc)),
8547           Statements       =>
8548             New_List (Make_Goto_Statement (Loc,
8549               Name => New_Copy (Identifier (End_Lab))))));
8550
8551       Accept_Case := New_List (
8552         Make_Case_Statement (Loc,
8553           Expression   => New_Reference_To (Xnam, Loc),
8554           Alternatives => Alt_List));
8555
8556       Append_List (Trailing_List, Accept_Case);
8557       Append (End_Lab, Accept_Case);
8558       Append_List (Body_List, Decls);
8559
8560       --  Construct case statement for trailing statements of delay
8561       --  alternatives, if there are several of them.
8562
8563       if Delay_Count > 1 then
8564          Append_To (Delay_Alt_List,
8565            Make_Case_Statement_Alternative (Loc,
8566              Discrete_Choices =>
8567                New_List (Make_Others_Choice (Loc)),
8568              Statements       =>
8569                New_List (Make_Null_Statement (Loc))));
8570
8571          Delay_Case := New_List (
8572            Make_Case_Statement (Loc,
8573              Expression   => New_Reference_To (Delay_Index, Loc),
8574              Alternatives => Delay_Alt_List));
8575       else
8576          Delay_Case := Delay_Alt_List;
8577       end if;
8578
8579       --  If there are no delay alternatives, we append the case statement
8580       --  to the statement list.
8581
8582       if Delay_Count = 0 then
8583          Append_List (Accept_Case, Stats);
8584
8585       --  Delay alternatives present
8586
8587       else
8588          --  If delay alternatives are present we generate:
8589
8590          --    find minimum delay.
8591          --    DX := minimum delay;
8592          --    M := <delay mode>;
8593          --    Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
8594          --      DX, MX, X);
8595          --
8596          --    if X = No_Rendezvous then
8597          --      case statement for delay statements.
8598          --    else
8599          --      case statement for accept alternatives.
8600          --    end if;
8601
8602          declare
8603             Cases : Node_Id;
8604             Stmt  : Node_Id;
8605             Parms : List_Id;
8606             Parm  : Node_Id;
8607             Conv  : Node_Id;
8608
8609          begin
8610             --  The type of the delay expression is known to be legal
8611
8612             if Time_Type = Standard_Duration then
8613                Conv := New_Reference_To (Delay_Min, Loc);
8614
8615             elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
8616                Conv := Make_Function_Call (Loc,
8617                  New_Reference_To (RTE (RO_CA_To_Duration), Loc),
8618                  New_List (New_Reference_To (Delay_Min, Loc)));
8619
8620             else
8621                pragma Assert
8622                  (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
8623
8624                Conv := Make_Function_Call (Loc,
8625                  New_Reference_To (RTE (RO_RT_To_Duration), Loc),
8626                  New_List (New_Reference_To (Delay_Min, Loc)));
8627             end if;
8628
8629             Stmt := Make_Assignment_Statement (Loc,
8630               Name => New_Reference_To (D, Loc),
8631               Expression => Conv);
8632
8633             --  Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
8634
8635             Parms := Parameter_Associations (Select_Call);
8636             Parm := First (Parms);
8637
8638             while Present (Parm)
8639               and then Parm /= Select_Mode
8640             loop
8641                Next (Parm);
8642             end loop;
8643
8644             pragma Assert (Present (Parm));
8645             Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc));
8646             Analyze (Parm);
8647
8648             --  Prepare two new parameters of Duration and Delay_Mode type
8649             --  which represent the value and the mode of the minimum delay.
8650
8651             Next (Parm);
8652             Insert_After (Parm, New_Reference_To (M, Loc));
8653             Insert_After (Parm, New_Reference_To (D, Loc));
8654
8655             --  Create a call to RTS
8656
8657             Rewrite (Select_Call,
8658               Make_Procedure_Call_Statement (Loc,
8659                 Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc),
8660                 Parameter_Associations => Parms));
8661
8662             --  This new call should follow the calculation of the minimum
8663             --  delay.
8664
8665             Insert_List_Before (Select_Call, Delay_List);
8666
8667             if Check_Guard then
8668                Stmt :=
8669                  Make_Implicit_If_Statement (N,
8670                    Condition => New_Reference_To (Guard_Open, Loc),
8671                    Then_Statements =>
8672                      New_List (New_Copy_Tree (Stmt),
8673                        New_Copy_Tree (Select_Call)),
8674                    Else_Statements => Accept_Or_Raise);
8675                Rewrite (Select_Call, Stmt);
8676             else
8677                Insert_Before (Select_Call, Stmt);
8678             end if;
8679
8680             Cases :=
8681               Make_Implicit_If_Statement (N,
8682                 Condition => Make_Op_Eq (Loc,
8683                   Left_Opnd  => New_Reference_To (Xnam, Loc),
8684                   Right_Opnd =>
8685                     New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
8686
8687                 Then_Statements => Delay_Case,
8688                 Else_Statements => Accept_Case);
8689
8690             Append (Cases, Stats);
8691          end;
8692       end if;
8693
8694       --  Replace accept statement with appropriate block
8695
8696       Block :=
8697         Make_Block_Statement (Loc,
8698           Declarations => Decls,
8699           Handled_Statement_Sequence =>
8700             Make_Handled_Sequence_Of_Statements (Loc,
8701               Statements => Stats));
8702
8703       Rewrite (N, Block);
8704       Analyze (N);
8705
8706       --  Note: have to worry more about abort deferral in above code ???
8707
8708       --  Final step is to unstack the Accept_Address entries for all accept
8709       --  statements appearing in accept alternatives in the select statement
8710
8711       Alt := First (Alts);
8712       while Present (Alt) loop
8713          if Nkind (Alt) = N_Accept_Alternative then
8714             Remove_Last_Elmt (Accept_Address
8715               (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
8716          end if;
8717
8718          Next (Alt);
8719       end loop;
8720    end Expand_N_Selective_Accept;
8721
8722    --------------------------------------
8723    -- Expand_N_Single_Task_Declaration --
8724    --------------------------------------
8725
8726    --  Single task declarations should never be present after semantic
8727    --  analysis, since we expect them to be replaced by a declaration of an
8728    --  anonymous task type, followed by a declaration of the task object. We
8729    --  include this routine to make sure that is happening!
8730
8731    procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
8732    begin
8733       raise Program_Error;
8734    end Expand_N_Single_Task_Declaration;
8735
8736    ------------------------
8737    -- Expand_N_Task_Body --
8738    ------------------------
8739
8740    --  Given a task body
8741
8742    --    task body tname is
8743    --       <declarations>
8744    --    begin
8745    --       <statements>
8746    --    end x;
8747
8748    --  This expansion routine converts it into a procedure and sets the
8749    --  elaboration flag for the procedure to true, to represent the fact
8750    --  that the task body is now elaborated:
8751
8752    --    procedure tnameB (_Task : access tnameV) is
8753    --       discriminal : dtype renames _Task.discriminant;
8754
8755    --       procedure _clean is
8756    --       begin
8757    --          Abort_Defer.all;
8758    --          Complete_Task;
8759    --          Abort_Undefer.all;
8760    --          return;
8761    --       end _clean;
8762
8763    --    begin
8764    --       Abort_Undefer.all;
8765    --       <declarations>
8766    --       System.Task_Stages.Complete_Activation;
8767    --       <statements>
8768    --    at end
8769    --       _clean;
8770    --    end tnameB;
8771
8772    --    tnameE := True;
8773
8774    --  In addition, if the task body is an activator, then a call to activate
8775    --  tasks is added at the start of the statements, before the call to
8776    --  Complete_Activation, and if in addition the task is a master then it
8777    --  must be established as a master. These calls are inserted and analyzed
8778    --  in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
8779    --  expanded.
8780
8781    --  There is one discriminal declaration line generated for each
8782    --  discriminant that is present to provide an easy reference point for
8783    --  discriminant references inside the body (see Exp_Ch2.Expand_Name).
8784
8785    --  Note on relationship to GNARLI definition. In the GNARLI definition,
8786    --  task body procedures have a profile (Arg : System.Address). That is
8787    --  needed because GNARLI has to use the same access-to-subprogram type
8788    --  for all task types. We depend here on knowing that in GNAT, passing
8789    --  an address argument by value is identical to passing a record value
8790    --  by access (in either case a single pointer is passed), so even though
8791    --  this procedure has the wrong profile. In fact it's all OK, since the
8792    --  callings sequence is identical.
8793
8794    procedure Expand_N_Task_Body (N : Node_Id) is
8795       Loc   : constant Source_Ptr := Sloc (N);
8796       Ttyp  : constant Entity_Id  := Corresponding_Spec (N);
8797       Call  : Node_Id;
8798       New_N : Node_Id;
8799
8800    begin
8801       --  Here we start the expansion by generating discriminal declarations
8802
8803       Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc);
8804
8805       --  Add a call to Abort_Undefer at the very beginning of the task
8806       --  body since this body is called with abort still deferred.
8807
8808       if Abort_Allowed then
8809          Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
8810          Insert_Before
8811            (First (Statements (Handled_Statement_Sequence (N))), Call);
8812          Analyze (Call);
8813       end if;
8814
8815       --  The statement part has already been protected with an at_end and
8816       --  cleanup actions. The call to Complete_Activation must be placed
8817       --  at the head of the sequence of statements of that block. The
8818       --  declarations have been merged in this sequence of statements but
8819       --  the first real statement is accessible from the First_Real_Statement
8820       --  field (which was set for exactly this purpose).
8821
8822       if Restricted_Profile then
8823          Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
8824       else
8825          Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
8826       end if;
8827
8828       Insert_Before
8829         (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
8830       Analyze (Call);
8831
8832       New_N :=
8833         Make_Subprogram_Body (Loc,
8834           Specification => Build_Task_Proc_Specification (Ttyp),
8835           Declarations  => Declarations (N),
8836           Handled_Statement_Sequence => Handled_Statement_Sequence (N));
8837
8838       --  If the task contains generic instantiations, cleanup actions
8839       --  are delayed until after instantiation. Transfer the activation
8840       --  chain to the subprogram, to insure that the activation call is
8841       --  properly generated. It the task body contains inner tasks, indicate
8842       --  that the subprogram is a task master.
8843
8844       if Delay_Cleanups (Ttyp) then
8845          Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
8846          Set_Is_Task_Master  (New_N, Is_Task_Master (N));
8847       end if;
8848
8849       Rewrite (N, New_N);
8850       Analyze (N);
8851
8852       --  Set elaboration flag immediately after task body. If the body is a
8853       --  subunit, the flag is set in the declarative part containing the stub.
8854
8855       if Nkind (Parent (N)) /= N_Subunit then
8856          Insert_After (N,
8857            Make_Assignment_Statement (Loc,
8858              Name =>
8859                Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
8860              Expression => New_Reference_To (Standard_True, Loc)));
8861       end if;
8862
8863       --  Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
8864       --  the task body. At this point the entry specs have been created,
8865       --  frozen and included in the dispatch table for the task type.
8866
8867       pragma Assert (Present (Corresponding_Record_Type (Ttyp)));
8868
8869       if Ada_Version >= Ada_05
8870         and then Present (Task_Definition (Parent (Ttyp)))
8871         and then Present (Abstract_Interfaces
8872                           (Corresponding_Record_Type (Ttyp)))
8873       then
8874          declare
8875             Current_Node : Node_Id;
8876             Vis_Decl     : Node_Id :=
8877               First (Visible_Declarations (Task_Definition (Parent (Ttyp))));
8878             Wrap_Body    : Node_Id;
8879
8880          begin
8881             if Nkind (Parent (N)) = N_Subunit then
8882                Current_Node := Corresponding_Stub (Parent (N));
8883             else
8884                Current_Node := N;
8885             end if;
8886
8887             --  Examine the visible declarations of the task type, looking for
8888             --  an entry declaration. We do not consider entry families since
8889             --  they cannot have dispatching operations, thus they do not need
8890             --  entry wrappers.
8891
8892             while Present (Vis_Decl) loop
8893                if Nkind (Vis_Decl) = N_Entry_Declaration
8894                  and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry
8895                then
8896
8897                   --  Create the specification of the wrapper
8898
8899                   Wrap_Body :=
8900                     Build_Wrapper_Body (Loc,
8901                       Proc_Nam => Defining_Identifier (Vis_Decl),
8902                       Obj_Typ  => Corresponding_Record_Type (Ttyp),
8903                       Formals  => Parameter_Specifications (Vis_Decl));
8904
8905                   if Wrap_Body /= Empty then
8906                      Insert_After (Current_Node, Wrap_Body);
8907                      Current_Node := Wrap_Body;
8908
8909                      Analyze (Wrap_Body);
8910                   end if;
8911                end if;
8912
8913                Next (Vis_Decl);
8914             end loop;
8915          end;
8916       end if;
8917    end Expand_N_Task_Body;
8918
8919    ------------------------------------
8920    -- Expand_N_Task_Type_Declaration --
8921    ------------------------------------
8922
8923    --  We have several things to do. First we must create a Boolean flag used
8924    --  to mark if the body is elaborated yet. This variable gets set to True
8925    --  when the body of the task is elaborated (we can't rely on the normal
8926    --  ABE mechanism for the task body, since we need to pass an access to
8927    --  this elaboration boolean to the runtime routines).
8928
8929    --    taskE : aliased Boolean := False;
8930
8931    --  Next a variable is declared to hold the task stack size (either the
8932    --  default : Unspecified_Size, or a value that is set by a pragma
8933    --  Storage_Size). If the value of the pragma Storage_Size is static, then
8934    --  the variable is initialized with this value:
8935
8936    --    taskZ : Size_Type := Unspecified_Size;
8937    --  or
8938    --    taskZ : Size_Type := Size_Type (size_expression);
8939
8940    --  Next we create a corresponding record type declaration used to represent
8941    --  values of this task. The general form of this type declaration is
8942
8943    --    type taskV (discriminants) is record
8944    --      _Task_Id     : Task_Id;
8945    --      entry_family : array (bounds) of Void;
8946    --      _Priority    : Integer         := priority_expression;
8947    --      _Size        : Size_Type       := Size_Type (size_expression);
8948    --      _Task_Info   : Task_Info_Type  := task_info_expression;
8949    --    end record;
8950
8951    --  The discriminants are present only if the corresponding task type has
8952    --  discriminants, and they exactly mirror the task type discriminants.
8953
8954    --  The Id field is always present. It contains the Task_Id value, as set by
8955    --  the call to Create_Task. Note that although the task is limited, the
8956    --  task value record type is not limited, so there is no problem in passing
8957    --  this field as an out parameter to Create_Task.
8958
8959    --  One entry_family component is present for each entry family in the task
8960    --  definition. The bounds correspond to the bounds of the entry family
8961    --  (which may depend on discriminants). The element type is void, since we
8962    --  only need the bounds information for determining the entry index. Note
8963    --  that the use of an anonymous array would normally be illegal in this
8964    --  context, but this is a parser check, and the semantics is quite prepared
8965    --  to handle such a case.
8966
8967    --  The _Size field is present only if a Storage_Size pragma appears in the
8968    --  task definition. The expression captures the argument that was present
8969    --  in the pragma, and is used to override the task stack size otherwise
8970    --  associated with the task type.
8971
8972    --  The _Priority field is present only if a Priority or Interrupt_Priority
8973    --  pragma appears in the task definition. The expression captures the
8974    --  argument that was present in the pragma, and is used to provide the Size
8975    --  parameter to the call to Create_Task.
8976
8977    --  The _Task_Info field is present only if a Task_Info pragma appears in
8978    --  the task definition. The expression captures the argument that was
8979    --  present in the pragma, and is used to provide the Task_Image parameter
8980    --  to the call to Create_Task.
8981
8982    --  When a task is declared, an instance of the task value record is
8983    --  created. The elaboration of this declaration creates the correct bounds
8984    --  for the entry families, and also evaluates the size, priority, and
8985    --  task_Info expressions if needed. The initialization routine for the task
8986    --  type itself then calls Create_Task with appropriate parameters to
8987    --  initialize the value of the Task_Id field.
8988
8989    --  Note: the address of this record is passed as the "Discriminants"
8990    --  parameter for Create_Task. Since Create_Task merely passes this onto the
8991    --  body procedure, it does not matter that it does not quite match the
8992    --  GNARLI model of what is being passed (the record contains more than just
8993    --  the discriminants, but the discriminants can be found from the record
8994    --  value).
8995
8996    --  The Entity_Id for this created record type is placed in the
8997    --  Corresponding_Record_Type field of the associated task type entity.
8998
8999    --  Next we create a procedure specification for the task body procedure:
9000
9001    --    procedure taskB (_Task : access taskV);
9002
9003    --  Note that this must come after the record type declaration, since
9004    --  the spec refers to this type. It turns out that the initialization
9005    --  procedure for the value type references the task body spec, but that's
9006    --  fine, since it won't be generated till the freeze point for the type,
9007    --  which is certainly after the task body spec declaration.
9008
9009    --  Finally, we set the task index value field of the entry attribute in
9010    --  the case of a simple entry.
9011
9012    procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
9013       Loc       : constant Source_Ptr := Sloc (N);
9014       Tasktyp   : constant Entity_Id  := Etype (Defining_Identifier (N));
9015       Tasknm    : constant Name_Id    := Chars (Tasktyp);
9016       Taskdef   : constant Node_Id    := Task_Definition (N);
9017
9018       Proc_Spec  : Node_Id;
9019       Rec_Decl   : Node_Id;
9020       Rec_Ent    : Entity_Id;
9021       Cdecls     : List_Id;
9022       Elab_Decl  : Node_Id;
9023       Size_Decl  : Node_Id;
9024       Body_Decl  : Node_Id;
9025       Task_Size  : Node_Id;
9026       Ent_Stack  : Entity_Id;
9027       Decl_Stack : Node_Id;
9028
9029    begin
9030       --  If already expanded, nothing to do
9031
9032       if Present (Corresponding_Record_Type (Tasktyp)) then
9033          return;
9034       end if;
9035
9036       --  Here we will do the expansion
9037
9038       Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
9039
9040       --  Ada 2005 (AI-345): Propagate the attribute that contains the list
9041       --  of implemented interfaces.
9042
9043       Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
9044
9045       Rec_Ent  := Defining_Identifier (Rec_Decl);
9046       Cdecls   := Component_Items (Component_List
9047                                      (Type_Definition (Rec_Decl)));
9048
9049       Qualify_Entity_Names (N);
9050
9051       --  First create the elaboration variable
9052
9053       Elab_Decl :=
9054         Make_Object_Declaration (Loc,
9055           Defining_Identifier =>
9056             Make_Defining_Identifier (Sloc (Tasktyp),
9057               Chars => New_External_Name (Tasknm, 'E')),
9058           Aliased_Present      => True,
9059           Object_Definition    => New_Reference_To (Standard_Boolean, Loc),
9060           Expression           => New_Reference_To (Standard_False, Loc));
9061       Insert_After (N, Elab_Decl);
9062
9063       --  Next create the declaration of the size variable (tasknmZ)
9064
9065       Set_Storage_Size_Variable (Tasktyp,
9066         Make_Defining_Identifier (Sloc (Tasktyp),
9067           Chars => New_External_Name (Tasknm, 'Z')));
9068
9069       if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then
9070         Is_Static_Expression (Expression (First (
9071           Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma (
9072             Taskdef, Name_Storage_Size)))))
9073       then
9074          Size_Decl :=
9075            Make_Object_Declaration (Loc,
9076              Defining_Identifier => Storage_Size_Variable (Tasktyp),
9077              Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
9078              Expression =>
9079                Convert_To (RTE (RE_Size_Type),
9080                  Relocate_Node (
9081                    Expression (First (
9082                      Pragma_Argument_Associations (
9083                        Find_Task_Or_Protected_Pragma
9084                          (Taskdef, Name_Storage_Size)))))));
9085
9086       else
9087          Size_Decl :=
9088            Make_Object_Declaration (Loc,
9089              Defining_Identifier => Storage_Size_Variable (Tasktyp),
9090              Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
9091              Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc));
9092       end if;
9093
9094       Insert_After (Elab_Decl, Size_Decl);
9095
9096       --  Next build the rest of the corresponding record declaration. This is
9097       --  done last, since the corresponding record initialization procedure
9098       --  will reference the previously created entities.
9099
9100       --  Fill in the component declarations -- first the _Task_Id field
9101
9102       Append_To (Cdecls,
9103         Make_Component_Declaration (Loc,
9104           Defining_Identifier =>
9105             Make_Defining_Identifier (Loc, Name_uTask_Id),
9106           Component_Definition =>
9107             Make_Component_Definition (Loc,
9108               Aliased_Present    => False,
9109               Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id),
9110                                     Loc))));
9111
9112       --  Declare static ATCB (that is, created by the expander) if we are
9113       --  using the Restricted run time.
9114
9115       if Restricted_Profile then
9116          Append_To (Cdecls,
9117            Make_Component_Declaration (Loc,
9118              Defining_Identifier  =>
9119                Make_Defining_Identifier (Loc, Name_uATCB),
9120
9121              Component_Definition =>
9122                Make_Component_Definition (Loc,
9123                  Aliased_Present     => True,
9124                  Subtype_Indication  => Make_Subtype_Indication (Loc,
9125                    Subtype_Mark => New_Occurrence_Of
9126                      (RTE (RE_Ada_Task_Control_Block), Loc),
9127
9128                    Constraint   =>
9129                      Make_Index_Or_Discriminant_Constraint (Loc,
9130                        Constraints =>
9131                          New_List (Make_Integer_Literal (Loc, 0)))))));
9132
9133       end if;
9134
9135       --  Declare static stack (that is, created by the expander) if we are
9136       --  using the Restricted run time on a bare board configuration.
9137
9138       if Restricted_Profile
9139         and then Preallocated_Stacks_On_Target
9140       then
9141          --  First we need to extract the appropriate stack size
9142
9143          Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
9144
9145          if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
9146             Task_Size := Relocate_Node (
9147               Expression (First (
9148                 Pragma_Argument_Associations (
9149                   Find_Task_Or_Protected_Pragma
9150                     (Taskdef, Name_Storage_Size)))));
9151          else
9152             Task_Size :=
9153               New_Reference_To (RTE (RE_Default_Stack_Size), Loc);
9154          end if;
9155
9156          Decl_Stack := Make_Component_Declaration (Loc,
9157            Defining_Identifier  => Ent_Stack,
9158
9159            Component_Definition =>
9160              Make_Component_Definition (Loc,
9161                Aliased_Present     => True,
9162                Subtype_Indication  => Make_Subtype_Indication (Loc,
9163                  Subtype_Mark =>
9164                    New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9165
9166                  Constraint   =>
9167                    Make_Index_Or_Discriminant_Constraint (Loc,
9168                      Constraints  => New_List (Make_Range (Loc,
9169                        Low_Bound  => Make_Integer_Literal (Loc, 1),
9170                        High_Bound => Convert_To (RTE (RE_Storage_Offset),
9171                          Task_Size)))))));
9172
9173          Append_To (Cdecls, Decl_Stack);
9174
9175          --  The appropriate alignment for the stack is ensured by the run-time
9176          --  code in charge of task creation.
9177
9178       end if;
9179
9180       --  Add components for entry families
9181
9182       Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
9183
9184       --  Add the _Priority component if a Priority pragma is present
9185
9186       if Present (Taskdef) and then Has_Priority_Pragma (Taskdef) then
9187          declare
9188             Prag : constant Node_Id :=
9189                      Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
9190             Expr : Node_Id;
9191
9192          begin
9193             Expr := First (Pragma_Argument_Associations (Prag));
9194
9195             if Nkind (Expr) = N_Pragma_Argument_Association then
9196                Expr := Expression (Expr);
9197             end if;
9198
9199             Expr := New_Copy_Tree (Expr);
9200
9201             --  Add conversion to proper type to do range check if required
9202             --  Note that for runtime units, we allow out of range interrupt
9203             --  priority values to be used in a priority pragma. This is for
9204             --  the benefit of some versions of System.Interrupts which use
9205             --  a special server task with maximum interrupt priority.
9206
9207             if Chars (Prag) = Name_Priority
9208               and then not GNAT_Mode
9209             then
9210                Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
9211             else
9212                Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
9213             end if;
9214
9215             Append_To (Cdecls,
9216               Make_Component_Declaration (Loc,
9217                 Defining_Identifier =>
9218                   Make_Defining_Identifier (Loc, Name_uPriority),
9219                 Component_Definition =>
9220                   Make_Component_Definition (Loc,
9221                     Aliased_Present    => False,
9222                     Subtype_Indication => New_Reference_To (Standard_Integer,
9223                                                             Loc)),
9224                 Expression => Expr));
9225          end;
9226       end if;
9227
9228       --  Add the _Task_Size component if a Storage_Size pragma is present
9229
9230       if Present (Taskdef)
9231         and then Has_Storage_Size_Pragma (Taskdef)
9232       then
9233          Append_To (Cdecls,
9234            Make_Component_Declaration (Loc,
9235              Defining_Identifier =>
9236                Make_Defining_Identifier (Loc, Name_uSize),
9237
9238              Component_Definition =>
9239                Make_Component_Definition (Loc,
9240                  Aliased_Present    => False,
9241                  Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
9242                                                          Loc)),
9243
9244              Expression =>
9245                Convert_To (RTE (RE_Size_Type),
9246                  Relocate_Node (
9247                    Expression (First (
9248                      Pragma_Argument_Associations (
9249                        Find_Task_Or_Protected_Pragma
9250                          (Taskdef, Name_Storage_Size))))))));
9251       end if;
9252
9253       --  Add the _Task_Info component if a Task_Info pragma is present
9254
9255       if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then
9256          Append_To (Cdecls,
9257            Make_Component_Declaration (Loc,
9258              Defining_Identifier =>
9259                Make_Defining_Identifier (Loc, Name_uTask_Info),
9260
9261              Component_Definition =>
9262                Make_Component_Definition (Loc,
9263                  Aliased_Present    => False,
9264                  Subtype_Indication =>
9265                    New_Reference_To (RTE (RE_Task_Info_Type), Loc)),
9266
9267              Expression => New_Copy (
9268                Expression (First (
9269                  Pragma_Argument_Associations (
9270                    Find_Task_Or_Protected_Pragma
9271                      (Taskdef, Name_Task_Info)))))));
9272       end if;
9273
9274       Insert_After (Size_Decl, Rec_Decl);
9275
9276       --  Analyze the record declaration immediately after construction,
9277       --  because the initialization procedure is needed for single task
9278       --  declarations before the next entity is analyzed.
9279
9280       Analyze (Rec_Decl);
9281
9282       --  Create the declaration of the task body procedure
9283
9284       Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
9285       Body_Decl :=
9286         Make_Subprogram_Declaration (Loc,
9287           Specification => Proc_Spec);
9288
9289       Insert_After (Rec_Decl, Body_Decl);
9290
9291       --  The subprogram does not comes from source, so we have to indicate the
9292       --  need for debugging information explicitly.
9293
9294       Set_Needs_Debug_Info
9295         (Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N)));
9296
9297       --  Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
9298       --  the corresponding record has been frozen.
9299
9300       if Ada_Version >= Ada_05
9301         and then Present (Taskdef)
9302         and then Present (Corresponding_Record_Type
9303                           (Defining_Identifier (Parent (Taskdef))))
9304         and then Present (Abstract_Interfaces
9305                           (Corresponding_Record_Type
9306                            (Defining_Identifier (Parent (Taskdef)))))
9307       then
9308          declare
9309             Current_Node : Node_Id := Rec_Decl;
9310             Vis_Decl     : Node_Id := First (Visible_Declarations (Taskdef));
9311             Wrap_Spec    : Node_Id;
9312             New_N        : Node_Id;
9313
9314          begin
9315             --  Examine the visible declarations of the task type, looking for
9316             --  an entry declaration. We do not consider entry families since
9317             --  they cannot have dispatching operations, thus they do not need
9318             --  entry wrappers.
9319
9320             while Present (Vis_Decl) loop
9321                if Nkind (Vis_Decl) = N_Entry_Declaration
9322                  and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry
9323                then
9324                   Wrap_Spec :=
9325                     Build_Wrapper_Spec (Loc,
9326                       Proc_Nam => Defining_Identifier (Vis_Decl),
9327                       Obj_Typ  => Etype (Rec_Ent),
9328                       Formals  => Parameter_Specifications (Vis_Decl));
9329
9330                   if Wrap_Spec /= Empty then
9331                      New_N :=
9332                        Make_Subprogram_Declaration (Loc,
9333                          Specification => Wrap_Spec);
9334
9335                      Insert_After (Current_Node, New_N);
9336                      Current_Node := New_N;
9337
9338                      Analyze (New_N);
9339                   end if;
9340                end if;
9341
9342                Next (Vis_Decl);
9343             end loop;
9344          end;
9345       end if;
9346
9347       --  Ada 2005 (AI-345): We must defer freezing to allow further
9348       --  declaration of primitive subprograms covering task interfaces
9349
9350       if Ada_Version <= Ada_95 then
9351
9352          --  Now we can freeze the corresponding record. This needs manually
9353          --  freezing, since it is really part of the task type, and the task
9354          --  type is frozen at this stage. We of course need the initialization
9355          --  procedure for this corresponding record type and we won't get it
9356          --  in time if we don't freeze now.
9357
9358          declare
9359             L : constant List_Id := Freeze_Entity (Rec_Ent, Loc);
9360
9361          begin
9362             if Is_Non_Empty_List (L) then
9363                Insert_List_After (Body_Decl, L);
9364             end if;
9365          end;
9366       end if;
9367
9368       --  Complete the expansion of access types to the current task type, if
9369       --  any were declared.
9370
9371       Expand_Previous_Access_Type (Tasktyp);
9372    end Expand_N_Task_Type_Declaration;
9373
9374    -------------------------------
9375    -- Expand_N_Timed_Entry_Call --
9376    -------------------------------
9377
9378    --  A timed entry call in normal case is not implemented using ATC mechanism
9379    --  anymore for efficiency reason.
9380
9381    --     select
9382    --        T.E;
9383    --        S1;
9384    --     or
9385    --        Delay D;
9386    --        S2;
9387    --     end select;
9388
9389    --  is expanded as follow:
9390
9391    --  1) When T.E is a task entry_call;
9392
9393    --    declare
9394    --       B  : Boolean;
9395    --       X  : Task_Entry_Index := <entry index>;
9396    --       DX : Duration := To_Duration (D);
9397    --       M  : Delay_Mode := <discriminant>;
9398    --       P  : parms := (parm, parm, parm);
9399
9400    --    begin
9401    --       Timed_Protected_Entry_Call (<acceptor-task>, X, P'Address,
9402    --         DX, M, B);
9403    --       if B then
9404    --          S1;
9405    --       else
9406    --          S2;
9407    --       end if;
9408    --    end;
9409
9410    --  2) When T.E is a protected entry_call;
9411
9412    --    declare
9413    --       B  : Boolean;
9414    --       X  : Protected_Entry_Index := <entry index>;
9415    --       DX : Duration := To_Duration (D);
9416    --       M  : Delay_Mode := <discriminant>;
9417    --       P  : parms := (parm, parm, parm);
9418
9419    --    begin
9420    --       Timed_Protected_Entry_Call (<object>'unchecked_access, X,
9421    --         P'Address, DX, M, B);
9422    --       if B then
9423    --          S1;
9424    --       else
9425    --          S2;
9426    --       end if;
9427    --    end;
9428
9429    --  3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
9430
9431    --    declare
9432    --       B  : Boolean := False;
9433    --       C  : Ada.Tags.Prim_Op_Kind;
9434    --       DX : Duration := To_Duration (D)
9435    --       K : Ada.Tags.Tagged_Kind :=
9436    --             Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
9437    --       M  : Integer :=...;
9438    --       P  : Parameters := (Param1 .. ParamN);
9439    --       S  : Iteger;
9440
9441    --    begin
9442    --       if K = Ada.Tags.TK_Limited_Tagged then
9443    --          <dispatching-call>;
9444    --          <triggering-statements>
9445
9446    --       else
9447    --          S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>),
9448    --                 DT_Position (<dispatching-call>));
9449
9450    --          _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
9451
9452    --          if C = POK_Protected_Entry
9453    --            or else C = POK_Task_Entry
9454    --          then
9455    --             Param1 := P.Param1;
9456    --             ...
9457    --             ParamN := P.ParamN;
9458    --          end if;
9459
9460    --          if B then
9461    --             if C = POK_Procedure
9462    --               or else C = POK_Protected_Procedure
9463    --               or else C = POK_Task_Procedure
9464    --             then
9465    --                <dispatching-call>;
9466    --             end if;
9467
9468    --             <triggering-statements>
9469    --          else
9470    --             <timed-statements>
9471    --          end if;
9472    --       end if;
9473    --    end;
9474
9475    procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
9476       Loc : constant Source_Ptr := Sloc (N);
9477
9478       E_Call  : Node_Id :=
9479                   Entry_Call_Statement (Entry_Call_Alternative (N));
9480       E_Stats : constant List_Id :=
9481                   Statements (Entry_Call_Alternative (N));
9482       D_Stat  : constant Node_Id :=
9483                   Delay_Statement (Delay_Alternative (N));
9484       D_Stats : constant List_Id :=
9485                   Statements (Delay_Alternative (N));
9486
9487       Actuals        : List_Id;
9488       Blk_Typ        : Entity_Id;
9489       Call           : Node_Id;
9490       Call_Ent       : Entity_Id;
9491       Conc_Typ_Stmts : List_Id;
9492       Concval        : Node_Id;
9493       D_Conv         : Node_Id;
9494       D_Disc         : Node_Id;
9495       D_Type         : Entity_Id;
9496       Decls          : List_Id;
9497       Dummy          : Node_Id;
9498       Ename          : Node_Id;
9499       Formals        : List_Id;
9500       Index          : Node_Id;
9501       Lim_Typ_Stmts  : List_Id;
9502       N_Stats        : List_Id;
9503       Obj            : Entity_Id;
9504       Param          : Node_Id;
9505       Params         : List_Id;
9506       Stmt           : Node_Id;
9507       Stmts          : List_Id;
9508       Unpack         : List_Id;
9509
9510       B : Entity_Id;  --  Call status flag
9511       C : Entity_Id;  --  Call kind
9512       D : Entity_Id;  --  Delay
9513       K : Entity_Id;  --  Tagged kind
9514       M : Entity_Id;  --  Delay mode
9515       P : Entity_Id;  --  Parameter block
9516       S : Entity_Id;  --  Primitive operation slot
9517
9518    begin
9519       --  The arguments in the call may require dynamic allocation, and the
9520       --  call statement may have been transformed into a block. The block
9521       --  may contain additional declarations for internal entities, and the
9522       --  original call is found by sequential search.
9523
9524       if Nkind (E_Call) = N_Block_Statement then
9525          E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
9526          while Nkind (E_Call) /= N_Procedure_Call_Statement
9527            and then Nkind (E_Call) /= N_Entry_Call_Statement
9528          loop
9529             Next (E_Call);
9530          end loop;
9531       end if;
9532
9533       if Ada_Version >= Ada_05
9534         and then Nkind (E_Call) = N_Procedure_Call_Statement
9535       then
9536          Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
9537
9538          Decls := New_List;
9539          Stmts := New_List;
9540
9541       else
9542          --  Build an entry call using Simple_Entry_Call
9543
9544          Extract_Entry (E_Call, Concval, Ename, Index);
9545          Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
9546
9547          Decls := Declarations (E_Call);
9548          Stmts := Statements (Handled_Statement_Sequence (E_Call));
9549
9550          if No (Decls) then
9551             Decls := New_List;
9552          end if;
9553       end if;
9554
9555       --  Call status flag processing
9556
9557       if Ada_Version >= Ada_05
9558         and then Nkind (E_Call) = N_Procedure_Call_Statement
9559       then
9560          --  Generate:
9561          --    B : Boolean := False;
9562
9563          B := Build_B (Loc, Decls);
9564
9565       else
9566          --  Generate:
9567          --    B : Boolean;
9568
9569          B := Make_Defining_Identifier (Loc, Name_uB);
9570
9571          Prepend_To (Decls,
9572            Make_Object_Declaration (Loc,
9573              Defining_Identifier =>
9574                B,
9575              Object_Definition =>
9576                New_Reference_To (Standard_Boolean, Loc)));
9577       end if;
9578
9579       --  Call kind processing
9580
9581       if Ada_Version >= Ada_05
9582         and then Nkind (E_Call) = N_Procedure_Call_Statement
9583       then
9584          --  Generate:
9585          --    C : Ada.Tags.Prim_Op_Kind;
9586
9587          C := Build_C (Loc, Decls);
9588       end if;
9589
9590       --  Duration and mode processing
9591
9592       D_Type := Base_Type (Etype (Expression (D_Stat)));
9593
9594       --  Use the type of the delay expression (Calendar or Real_Time)
9595       --  to generate the appropriate conversion.
9596
9597       if Nkind (D_Stat) = N_Delay_Relative_Statement then
9598          D_Disc := Make_Integer_Literal (Loc, 0);
9599          D_Conv := Relocate_Node (Expression (D_Stat));
9600
9601       elsif Is_RTE (D_Type, RO_CA_Time) then
9602          D_Disc := Make_Integer_Literal (Loc, 1);
9603          D_Conv := Make_Function_Call (Loc,
9604            New_Reference_To (RTE (RO_CA_To_Duration), Loc),
9605            New_List (New_Copy (Expression (D_Stat))));
9606
9607       else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
9608          D_Disc := Make_Integer_Literal (Loc, 2);
9609          D_Conv := Make_Function_Call (Loc,
9610            New_Reference_To (RTE (RO_RT_To_Duration), Loc),
9611            New_List (New_Copy (Expression (D_Stat))));
9612       end if;
9613
9614       D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
9615
9616       --  Generate:
9617       --    D : Duration;
9618
9619       Append_To (Decls,
9620         Make_Object_Declaration (Loc,
9621           Defining_Identifier =>
9622             D,
9623           Object_Definition =>
9624             New_Reference_To (Standard_Duration, Loc)));
9625
9626       M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
9627
9628       --  Generate:
9629       --    M : Integer := (0 | 1 | 2);
9630
9631       Append_To (Decls,
9632         Make_Object_Declaration (Loc,
9633           Defining_Identifier =>
9634             M,
9635           Object_Definition =>
9636             New_Reference_To (Standard_Integer, Loc),
9637           Expression =>
9638             D_Disc));
9639
9640       --  Do the assignement at this stage only because the evaluation of the
9641       --  expression must not occur before (see ACVC C97302A).
9642
9643       Append_To (Stmts,
9644         Make_Assignment_Statement (Loc,
9645           Name =>
9646             New_Reference_To (D, Loc),
9647           Expression =>
9648             D_Conv));
9649
9650       --  Parameter block processing
9651
9652       --  Manually create the parameter block for dispatching calls. In the
9653       --  case of entries, the block has already been created during the call
9654       --  to Build_Simple_Entry_Call.
9655
9656       if Ada_Version >= Ada_05
9657         and then Nkind (E_Call) = N_Procedure_Call_Statement
9658       then
9659          --  Tagged kind processing, generate:
9660          --    K : Ada.Tags.Tagged_Kind :=
9661          --          Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
9662
9663          K := Build_K (Loc, Decls, Obj);
9664
9665          Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
9666          P       := Parameter_Block_Pack  (Loc, Blk_Typ, Actuals, Formals,
9667                       Decls, Stmts);
9668
9669          --  Dispatch table slot processing, generate:
9670          --    S : Integer;
9671
9672          S := Build_S (Loc, Decls);
9673
9674          --  Generate:
9675          --    S := Ada.Tags.Get_Offset_Index (
9676          --           Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
9677
9678          Conc_Typ_Stmts := New_List (
9679            Build_S_Assignment (Loc, S, Obj, Call_Ent));
9680
9681          --  Generate:
9682          --    _Disp_Timed_Select (<object>, S, P'address, D, M, C, B);
9683
9684          --  where Obj is the controlling formal parameter, S is the dispatch
9685          --  table slot number of the dispatching operation, P is the wrapped
9686          --  parameter block, D is the duration, M is the duration mode, C is
9687          --  the call kind and B is the call status.
9688
9689          Params := New_List;
9690
9691          Append_To (Params, New_Copy_Tree    (Obj));
9692          Append_To (Params, New_Reference_To (S, Loc));
9693          Append_To (Params, Make_Attribute_Reference (Loc,
9694                               Prefix => New_Reference_To (P, Loc),
9695                               Attribute_Name => Name_Address));
9696          Append_To (Params, New_Reference_To (D, Loc));
9697          Append_To (Params, New_Reference_To (M, Loc));
9698          Append_To (Params, New_Reference_To (C, Loc));
9699          Append_To (Params, New_Reference_To (B, Loc));
9700
9701          Append_To (Conc_Typ_Stmts,
9702            Make_Procedure_Call_Statement (Loc,
9703              Name =>
9704                New_Reference_To (
9705                  Find_Prim_Op (Etype (Etype (Obj)),
9706                    Name_uDisp_Timed_Select),
9707                  Loc),
9708              Parameter_Associations =>
9709                Params));
9710
9711          --  Generate:
9712          --    if C = POK_Protected_Entry
9713          --      or else C = POK_Task_Entry
9714          --    then
9715          --       Param1 := P.Param1;
9716          --       ...
9717          --       ParamN := P.ParamN;
9718          --    end if;
9719
9720          Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
9721
9722          --  Generate the if statement only when the packed parameters need
9723          --  explicit assignments to their corresponding actuals.
9724
9725          if Present (Unpack) then
9726             Append_To (Conc_Typ_Stmts,
9727               Make_If_Statement (Loc,
9728
9729                 Condition =>
9730                   Make_Or_Else (Loc,
9731                     Left_Opnd =>
9732                       Make_Op_Eq (Loc,
9733                         Left_Opnd =>
9734                           New_Reference_To (C, Loc),
9735                         Right_Opnd =>
9736                           New_Reference_To (RTE (
9737                             RE_POK_Protected_Entry), Loc)),
9738                     Right_Opnd =>
9739                       Make_Op_Eq (Loc,
9740                         Left_Opnd =>
9741                           New_Reference_To (C, Loc),
9742                         Right_Opnd =>
9743                           New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
9744
9745                 Then_Statements =>
9746                   Unpack));
9747          end if;
9748
9749          --  Generate:
9750
9751          --    if B then
9752          --       if C = POK_Procedure
9753          --         or else C = POK_Protected_Procedure
9754          --         or else C = POK_Task_Procedure
9755          --       then
9756          --          <dispatching-call>
9757          --       end if;
9758          --       <triggering-statements>
9759          --    else
9760          --       <timed-statements>
9761          --    end if;
9762
9763          N_Stats := New_Copy_List_Tree (E_Stats);
9764
9765          Prepend_To (N_Stats,
9766            Make_If_Statement (Loc,
9767
9768              Condition =>
9769                Make_Or_Else (Loc,
9770                  Left_Opnd =>
9771                    Make_Op_Eq (Loc,
9772                      Left_Opnd =>
9773                        New_Reference_To (C, Loc),
9774                      Right_Opnd =>
9775                        New_Reference_To (RTE (RE_POK_Procedure), Loc)),
9776                  Right_Opnd =>
9777                    Make_Or_Else (Loc,
9778                      Left_Opnd =>
9779                        Make_Op_Eq (Loc,
9780                          Left_Opnd =>
9781                            New_Reference_To (C, Loc),
9782                          Right_Opnd =>
9783                            New_Reference_To (RTE (
9784                              RE_POK_Protected_Procedure), Loc)),
9785                      Right_Opnd =>
9786                        Make_Op_Eq (Loc,
9787                          Left_Opnd =>
9788                            New_Reference_To (C, Loc),
9789                          Right_Opnd =>
9790                            New_Reference_To (RTE (
9791                              RE_POK_Task_Procedure), Loc)))),
9792
9793              Then_Statements =>
9794                New_List (E_Call)));
9795
9796          Append_To (Conc_Typ_Stmts,
9797            Make_If_Statement (Loc,
9798              Condition       => New_Reference_To (B, Loc),
9799              Then_Statements => N_Stats,
9800              Else_Statements => D_Stats));
9801
9802          --  Generate:
9803          --    <dispatching-call>;
9804          --    <triggering-statements>
9805
9806          Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
9807          Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
9808
9809          --  Generate:
9810          --    if K = Ada.Tags.TK_Limited_Tagged then
9811          --       Lim_Typ_Stmts
9812          --    else
9813          --       Conc_Typ_Stmts
9814          --    end if;
9815
9816          Append_To (Stmts,
9817            Make_If_Statement (Loc,
9818              Condition =>
9819                Make_Op_Eq (Loc,
9820                  Left_Opnd =>
9821                    New_Reference_To (K, Loc),
9822                  Right_Opnd =>
9823                    New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
9824
9825              Then_Statements =>
9826                Lim_Typ_Stmts,
9827
9828              Else_Statements =>
9829                Conc_Typ_Stmts));
9830
9831       else
9832          --  Skip assignments to temporaries created for in-out parameters.
9833          --  This makes unwarranted assumptions about the shape of the expanded
9834          --  tree for the call, and should be cleaned up ???
9835
9836          Stmt := First (Stmts);
9837          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
9838             Next (Stmt);
9839          end loop;
9840
9841          --  Do the assignement at this stage only because the evaluation
9842          --  of the expression must not occur before (see ACVC C97302A).
9843
9844          Insert_Before (Stmt,
9845            Make_Assignment_Statement (Loc,
9846              Name => New_Reference_To (D, Loc),
9847              Expression => D_Conv));
9848
9849          Call   := Stmt;
9850          Params := Parameter_Associations (Call);
9851
9852          --  For a protected type, we build a Timed_Protected_Entry_Call
9853
9854          if Is_Protected_Type (Etype (Concval)) then
9855
9856             --  Create a new call statement
9857
9858             Param := First (Params);
9859             while Present (Param)
9860               and then not Is_RTE (Etype (Param), RE_Call_Modes)
9861             loop
9862                Next (Param);
9863             end loop;
9864
9865             Dummy := Remove_Next (Next (Param));
9866
9867             --  Remove garbage is following the Cancel_Param if present
9868
9869             Dummy := Next (Param);
9870
9871             --  Remove the mode of the Protected_Entry_Call call, then remove
9872             --  the Communication_Block of the Protected_Entry_Call call, and
9873             --  finally add Duration and a Delay_Mode parameter
9874
9875             pragma Assert (Present (Param));
9876             Rewrite (Param, New_Reference_To (D, Loc));
9877
9878             Rewrite (Dummy, New_Reference_To (M, Loc));
9879
9880             --  Add a Boolean flag for successful entry call
9881
9882             Append_To (Params, New_Reference_To (B, Loc));
9883
9884             if Abort_Allowed
9885               or else Restriction_Active (No_Entry_Queue) = False
9886               or else Number_Entries (Etype (Concval)) > 1
9887             then
9888                Rewrite (Call,
9889                  Make_Procedure_Call_Statement (Loc,
9890                    Name =>
9891                      New_Reference_To (RTE (
9892                        RE_Timed_Protected_Entry_Call), Loc),
9893                    Parameter_Associations => Params));
9894             else
9895                Param := First (Params);
9896                while Present (Param)
9897                  and then not Is_RTE (Etype (Param), RE_Protected_Entry_Index)
9898                loop
9899                   Next (Param);
9900                end loop;
9901
9902                Remove (Param);
9903
9904                Rewrite (Call,
9905                  Make_Procedure_Call_Statement (Loc,
9906                    Name => New_Reference_To (
9907                      RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
9908                    Parameter_Associations => Params));
9909             end if;
9910
9911          --  For the task case, build a Timed_Task_Entry_Call
9912
9913          else
9914             --  Create a new call statement
9915
9916             Append_To (Params, New_Reference_To (D, Loc));
9917             Append_To (Params, New_Reference_To (M, Loc));
9918             Append_To (Params, New_Reference_To (B, Loc));
9919
9920             Rewrite (Call,
9921               Make_Procedure_Call_Statement (Loc,
9922                 Name =>
9923                   New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
9924                 Parameter_Associations => Params));
9925          end if;
9926
9927          Append_To (Stmts,
9928            Make_Implicit_If_Statement (N,
9929              Condition => New_Reference_To (B, Loc),
9930              Then_Statements => E_Stats,
9931              Else_Statements => D_Stats));
9932       end if;
9933
9934       Rewrite (N,
9935         Make_Block_Statement (Loc,
9936           Declarations => Decls,
9937           Handled_Statement_Sequence =>
9938             Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
9939
9940       Analyze (N);
9941    end Expand_N_Timed_Entry_Call;
9942
9943    ----------------------------------------
9944    -- Expand_Protected_Body_Declarations --
9945    ----------------------------------------
9946
9947    --  Part of the expansion of a protected body involves the creation of a
9948    --  declaration that can be referenced from the statement sequences of the
9949    --  entry bodies:
9950
9951    --    A : Address;
9952
9953    --  This declaration is inserted in the declarations of the service entries
9954    --  procedure for the protected body, and it is important that it be
9955    --  inserted before the statements of the entry body statement sequences are
9956    --  analyzed. Thus it would be too late to create this declaration in the
9957    --  Expand_N_Protected_Body routine, which is why there is a separate
9958    --  procedure to be called directly from Sem_Ch9.
9959
9960    --  Ann is used to hold the address of the record containing the parameters
9961    --  (see Expand_N_Entry_Call for more details on how this record is built).
9962    --  References to the parameters do an unchecked conversion of this address
9963    --  to a pointer to the required record type, and then access the field that
9964    --  holds the value of the required parameter. The entity for the address
9965    --  variable is held as the top stack element (i.e. the last element) of the
9966    --  Accept_Address stack in the corresponding entry entity, and this element
9967    --  must be set in place  before the statements are processed.
9968
9969    --  No stack is needed for entry bodies, since they cannot be nested, but it
9970    --  is kept for consistency between protected and task entries. The stack
9971    --  will never contain more than one element. There is also only one such
9972    --  variable for a given protected body, but this is placed on the
9973    --  Accept_Address stack of all of the entries, again for consistency.
9974
9975    --  To expand the requeue statement, a label is provided at the end of the
9976    --  loop in the entry service routine created by the expander (see
9977    --  Expand_N_Protected_Body for details), so that the statement can be
9978    --  skipped after the requeue is complete. This label is created during the
9979    --  expansion of the entry body, which will take place after the expansion
9980    --  of the requeue statements that it contains, so a placeholder defining
9981    --  identifier is associated with the task type here.
9982
9983    --  Another label is provided following case statement created by the
9984    --  expander. This label is need for implementing return statement from
9985    --  entry body so that a return can be expanded as a goto to this label.
9986    --  This label is created during the expansion of the entry body, which
9987    --  will take place after the expansion of the return statements that it
9988    --  contains. Therefore, just like the label for expanding requeues, we
9989    --  need another placeholder for the label.
9990
9991    procedure Expand_Protected_Body_Declarations
9992      (N       : Node_Id;
9993       Spec_Id : Entity_Id)
9994    is
9995       Op : Node_Id;
9996
9997    begin
9998       if No_Run_Time_Mode then
9999          Error_Msg_CRT ("protected body", N);
10000          return;
10001
10002       elsif Expander_Active then
10003
10004          --  Associate privals with the first subprogram or entry body to be
10005          --  expanded. These are used to expand references to private data
10006          --  objects.
10007
10008          Op := First_Protected_Operation (Declarations (N));
10009
10010          if Present (Op) then
10011             Set_Discriminals (Parent (Spec_Id));
10012             Set_Privals (Parent (Spec_Id), Op, Sloc (N));
10013          end if;
10014       end if;
10015    end Expand_Protected_Body_Declarations;
10016
10017    -------------------------
10018    -- External_Subprogram --
10019    -------------------------
10020
10021    function External_Subprogram (E : Entity_Id) return Entity_Id is
10022       Subp : constant Entity_Id := Protected_Body_Subprogram (E);
10023       Decl : constant Node_Id   := Unit_Declaration_Node (E);
10024
10025    begin
10026       --  If the protected operation is defined in the visible part of the
10027       --  protected type, or if it is an interrupt handler, the internal and
10028       --  external subprograms follow each other on the entity chain. If the
10029       --  operation is defined in the private part of the type, there is no
10030       --  need for a separate locking version of the operation, and internal
10031       --  calls use the protected_body_subprogram directly.
10032
10033       if List_Containing (Decl) = Visible_Declarations (Parent (Decl))
10034         or else Is_Interrupt_Handler (E)
10035       then
10036          return Next_Entity (Subp);
10037       else
10038          return (Subp);
10039       end if;
10040    end External_Subprogram;
10041
10042    ------------------------------
10043    -- Extract_Dispatching_Call --
10044    ------------------------------
10045
10046    procedure Extract_Dispatching_Call
10047      (N        : Node_Id;
10048       Call_Ent : out Entity_Id;
10049       Object   : out Entity_Id;
10050       Actuals  : out List_Id;
10051       Formals  : out List_Id)
10052    is
10053       Call_Nam : Node_Id;
10054
10055    begin
10056       pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
10057
10058       if Present (Original_Node (N)) then
10059          Call_Nam := Name (Original_Node (N));
10060       else
10061          Call_Nam := Name (N);
10062       end if;
10063
10064       --  Retrieve the name of the dispatching procedure. It contains the
10065       --  dispatch table slot number.
10066
10067       loop
10068          case Nkind (Call_Nam) is
10069             when N_Identifier =>
10070                exit;
10071
10072             when N_Selected_Component =>
10073                Call_Nam := Selector_Name (Call_Nam);
10074
10075             when others =>
10076                raise Program_Error;
10077
10078          end case;
10079       end loop;
10080
10081       Actuals  := Parameter_Associations (N);
10082       Call_Ent := Entity (Call_Nam);
10083       Formals  := Parameter_Specifications (Parent (Call_Ent));
10084       Object   := First (Actuals);
10085
10086       if Present (Original_Node (Object)) then
10087          Object := Original_Node (Object);
10088       end if;
10089    end Extract_Dispatching_Call;
10090
10091    -------------------
10092    -- Extract_Entry --
10093    -------------------
10094
10095    procedure Extract_Entry
10096      (N       : Node_Id;
10097       Concval : out Node_Id;
10098       Ename   : out Node_Id;
10099       Index   : out Node_Id)
10100    is
10101       Nam : constant Node_Id := Name (N);
10102
10103    begin
10104       --  For a simple entry, the name is a selected component, with the
10105       --  prefix being the task value, and the selector being the entry.
10106
10107       if Nkind (Nam) = N_Selected_Component then
10108          Concval := Prefix (Nam);
10109          Ename   := Selector_Name (Nam);
10110          Index   := Empty;
10111
10112       --  For a member of an entry family, the name is an indexed component
10113       --  where the prefix is a selected component, whose prefix in turn is
10114       --  the task value, and whose selector is the entry family. The single
10115       --  expression in the expressions list of the indexed component is the
10116       --  subscript for the family.
10117
10118       else pragma Assert (Nkind (Nam) = N_Indexed_Component);
10119          Concval := Prefix (Prefix (Nam));
10120          Ename   := Selector_Name (Prefix (Nam));
10121          Index   := First (Expressions (Nam));
10122       end if;
10123    end Extract_Entry;
10124
10125    -------------------
10126    -- Family_Offset --
10127    -------------------
10128
10129    function Family_Offset
10130      (Loc  : Source_Ptr;
10131       Hi   : Node_Id;
10132       Lo   : Node_Id;
10133       Ttyp : Entity_Id) return Node_Id
10134    is
10135       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
10136       --  If one of the bounds is a reference to a discriminant, replace with
10137       --  corresponding discriminal of type. Within the body of a task retrieve
10138       --  the renamed discriminant by simple visibility, using its generated
10139       --  name. Within a protected object, find the original dis- criminant and
10140       --  replace it with the discriminal of the current prot- ected operation.
10141
10142       ------------------------------
10143       -- Convert_Discriminant_Ref --
10144       ------------------------------
10145
10146       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
10147          Loc : constant Source_Ptr := Sloc (Bound);
10148          B   : Node_Id;
10149          D   : Entity_Id;
10150
10151       begin
10152          if Is_Entity_Name (Bound)
10153            and then Ekind (Entity (Bound)) = E_Discriminant
10154          then
10155             if Is_Task_Type (Ttyp)
10156               and then Has_Completion (Ttyp)
10157             then
10158                B := Make_Identifier (Loc, Chars (Entity (Bound)));
10159                Find_Direct_Name (B);
10160
10161             elsif Is_Protected_Type (Ttyp) then
10162                D := First_Discriminant (Ttyp);
10163                while Chars (D) /= Chars (Entity (Bound)) loop
10164                   Next_Discriminant (D);
10165                end loop;
10166
10167                B := New_Reference_To  (Discriminal (D), Loc);
10168
10169             else
10170                B := New_Reference_To (Discriminal (Entity (Bound)), Loc);
10171             end if;
10172
10173          elsif Nkind (Bound) = N_Attribute_Reference then
10174             return Bound;
10175
10176          else
10177             B := New_Copy_Tree (Bound);
10178          end if;
10179
10180          return
10181            Make_Attribute_Reference (Loc,
10182              Attribute_Name => Name_Pos,
10183              Prefix => New_Occurrence_Of (Etype (Bound), Loc),
10184              Expressions    => New_List (B));
10185       end Convert_Discriminant_Ref;
10186
10187    --  Start of processing for Family_Offset
10188
10189    begin
10190       return
10191         Make_Op_Subtract (Loc,
10192           Left_Opnd  => Convert_Discriminant_Ref (Hi),
10193           Right_Opnd => Convert_Discriminant_Ref (Lo));
10194    end Family_Offset;
10195
10196    -----------------
10197    -- Family_Size --
10198    -----------------
10199
10200    function Family_Size
10201      (Loc  : Source_Ptr;
10202       Hi   : Node_Id;
10203       Lo   : Node_Id;
10204       Ttyp : Entity_Id) return Node_Id
10205    is
10206       Ityp : Entity_Id;
10207
10208    begin
10209       if Is_Task_Type (Ttyp) then
10210          Ityp := RTE (RE_Task_Entry_Index);
10211       else
10212          Ityp := RTE (RE_Protected_Entry_Index);
10213       end if;
10214
10215       return
10216         Make_Attribute_Reference (Loc,
10217           Prefix         => New_Reference_To (Ityp, Loc),
10218           Attribute_Name => Name_Max,
10219           Expressions    => New_List (
10220             Make_Op_Add (Loc,
10221               Left_Opnd  =>
10222                 Family_Offset (Loc, Hi, Lo, Ttyp),
10223               Right_Opnd =>
10224                 Make_Integer_Literal (Loc, 1)),
10225             Make_Integer_Literal (Loc, 0)));
10226    end Family_Size;
10227
10228    -----------------------------------
10229    -- Find_Task_Or_Protected_Pragma --
10230    -----------------------------------
10231
10232    function Find_Task_Or_Protected_Pragma
10233      (T : Node_Id;
10234       P : Name_Id) return Node_Id
10235    is
10236       N : Node_Id;
10237
10238    begin
10239       N := First (Visible_Declarations (T));
10240       while Present (N) loop
10241          if Nkind (N) = N_Pragma then
10242             if Chars (N) = P then
10243                return N;
10244
10245             elsif P = Name_Priority
10246               and then Chars (N) = Name_Interrupt_Priority
10247             then
10248                return N;
10249
10250             else
10251                Next (N);
10252             end if;
10253
10254          else
10255             Next (N);
10256          end if;
10257       end loop;
10258
10259       N := First (Private_Declarations (T));
10260       while Present (N) loop
10261          if Nkind (N) = N_Pragma then
10262             if  Chars (N) = P then
10263                return N;
10264
10265             elsif P = Name_Priority
10266               and then Chars (N) = Name_Interrupt_Priority
10267             then
10268                return N;
10269
10270             else
10271                Next (N);
10272             end if;
10273
10274          else
10275             Next (N);
10276          end if;
10277       end loop;
10278
10279       raise Program_Error;
10280    end Find_Task_Or_Protected_Pragma;
10281
10282    -------------------------------
10283    -- First_Protected_Operation --
10284    -------------------------------
10285
10286    function First_Protected_Operation (D : List_Id) return Node_Id is
10287       First_Op : Node_Id;
10288
10289    begin
10290       First_Op := First (D);
10291       while Present (First_Op)
10292         and then Nkind (First_Op) /= N_Subprogram_Body
10293         and then Nkind (First_Op) /= N_Entry_Body
10294       loop
10295          Next (First_Op);
10296       end loop;
10297
10298       return First_Op;
10299    end First_Protected_Operation;
10300
10301    --------------------------------
10302    -- Index_Constant_Declaration --
10303    --------------------------------
10304
10305    function Index_Constant_Declaration
10306      (N        : Node_Id;
10307       Index_Id : Entity_Id;
10308       Prot     : Entity_Id) return List_Id
10309    is
10310       Loc       : constant Source_Ptr := Sloc (N);
10311       Decls     : constant List_Id    := New_List;
10312       Index_Con : constant Entity_Id  := Entry_Index_Constant (Index_Id);
10313       Index_Typ : Entity_Id;
10314
10315       Hi : Node_Id := Type_High_Bound (Etype (Index_Id));
10316       Lo : Node_Id := Type_Low_Bound  (Etype (Index_Id));
10317
10318       function Replace_Discriminant (Bound : Node_Id) return Node_Id;
10319       --  The bounds of the entry index may depend on discriminants, so each
10320       --  declaration of an entry_index_constant must have its own subtype
10321       --  declaration, using the local renaming of the object discriminant.
10322
10323       --------------------------
10324       -- Replace_Discriminant --
10325       --------------------------
10326
10327       function Replace_Discriminant (Bound : Node_Id) return Node_Id is
10328       begin
10329          if Nkind (Bound) = N_Identifier
10330            and then Ekind (Entity (Bound)) = E_Constant
10331            and then Present (Discriminal_Link (Entity (Bound)))
10332          then
10333             return Make_Identifier (Loc, Chars (Entity (Bound)));
10334          else
10335             return Duplicate_Subexpr (Bound);
10336          end if;
10337       end Replace_Discriminant;
10338
10339    --  Start of processing for Index_Constant_Declaration
10340
10341    begin
10342       Set_Discriminal_Link (Index_Con, Index_Id);
10343
10344       if Is_Entity_Name (
10345         Original_Node (Discrete_Subtype_Definition (Parent (Index_Id))))
10346       then
10347          --  Simple case: entry family is given by a subtype mark, and index
10348          --  constant has the same type, no replacement needed.
10349
10350          Index_Typ := Etype (Index_Id);
10351
10352       else
10353          Hi := Replace_Discriminant (Hi);
10354          Lo := Replace_Discriminant (Lo);
10355
10356          Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
10357
10358          Append (
10359            Make_Subtype_Declaration (Loc,
10360              Defining_Identifier => Index_Typ,
10361              Subtype_Indication =>
10362                Make_Subtype_Indication (Loc,
10363                  Subtype_Mark =>
10364                    New_Occurrence_Of (Base_Type (Etype (Index_Id)), Loc),
10365                  Constraint =>
10366                    Make_Range_Constraint (Loc,
10367                      Range_Expression => Make_Range (Loc, Lo, Hi)))),
10368            Decls);
10369
10370       end if;
10371
10372       Append (
10373         Make_Object_Declaration (Loc,
10374           Defining_Identifier => Index_Con,
10375           Constant_Present => True,
10376           Object_Definition => New_Occurrence_Of (Index_Typ, Loc),
10377
10378           Expression =>
10379             Make_Attribute_Reference (Loc,
10380               Prefix => New_Reference_To (Index_Typ, Loc),
10381               Attribute_Name => Name_Val,
10382
10383               Expressions => New_List (
10384
10385                 Make_Op_Add (Loc,
10386                   Left_Opnd =>
10387                     Make_Op_Subtract (Loc,
10388                       Left_Opnd => Make_Identifier (Loc, Name_uE),
10389                       Right_Opnd =>
10390                         Entry_Index_Expression (Loc,
10391                           Defining_Identifier (N), Empty, Prot)),
10392
10393                   Right_Opnd =>
10394                     Make_Attribute_Reference (Loc,
10395                       Prefix => New_Reference_To (Index_Typ, Loc),
10396                       Attribute_Name => Name_Pos,
10397                       Expressions => New_List (
10398                         Make_Attribute_Reference (Loc,
10399                           Prefix => New_Reference_To (Index_Typ, Loc),
10400                     Attribute_Name => Name_First))))))),
10401       Decls);
10402
10403       return Decls;
10404    end Index_Constant_Declaration;
10405
10406    --------------------------------
10407    -- Make_Initialize_Protection --
10408    --------------------------------
10409
10410    function Make_Initialize_Protection
10411      (Protect_Rec : Entity_Id) return List_Id
10412    is
10413       Loc         : constant Source_Ptr := Sloc (Protect_Rec);
10414       P_Arr       : Entity_Id;
10415       Pdef        : Node_Id;
10416       Pdec        : Node_Id;
10417       Ptyp        : constant Node_Id :=
10418                       Corresponding_Concurrent_Type (Protect_Rec);
10419       Args        : List_Id;
10420       L           : constant List_Id := New_List;
10421       Has_Entry   : constant Boolean := Has_Entries (Ptyp);
10422       Restricted  : constant Boolean := Restricted_Profile;
10423
10424    begin
10425       --  We may need two calls to properly initialize the object, one to
10426       --  Initialize_Protection, and possibly one to Install_Handlers if we
10427       --  have a pragma Attach_Handler.
10428
10429       --  Get protected declaration. In the case of a task type declaration,
10430       --  this is simply the parent of the protected type entity. In the single
10431       --  protected object declaration, this parent will be the implicit type,
10432       --  and we can find the corresponding single protected object declaration
10433       --  by searching forward in the declaration list in the tree.
10434
10435       --  Is the test for N_Single_Protected_Declaration needed here??? Nodes
10436       --  of this type should have been removed during semantic analysis.
10437
10438       Pdec := Parent (Ptyp);
10439       while Nkind (Pdec) /= N_Protected_Type_Declaration
10440         and then Nkind (Pdec) /= N_Single_Protected_Declaration
10441       loop
10442          Next (Pdec);
10443       end loop;
10444
10445       --  Now we can find the object definition from this declaration
10446
10447       Pdef := Protected_Definition (Pdec);
10448
10449       --  Build the parameter list for the call. Note that _Init is the name
10450       --  of the formal for the object to be initialized, which is the task
10451       --  value record itself.
10452
10453       Args := New_List;
10454
10455       --  Object parameter. This is a pointer to the object of type
10456       --  Protection used by the GNARL to control the protected object.
10457
10458       Append_To (Args,
10459         Make_Attribute_Reference (Loc,
10460           Prefix =>
10461             Make_Selected_Component (Loc,
10462               Prefix => Make_Identifier (Loc, Name_uInit),
10463               Selector_Name => Make_Identifier (Loc, Name_uObject)),
10464           Attribute_Name => Name_Unchecked_Access));
10465
10466       --  Priority parameter. Set to Unspecified_Priority unless there is a
10467       --  priority pragma, in which case we take the value from the pragma,
10468       --  or there is an interrupt pragma and no priority pragma, and we
10469       --  set the ceiling to Interrupt_Priority'Last, an implementation-
10470       --  defined value, see D.3(10).
10471
10472       if Present (Pdef)
10473         and then Has_Priority_Pragma (Pdef)
10474       then
10475          Append_To (Args,
10476            Duplicate_Subexpr_No_Checks
10477              (Expression
10478                (First
10479                  (Pragma_Argument_Associations
10480                    (Find_Task_Or_Protected_Pragma (Pdef, Name_Priority))))));
10481
10482       elsif Has_Interrupt_Handler (Ptyp)
10483         or else Has_Attach_Handler (Ptyp)
10484       then
10485          --  When no priority is specified but an xx_Handler pragma is,
10486          --  we default to System.Interrupts.Default_Interrupt_Priority,
10487          --  see D.3(10).
10488
10489          Append_To (Args,
10490            New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
10491
10492       else
10493          Append_To (Args,
10494            New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
10495       end if;
10496
10497       if Has_Entry
10498         or else Has_Interrupt_Handler (Ptyp)
10499         or else Has_Attach_Handler (Ptyp)
10500         or else (Ada_Version >= Ada_05
10501                    and then Present (Interface_List (Parent (Ptyp))))
10502       then
10503          --  Compiler_Info parameter. This parameter allows entry body
10504          --  procedures and barrier functions to be called from the runtime.
10505          --  It is a pointer to the record generated by the compiler to
10506          --  represent the protected object.
10507
10508          if Has_Entry or else not Restricted then
10509             Append_To (Args,
10510                Make_Attribute_Reference (Loc,
10511                  Prefix => Make_Identifier (Loc, Name_uInit),
10512                  Attribute_Name => Name_Address));
10513          end if;
10514
10515          if Has_Entry then
10516
10517             --  Entry_Bodies parameter. This is a pointer to an array of
10518             --  pointers to the entry body procedures and barrier functions of
10519             --  the object. If the protected type has no entries this object
10520             --  will not exist; in this case, pass a null.
10521
10522             P_Arr := Entry_Bodies_Array (Ptyp);
10523
10524             Append_To (Args,
10525               Make_Attribute_Reference (Loc,
10526                 Prefix => New_Reference_To (P_Arr, Loc),
10527                 Attribute_Name => Name_Unrestricted_Access));
10528
10529             if Abort_Allowed
10530               or else Restriction_Active (No_Entry_Queue) = False
10531               or else Number_Entries (Ptyp) > 1
10532               or else (Has_Attach_Handler (Ptyp) and then not Restricted)
10533             then
10534                --  Find index mapping function (clumsy but ok for now)
10535
10536                while Ekind (P_Arr) /= E_Function loop
10537                   Next_Entity (P_Arr);
10538                end loop;
10539
10540                Append_To (Args,
10541                   Make_Attribute_Reference (Loc,
10542                     Prefix =>
10543                       New_Reference_To (P_Arr, Loc),
10544                     Attribute_Name => Name_Unrestricted_Access));
10545             end if;
10546
10547          elsif not Restricted then
10548             Append_To (Args, Make_Null (Loc));
10549             Append_To (Args, Make_Null (Loc));
10550          end if;
10551
10552          if Abort_Allowed
10553            or else Restriction_Active (No_Entry_Queue) = False
10554            or else Number_Entries (Ptyp) > 1
10555            or else (Has_Attach_Handler (Ptyp)
10556                      and then not Restricted)
10557          then
10558             Append_To (L,
10559               Make_Procedure_Call_Statement (Loc,
10560                 Name => New_Reference_To (
10561                   RTE (RE_Initialize_Protection_Entries), Loc),
10562                 Parameter_Associations => Args));
10563
10564          elsif not Has_Entry and then Restricted then
10565             Append_To (L,
10566               Make_Procedure_Call_Statement (Loc,
10567                 Name => New_Reference_To (
10568                   RTE (RE_Initialize_Protection), Loc),
10569                 Parameter_Associations => Args));
10570
10571          else
10572             Append_To (L,
10573               Make_Procedure_Call_Statement (Loc,
10574                 Name => New_Reference_To (
10575                   RTE (RE_Initialize_Protection_Entry), Loc),
10576                 Parameter_Associations => Args));
10577          end if;
10578
10579       else
10580          Append_To (L,
10581            Make_Procedure_Call_Statement (Loc,
10582              Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
10583              Parameter_Associations => Args));
10584       end if;
10585
10586       if Has_Attach_Handler (Ptyp) then
10587
10588          --  We have a list of N Attach_Handler (ProcI, ExprI), and we have to
10589          --  make the following call:
10590
10591          --  Install_Handlers (_object,
10592          --    ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
10593
10594          --  or, in the case of Ravenscar:
10595
10596          --  Install_Handlers
10597          --    ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
10598
10599          declare
10600             Args  : constant List_Id := New_List;
10601             Table : constant List_Id := New_List;
10602             Ritem : Node_Id := First_Rep_Item (Ptyp);
10603
10604          begin
10605             if not Restricted then
10606
10607                --  Appends the _object argument
10608
10609                Append_To (Args,
10610                  Make_Attribute_Reference (Loc,
10611                    Prefix =>
10612                      Make_Selected_Component (Loc,
10613                        Prefix => Make_Identifier (Loc, Name_uInit),
10614                        Selector_Name => Make_Identifier (Loc, Name_uObject)),
10615                    Attribute_Name => Name_Unchecked_Access));
10616             end if;
10617
10618             --  Build the Attach_Handler table argument
10619
10620             while Present (Ritem) loop
10621                if Nkind (Ritem) = N_Pragma
10622                  and then Chars (Ritem) = Name_Attach_Handler
10623                then
10624                   declare
10625                      Handler : constant Node_Id :=
10626                                  First (Pragma_Argument_Associations (Ritem));
10627
10628                      Interrupt : constant Node_Id  := Next (Handler);
10629                      Expr      : constant  Node_Id := Expression (Interrupt);
10630
10631                   begin
10632                      Append_To (Table,
10633                        Make_Aggregate (Loc, Expressions => New_List (
10634                          Unchecked_Convert_To
10635                           (RTE (RE_System_Interrupt_Id), Expr),
10636                          Make_Attribute_Reference (Loc,
10637                            Prefix => Make_Selected_Component (Loc,
10638                               Make_Identifier (Loc, Name_uInit),
10639                               Duplicate_Subexpr_No_Checks
10640                                 (Expression (Handler))),
10641                            Attribute_Name => Name_Access))));
10642                   end;
10643                end if;
10644
10645                Next_Rep_Item (Ritem);
10646             end loop;
10647
10648             --  Append the table argument we just built
10649
10650             Append_To (Args, Make_Aggregate (Loc, Table));
10651
10652             --  Append the Install_Handler call to the statements
10653
10654             Append_To (L,
10655               Make_Procedure_Call_Statement (Loc,
10656                 Name => New_Reference_To (RTE (RE_Install_Handlers), Loc),
10657                 Parameter_Associations => Args));
10658          end;
10659       end if;
10660
10661       return L;
10662    end Make_Initialize_Protection;
10663
10664    ---------------------------
10665    -- Make_Task_Create_Call --
10666    ---------------------------
10667
10668    function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
10669       Loc    : constant Source_Ptr := Sloc (Task_Rec);
10670       Name   : Node_Id;
10671       Tdef   : Node_Id;
10672       Tdec   : Node_Id;
10673       Ttyp   : Node_Id;
10674       Tnam   : Name_Id;
10675       Args   : List_Id;
10676       Ecount : Node_Id;
10677
10678    begin
10679       Ttyp := Corresponding_Concurrent_Type (Task_Rec);
10680       Tnam := Chars (Ttyp);
10681
10682       --  Get task declaration. In the case of a task type declaration, this is
10683       --  simply the parent of the task type entity. In the single task
10684       --  declaration, this parent will be the implicit type, and we can find
10685       --  the corresponding single task declaration by searching forward in the
10686       --  declaration list in the tree.
10687
10688       --  Is the test for N_Single_Task_Declaration needed here??? Nodes of
10689       --  this type should have been removed during semantic analysis.
10690
10691       Tdec := Parent (Ttyp);
10692       while Nkind (Tdec) /= N_Task_Type_Declaration
10693         and then Nkind (Tdec) /= N_Single_Task_Declaration
10694       loop
10695          Next (Tdec);
10696       end loop;
10697
10698       --  Now we can find the task definition from this declaration
10699
10700       Tdef := Task_Definition (Tdec);
10701
10702       --  Build the parameter list for the call. Note that _Init is the name
10703       --  of the formal for the object to be initialized, which is the task
10704       --  value record itself.
10705
10706       Args := New_List;
10707
10708       --  Priority parameter. Set to Unspecified_Priority unless there is a
10709       --  priority pragma, in which case we take the value from the pragma.
10710
10711       if Present (Tdef) and then Has_Priority_Pragma (Tdef) then
10712          Append_To (Args,
10713            Make_Selected_Component (Loc,
10714              Prefix => Make_Identifier (Loc, Name_uInit),
10715              Selector_Name => Make_Identifier (Loc, Name_uPriority)));
10716       else
10717          Append_To (Args,
10718            New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
10719       end if;
10720
10721       --  Optional Stack parameter
10722
10723       if Restricted_Profile then
10724
10725          --  If the stack has been preallocated by the expander then
10726          --  pass its address. Otherwise, pass a null address.
10727
10728          if Preallocated_Stacks_On_Target then
10729             Append_To (Args,
10730               Make_Attribute_Reference (Loc,
10731                 Prefix         => Make_Selected_Component (Loc,
10732                   Prefix        => Make_Identifier (Loc, Name_uInit),
10733                   Selector_Name =>
10734                     Make_Identifier (Loc, Name_uStack)),
10735                 Attribute_Name => Name_Address));
10736
10737          else
10738             Append_To (Args,
10739               New_Reference_To (RTE (RE_Null_Address), Loc));
10740          end if;
10741       end if;
10742
10743       --  Size parameter. If no Storage_Size pragma is present, then
10744       --  the size is taken from the taskZ variable for the type, which
10745       --  is either Unspecified_Size, or has been reset by the use of
10746       --  a Storage_Size attribute definition clause. If a pragma is
10747       --  present, then the size is taken from the _Size field of the
10748       --  task value record, which was set from the pragma value.
10749
10750       if Present (Tdef)
10751         and then Has_Storage_Size_Pragma (Tdef)
10752       then
10753          Append_To (Args,
10754            Make_Selected_Component (Loc,
10755              Prefix => Make_Identifier (Loc, Name_uInit),
10756              Selector_Name => Make_Identifier (Loc, Name_uSize)));
10757
10758       else
10759          Append_To (Args,
10760            New_Reference_To (Storage_Size_Variable (Ttyp), Loc));
10761       end if;
10762
10763       --  Task_Info parameter. Set to Unspecified_Task_Info unless there is a
10764       --  Task_Info pragma, in which case we take the value from the pragma.
10765
10766       if Present (Tdef)
10767         and then Has_Task_Info_Pragma (Tdef)
10768       then
10769          Append_To (Args,
10770            Make_Selected_Component (Loc,
10771              Prefix => Make_Identifier (Loc, Name_uInit),
10772              Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
10773
10774       else
10775          Append_To (Args,
10776            New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc));
10777       end if;
10778
10779       if not Restricted_Profile then
10780
10781          --  Number of entries. This is an expression of the form:
10782          --
10783          --    n + _Init.a'Length + _Init.a'B'Length + ...
10784          --
10785          --  where a,b... are the entry family names for the task definition
10786
10787          Ecount := Build_Entry_Count_Expression (
10788            Ttyp,
10789            Component_Items (Component_List (
10790              Type_Definition (Parent (
10791                Corresponding_Record_Type (Ttyp))))),
10792            Loc);
10793          Append_To (Args, Ecount);
10794
10795          --  Master parameter. This is a reference to the _Master parameter of
10796          --  the initialization procedure, except in the case of the pragma
10797          --  Restrictions (No_Task_Hierarchy) where the value is fixed to 3.
10798          --  See comments in System.Tasking.Initialization.Init_RTS for the
10799          --  value 3.
10800
10801          if Restriction_Active (No_Task_Hierarchy) = False then
10802             Append_To (Args, Make_Identifier (Loc, Name_uMaster));
10803          else
10804             Append_To (Args, Make_Integer_Literal (Loc, 3));
10805          end if;
10806       end if;
10807
10808       --  State parameter. This is a pointer to the task body procedure. The
10809       --  required value is obtained by taking the address of the task body
10810       --  procedure and converting it (with an unchecked conversion) to the
10811       --  type required by the task kernel. For further details, see the
10812       --  description of Expand_Task_Body
10813
10814       Append_To (Args,
10815         Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
10816           Make_Attribute_Reference (Loc,
10817             Prefix =>
10818               New_Occurrence_Of (Get_Task_Body_Procedure (Ttyp), Loc),
10819             Attribute_Name => Name_Address)));
10820
10821       --  Discriminants parameter. This is just the address of the task
10822       --  value record itself (which contains the discriminant values
10823
10824       Append_To (Args,
10825         Make_Attribute_Reference (Loc,
10826           Prefix => Make_Identifier (Loc, Name_uInit),
10827           Attribute_Name => Name_Address));
10828
10829       --  Elaborated parameter. This is an access to the elaboration Boolean
10830
10831       Append_To (Args,
10832         Make_Attribute_Reference (Loc,
10833           Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
10834           Attribute_Name => Name_Unchecked_Access));
10835
10836       --  Chain parameter. This is a reference to the _Chain parameter of
10837       --  the initialization procedure.
10838
10839       Append_To (Args, Make_Identifier (Loc, Name_uChain));
10840
10841       --  Task name parameter. Take this from the _Task_Id parameter to the
10842       --  init call unless there is a Task_Name pragma, in which case we take
10843       --  the value from the pragma.
10844
10845       if Present (Tdef)
10846         and then Has_Task_Name_Pragma (Tdef)
10847       then
10848          Append_To (Args,
10849            New_Copy (
10850              Expression (First (
10851                Pragma_Argument_Associations (
10852                  Find_Task_Or_Protected_Pragma
10853                    (Tdef, Name_Task_Name))))));
10854
10855       else
10856          Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
10857       end if;
10858
10859       --  Created_Task parameter. This is the _Task_Id field of the task
10860       --  record value
10861
10862       Append_To (Args,
10863         Make_Selected_Component (Loc,
10864           Prefix => Make_Identifier (Loc, Name_uInit),
10865           Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
10866
10867       if Restricted_Profile then
10868          Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
10869       else
10870          Name := New_Reference_To (RTE (RE_Create_Task), Loc);
10871       end if;
10872
10873       return Make_Procedure_Call_Statement (Loc,
10874         Name => Name, Parameter_Associations => Args);
10875    end Make_Task_Create_Call;
10876
10877    ------------------------------
10878    -- Next_Protected_Operation --
10879    ------------------------------
10880
10881    function Next_Protected_Operation (N : Node_Id) return Node_Id is
10882       Next_Op : Node_Id;
10883
10884    begin
10885       Next_Op := Next (N);
10886       while Present (Next_Op)
10887         and then Nkind (Next_Op) /= N_Subprogram_Body
10888         and then Nkind (Next_Op) /= N_Entry_Body
10889       loop
10890          Next (Next_Op);
10891       end loop;
10892
10893       return Next_Op;
10894    end Next_Protected_Operation;
10895
10896    --------------------------
10897    -- Parameter_Block_Pack --
10898    --------------------------
10899
10900    function Parameter_Block_Pack
10901      (Loc     : Source_Ptr;
10902       Blk_Typ : Entity_Id;
10903       Actuals : List_Id;
10904       Formals : List_Id;
10905       Decls   : List_Id;
10906       Stmts   : List_Id) return Node_Id
10907    is
10908       Actual    : Entity_Id;
10909       Expr      : Node_Id := Empty;
10910       Formal    : Entity_Id;
10911       Has_Param : Boolean := False;
10912       P         : Entity_Id;
10913       Params    : List_Id;
10914       Temp_Asn  : Node_Id;
10915       Temp_Nam  : Node_Id;
10916
10917    begin
10918       Actual := First (Actuals);
10919       Formal := Defining_Identifier (First (Formals));
10920       Params := New_List;
10921
10922       while Present (Actual) loop
10923          if Is_By_Copy_Type (Etype (Actual)) then
10924             --  Generate:
10925             --    Jnn : aliased <formal-type>
10926
10927             Temp_Nam :=
10928               Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
10929
10930             Append_To (Decls,
10931               Make_Object_Declaration (Loc,
10932                 Aliased_Present =>
10933                   True,
10934                 Defining_Identifier =>
10935                   Temp_Nam,
10936                 Object_Definition =>
10937                   New_Reference_To (Etype (Formal), Loc)));
10938
10939             if Ekind (Formal) /= E_Out_Parameter then
10940
10941                --  Generate:
10942                --    Jnn := <actual>
10943
10944                Temp_Asn :=
10945                  New_Reference_To (Temp_Nam, Loc);
10946
10947                Set_Assignment_OK (Temp_Asn);
10948
10949                Append_To (Stmts,
10950                  Make_Assignment_Statement (Loc,
10951                    Name =>
10952                      Temp_Asn,
10953                    Expression =>
10954                      New_Copy_Tree (Actual)));
10955             end if;
10956
10957             --  Generate:
10958             --    Jnn'unchecked_access
10959
10960             Append_To (Params,
10961               Make_Attribute_Reference (Loc,
10962                 Attribute_Name =>
10963                   Name_Unchecked_Access,
10964                 Prefix =>
10965                   New_Reference_To (Temp_Nam, Loc)));
10966
10967             Has_Param := True;
10968
10969          --  The controlling parameter is omitted
10970
10971          else
10972             if not Is_Controlling_Actual (Actual) then
10973                Append_To (Params,
10974                  Make_Reference (Loc, New_Copy_Tree (Actual)));
10975
10976                Has_Param := True;
10977             end if;
10978          end if;
10979
10980          Next_Actual (Actual);
10981          Next_Formal_With_Extras (Formal);
10982       end loop;
10983
10984       if Has_Param then
10985          Expr := Make_Aggregate (Loc, Params);
10986       end if;
10987
10988       --  Generate:
10989       --    P : Ann := (
10990       --      J1'unchecked_access;
10991       --      <actual2>'reference;
10992       --      ...);
10993
10994       P := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
10995
10996       Append_To (Decls,
10997         Make_Object_Declaration (Loc,
10998           Defining_Identifier =>
10999             P,
11000           Object_Definition =>
11001             New_Reference_To (Blk_Typ, Loc),
11002           Expression =>
11003             Expr));
11004
11005       return P;
11006    end Parameter_Block_Pack;
11007
11008    ----------------------------
11009    -- Parameter_Block_Unpack --
11010    ----------------------------
11011
11012    function Parameter_Block_Unpack
11013      (Loc     : Source_Ptr;
11014       P       : Entity_Id;
11015       Actuals : List_Id;
11016       Formals : List_Id) return List_Id
11017    is
11018       Actual    : Entity_Id;
11019       Asnmt     : Node_Id;
11020       Formal    : Entity_Id;
11021       Has_Asnmt : Boolean := False;
11022       Result    : constant List_Id := New_List;
11023
11024    begin
11025       Actual := First (Actuals);
11026       Formal := Defining_Identifier (First (Formals));
11027       while Present (Actual) loop
11028          if Is_By_Copy_Type (Etype (Actual))
11029            and then Ekind (Formal) /= E_In_Parameter
11030          then
11031             --  Generate:
11032             --    <actual> := P.<formal>;
11033
11034             Asnmt :=
11035               Make_Assignment_Statement (Loc,
11036                 Name =>
11037                   New_Copy (Actual),
11038                 Expression =>
11039                   Make_Explicit_Dereference (Loc,
11040                     Make_Selected_Component (Loc,
11041                       Prefix =>
11042                         New_Reference_To (P, Loc),
11043                       Selector_Name =>
11044                         Make_Identifier (Loc, Chars (Formal)))));
11045
11046             Set_Assignment_OK (Name (Asnmt));
11047             Append_To (Result, Asnmt);
11048
11049             Has_Asnmt := True;
11050          end if;
11051
11052          Next_Actual (Actual);
11053          Next_Formal_With_Extras (Formal);
11054       end loop;
11055
11056       if Has_Asnmt then
11057          return Result;
11058       else
11059          return New_List (Make_Null_Statement (Loc));
11060       end if;
11061    end Parameter_Block_Unpack;
11062
11063    ----------------------
11064    -- Set_Discriminals --
11065    ----------------------
11066
11067    procedure Set_Discriminals (Dec : Node_Id) is
11068       D       : Entity_Id;
11069       Pdef    : Entity_Id;
11070       D_Minal : Entity_Id;
11071
11072    begin
11073       pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
11074       Pdef := Defining_Identifier (Dec);
11075
11076       if Has_Discriminants (Pdef) then
11077          D := First_Discriminant (Pdef);
11078          while Present (D) loop
11079             D_Minal :=
11080               Make_Defining_Identifier (Sloc (D),
11081                 Chars => New_External_Name (Chars (D), 'D'));
11082
11083             Set_Ekind (D_Minal, E_Constant);
11084             Set_Etype (D_Minal, Etype (D));
11085             Set_Scope (D_Minal, Pdef);
11086             Set_Discriminal (D, D_Minal);
11087             Set_Discriminal_Link (D_Minal, D);
11088
11089             Next_Discriminant (D);
11090          end loop;
11091       end if;
11092    end Set_Discriminals;
11093
11094    -----------------
11095    -- Set_Privals --
11096    -----------------
11097
11098    procedure Set_Privals
11099       (Dec           : Node_Id;
11100        Op            : Node_Id;
11101        Loc           : Source_Ptr;
11102        After_Barrier : Boolean := False)
11103    is
11104       P_Decl      : Node_Id;
11105       P_Id        : Entity_Id;
11106       Priv        : Entity_Id;
11107       Def         : Node_Id;
11108       Body_Ent    : Entity_Id;
11109       For_Barrier : constant Boolean :=
11110                       Nkind (Op) = N_Entry_Body and then not After_Barrier;
11111
11112       Prec_Decl : constant Node_Id :=
11113                     Parent (Corresponding_Record_Type
11114                              (Defining_Identifier (Dec)));
11115       Prec_Def  : constant Entity_Id := Type_Definition (Prec_Decl);
11116       Obj_Decl  : Node_Id;
11117       P_Subtype : Entity_Id;
11118       Assoc_L   : constant Elist_Id := New_Elmt_List;
11119       Op_Id     : Entity_Id;
11120
11121    begin
11122       pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
11123       pragma Assert
11124         (Nkind (Op) = N_Subprogram_Body or else Nkind (Op) = N_Entry_Body);
11125
11126       Def := Protected_Definition (Dec);
11127
11128       if Present (Private_Declarations (Def)) then
11129          P_Decl := First (Private_Declarations (Def));
11130          while Present (P_Decl) loop
11131             if Nkind (P_Decl) = N_Component_Declaration then
11132                P_Id := Defining_Identifier (P_Decl);
11133
11134                if For_Barrier then
11135                   Priv :=
11136                     Make_Defining_Identifier (Loc,
11137                       Chars => New_External_Name (Chars (P_Id), 'P'));
11138                else
11139                   Priv :=
11140                     Make_Defining_Identifier (Loc,
11141                       Chars => New_External_Name (Chars (P_Id)));
11142                end if;
11143
11144                Set_Ekind     (Priv, E_Variable);
11145                Set_Etype     (Priv, Etype (P_Id));
11146                Set_Scope     (Priv, Scope (P_Id));
11147                Set_Esize     (Priv, Esize (Etype (P_Id)));
11148                Set_Alignment (Priv, Alignment (Etype (P_Id)));
11149
11150                --  If the type of the component is an itype, we must create a
11151                --  new itype for the corresponding prival in each protected
11152                --  operation, to avoid scoping problems. We create new itypes
11153                --  by copying the tree for the component definition.
11154
11155                if Is_Itype (Etype (P_Id)) then
11156                   Append_Elmt (P_Id, Assoc_L);
11157                   Append_Elmt (Priv, Assoc_L);
11158
11159                   if Nkind (Op) = N_Entry_Body then
11160                      Op_Id := Defining_Identifier (Op);
11161                   else
11162                      Op_Id := Defining_Unit_Name (Specification (Op));
11163                   end if;
11164
11165                   Discard_Node
11166                     (New_Copy_Tree (P_Decl, Assoc_L, New_Scope => Op_Id));
11167                end if;
11168
11169                Set_Protected_Operation (P_Id, Op);
11170                Set_Prival (P_Id, Priv);
11171             end if;
11172
11173             Next (P_Decl);
11174          end loop;
11175       end if;
11176
11177       --  There is one more implicit private decl: the object itself. "prival"
11178       --  for this is attached to the protected body defining identifier.
11179
11180       Body_Ent := Corresponding_Body (Dec);
11181
11182       Priv :=
11183         Make_Defining_Identifier (Sloc (Body_Ent),
11184           Chars => New_External_Name (Chars (Body_Ent), 'R'));
11185
11186       --  Set the Etype to the implicit subtype of Protection created when
11187       --  the protected type declaration was expanded. This node will not
11188       --  be analyzed until it is used as the defining identifier for the
11189       --  renaming declaration in the protected operation body, and it will
11190       --  be needed in the references expanded before that body is expanded.
11191       --  Since the Protection field is aliased, set Is_Aliased as well.
11192
11193       Obj_Decl := First (Component_Items (Component_List (Prec_Def)));
11194       while Chars (Defining_Identifier (Obj_Decl)) /= Name_uObject loop
11195          Next (Obj_Decl);
11196       end loop;
11197
11198       P_Subtype  := Etype (Defining_Identifier (Obj_Decl));
11199       Set_Ekind (Priv, E_Variable);
11200       Set_Etype (Priv, P_Subtype);
11201       Set_Is_Aliased (Priv);
11202       Set_Object_Ref (Body_Ent, Priv);
11203    end Set_Privals;
11204
11205    ----------------------------
11206    -- Update_Prival_Subtypes --
11207    ----------------------------
11208
11209    procedure Update_Prival_Subtypes (N : Node_Id) is
11210
11211       function Process (N : Node_Id) return Traverse_Result;
11212       --  Update the etype of occurrences of privals whose etype does not
11213       --  match the current Etype of the prival entity itself.
11214
11215       procedure Update_Array_Bounds (E : Entity_Id);
11216       --  Itypes generated for array expressions may depend on the
11217       --  determinants of the protected object, and need to be processed
11218       --  separately because they are not attached to the tree.
11219
11220       procedure Update_Index_Types (N : Node_Id);
11221       --  Similarly, update the types of expressions in indexed components
11222       --  which may depend on other discriminants.
11223
11224       -------------
11225       -- Process --
11226       -------------
11227
11228       function Process (N : Node_Id) return Traverse_Result is
11229       begin
11230          if Is_Entity_Name (N)  then
11231             declare
11232                E : constant Entity_Id := Entity (N);
11233             begin
11234                if Present (E)
11235                  and then (Ekind (E) = E_Constant
11236                             or else Ekind (E) = E_Variable)
11237                  and then Nkind (Parent (E)) = N_Object_Renaming_Declaration
11238                  and then not Is_Scalar_Type (Etype (E))
11239                  and then Etype (N) /= Etype (E)
11240                then
11241                   Set_Etype (N, Etype (Entity (Original_Node (N))));
11242                   Update_Index_Types (N);
11243
11244                elsif Present (E)
11245                  and then Ekind (E) = E_Constant
11246                  and then Present (Discriminal_Link (E))
11247                then
11248                   Set_Etype (N, Etype (E));
11249                end if;
11250             end;
11251
11252             return OK;
11253
11254          elsif Nkind (N) = N_Defining_Identifier
11255            or else Nkind (N) = N_Defining_Operator_Symbol
11256            or else Nkind (N) = N_Defining_Character_Literal
11257          then
11258             return Skip;
11259
11260          elsif Nkind (N) = N_String_Literal then
11261
11262             --  Array type, but bounds are constant
11263
11264             return OK;
11265
11266          elsif Nkind (N) = N_Object_Declaration
11267            and then Is_Itype (Etype (Defining_Identifier (N)))
11268            and then Is_Array_Type (Etype (Defining_Identifier (N)))
11269          then
11270             Update_Array_Bounds (Etype (Defining_Identifier (N)));
11271             return OK;
11272
11273          --  For array components of discriminated records, use the base type
11274          --  directly, because it may depend indirectly on the discriminants of
11275          --  the protected type.
11276
11277          --  Cleaner would be a systematic mechanism to compute actual subtypes
11278          --  of private components???
11279
11280          elsif Nkind (N) in N_Has_Etype
11281            and then Present (Etype (N))
11282            and then Is_Array_Type (Etype (N))
11283            and then Nkind (N) = N_Selected_Component
11284            and then Has_Discriminants (Etype (Prefix (N)))
11285          then
11286             Set_Etype (N, Base_Type (Etype (N)));
11287             Update_Index_Types (N);
11288             return OK;
11289
11290          else
11291             if Nkind (N) in N_Has_Etype
11292               and then Present (Etype (N))
11293               and then Is_Itype (Etype (N)) then
11294
11295                if Is_Array_Type (Etype (N)) then
11296                   Update_Array_Bounds (Etype (N));
11297
11298                elsif Is_Scalar_Type (Etype (N)) then
11299                   Update_Prival_Subtypes (Type_Low_Bound  (Etype (N)));
11300                   Update_Prival_Subtypes (Type_High_Bound (Etype (N)));
11301                end if;
11302             end if;
11303
11304             return OK;
11305          end if;
11306       end Process;
11307
11308       -------------------------
11309       -- Update_Array_Bounds --
11310       -------------------------
11311
11312       procedure Update_Array_Bounds (E : Entity_Id) is
11313          Ind : Node_Id;
11314       begin
11315          Ind := First_Index (E);
11316          while Present (Ind) loop
11317             Update_Prival_Subtypes (Type_Low_Bound  (Etype (Ind)));
11318             Update_Prival_Subtypes (Type_High_Bound (Etype (Ind)));
11319             Next_Index (Ind);
11320          end loop;
11321       end Update_Array_Bounds;
11322
11323       ------------------------
11324       -- Update_Index_Types --
11325       ------------------------
11326
11327       procedure Update_Index_Types (N : Node_Id) is
11328          Indx1 : Node_Id;
11329          I_Typ : Node_Id;
11330
11331       begin
11332          --  If the prefix has an actual subtype that is different from the
11333          --  nominal one, update the types of the indices, so that the proper
11334          --  constraints are applied. Do not apply this transformation to a
11335          --  packed array, where the index type is computed for a byte array
11336          --  and is different from the source index.
11337
11338          if Nkind (Parent (N)) = N_Indexed_Component
11339            and then
11340              not Is_Bit_Packed_Array (Etype (Prefix (Parent (N))))
11341          then
11342             Indx1 := First (Expressions (Parent (N)));
11343             I_Typ := First_Index (Etype (N));
11344
11345             while Present (Indx1) and then Present (I_Typ) loop
11346
11347                if not Is_Entity_Name (Indx1) then
11348                   Set_Etype (Indx1, Base_Type (Etype (I_Typ)));
11349                end if;
11350
11351                Next (Indx1);
11352                Next_Index (I_Typ);
11353             end loop;
11354          end if;
11355       end Update_Index_Types;
11356
11357       procedure Traverse is new Traverse_Proc;
11358
11359    --  Start of processing for Update_Prival_Subtypes
11360
11361    begin
11362       Traverse (N);
11363    end Update_Prival_Subtypes;
11364
11365 end Exp_Ch9;