gcc/ada/exp_ch9.adb

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