gcc/ada/exp_ch9.adb

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