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-2004, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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_Smem; use Exp_Smem;
  37 with Exp_Tss;  use Exp_Tss;
  38 with Exp_Util; use Exp_Util;
  39 with Freeze;   use Freeze;
  40 with Hostparm;
  41 with Namet;    use Namet;
  42 with Nlists;   use Nlists;
  43 with Nmake;    use Nmake;
  44 with Opt;      use Opt;
  45 with Restrict; use Restrict;
  46 with Rident;   use Rident;
  47 with Rtsfind;  use Rtsfind;
  48 with Sem;      use Sem;
  49 with Sem_Ch6;
  50 with Sem_Ch8;  use Sem_Ch8;
  51 with Sem_Ch11; use Sem_Ch11;
  52 with Sem_Elab; use Sem_Elab;
  53 with Sem_Res;  use Sem_Res;
  54 with Sem_Util; use Sem_Util;
  55 with Sinfo;    use Sinfo;
  56 with Snames;   use Snames;
  57 with Stand;    use Stand;
  58 with Tbuild;   use Tbuild;
  59 with Types;    use Types;
  60 with Uintp;    use Uintp;
  61 with Opt;
  62
  63 package body Exp_Ch9 is
  64
  65    -----------------------
  66    -- Local Subprograms --
  67    -----------------------
  68
  69    function Actual_Index_Expression
  70      (Sloc  : Source_Ptr;
  71       Ent   : Entity_Id;
  72       Index : Node_Id;
  73       Tsk   : Entity_Id) return Node_Id;
  74    --  Compute the index position for an entry call. Tsk is the target
  75    --  task. If the bounds of some entry family depend on discriminants,
  76    --  the expression computed by this function uses the discriminants
  77    --  of the target task.
  78
  79    function Index_Constant_Declaration
  80      (N        : Node_Id;
  81       Index_Id : Entity_Id;
  82       Prot     : Entity_Id) return List_Id;
  83    --  For an entry family and its barrier function, we define a local entity
  84    --  that maps the index in the call into the entry index into the object:
  85    --
  86    --     I : constant Index_Type := Index_Type'Val (
  87    --       E - <<index of first family member>> +
  88    --       Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
  89
  90    procedure Add_Object_Pointer
  91      (Decls : List_Id;
  92       Pid   : Entity_Id;
  93       Loc   : Source_Ptr);
  94    --  Prepend an object pointer declaration to the declaration list
  95    --  Decls. This object pointer is initialized to a type conversion
  96    --  of the System.Address pointer passed to entry barrier functions
  97    --  and entry body procedures.
  98
  99    function Build_Accept_Body (Astat : Node_Id) return  Node_Id;
 100    --  Transform accept statement into a block with added exception handler.
 101    --  Used both for simple accept statements and for accept alternatives in
 102    --  select statements. Astat is the accept statement.
 103
 104    function Build_Barrier_Function
 105      (N    : Node_Id;
 106       Ent  : Entity_Id;
 107       Pid  : Node_Id) return Node_Id;
 108    --  Build the function body returning the value of the barrier expression
 109    --  for the specified entry body.
 110
 111    function Build_Barrier_Function_Specification
 112      (Def_Id : Entity_Id;
 113       Loc    : Source_Ptr) return Node_Id;
 114    --  Build a specification for a function implementing
 115    --  the protected entry barrier of the specified entry body.
 116
 117    function Build_Corresponding_Record
 118      (N    : Node_Id;
 119       Ctyp : Node_Id;
 120       Loc  : Source_Ptr) return Node_Id;
 121    --  Common to tasks and protected types. Copy discriminant specifications,
 122    --  build record declaration. N is the type declaration, Ctyp is the
 123    --  concurrent entity (task type or protected type).
 124
 125    function Build_Entry_Count_Expression
 126      (Concurrent_Type : Node_Id;
 127       Component_List  : List_Id;
 128       Loc             : Source_Ptr) return Node_Id;
 129    --  Compute number of entries for concurrent object. This is a count of
 130    --  simple entries, followed by an expression that computes the length
 131    --  of the range of each entry family. A single array with that size is
 132    --  allocated for each concurrent object of the type.
 133
 134    function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
 135    --  Build the function that translates the entry index in the call
 136    --  (which depends on the size of entry families) into an index into the
 137    --  Entry_Bodies_Array, to determine the body and barrier function used
 138    --  in a protected entry call. A pointer to this function appears in every
 139    --  protected object.
 140
 141    function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
 142    --  Build subprogram declaration for previous one
 143
 144    function Build_Protected_Entry
 145      (N   : Node_Id;
 146       Ent : Entity_Id;
 147       Pid : Node_Id) return Node_Id;
 148    --  Build the procedure implementing the statement sequence of
 149    --  the specified entry body.
 150
 151    function Build_Protected_Entry_Specification
 152      (Def_Id : Entity_Id;
 153       Ent_Id : Entity_Id;
 154       Loc    : Source_Ptr) return Node_Id;
 155    --  Build a specification for a procedure implementing
 156    --  the statement sequence of the specified entry body.
 157    --  Add attributes associating it with the entry defining identifier
 158    --  Ent_Id.
 159
 160    function Build_Protected_Subprogram_Body
 161      (N         : Node_Id;
 162       Pid       : Node_Id;
 163       N_Op_Spec : Node_Id) return Node_Id;
 164    --  This function is used to construct the protected version of a protected
 165    --  subprogram. Its statement sequence first defers abortion, then locks
 166    --  the associated protected object, and then enters a block that contains
 167    --  a call to the unprotected version of the subprogram (for details, see
 168    --  Build_Unprotected_Subprogram_Body). This block statement requires
 169    --  a cleanup handler that unlocks the object in all cases.
 170    --  (see Exp_Ch7.Expand_Cleanup_Actions).
 171
 172    function Build_Protected_Spec
 173      (N           : Node_Id;
 174       Obj_Type    : Entity_Id;
 175       Unprotected : Boolean := False;
 176       Ident       : Entity_Id) return List_Id;
 177    --  Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
 178    --  Subprogram_Type. Builds signature of protected subprogram, adding the
 179    --  formal that corresponds to the object itself. For an access to protected
 180    --  subprogram, there is no object type to specify, so the additional
 181    --  parameter has type Address and mode In. An indirect call through such
 182    --  a pointer converts the address to a reference to the actual object.
 183    --  The object is a limited record and therefore a by_reference type.
 184
 185    function Build_Selected_Name
 186      (Prefix, Selector : Name_Id;
 187       Append_Char      : Character := ' ') return Name_Id;
 188    --  Build a name in the form of Prefix__Selector, with an optional
 189    --  character appended. This is used for internal subprograms generated
 190    --  for operations of protected types, including barrier functions. In
 191    --  order to simplify the work of the debugger, the prefix includes the
 192    --  characters PT. For the subprograms generated for entry bodies and
 193    --  entry barriers, the generated name includes a sequence number that
 194    --  makes names unique in the presence of entry overloading. This is
 195    --  necessary because entry body procedures and barrier functions all
 196    --  have the same signature.
 197
 198    procedure Build_Simple_Entry_Call
 199      (N       : Node_Id;
 200       Concval : Node_Id;
 201       Ename   : Node_Id;
 202       Index   : Node_Id);
 203    --  Some comments here would be useful ???
 204
 205    function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
 206    --  This routine constructs a specification for the procedure that we will
 207    --  build for the task body for task type T. The spec has the form:
 208    --
 209    --    procedure tnameB (_Task : access tnameV);
 210    --
 211    --  where name is the character name taken from the task type entity that
 212    --  is passed as the argument to the procedure, and tnameV is the task
 213    --  value type that is associated with the task type.
 214
 215    function Build_Unprotected_Subprogram_Body
 216      (N   : Node_Id;
 217       Pid : Node_Id) return Node_Id;
 218    --  This routine constructs the unprotected version of a protected
 219    --  subprogram body, which is contains all of the code in the
 220    --  original, unexpanded body. This is the version of the protected
 221    --  subprogram that is called from all protected operations on the same
 222    --  object, including the protected version of the same subprogram.
 223
 224    procedure Collect_Entry_Families
 225      (Loc          : Source_Ptr;
 226       Cdecls       : List_Id;
 227       Current_Node : in out Node_Id;
 228       Conctyp      : Entity_Id);
 229    --  For each entry family in a concurrent type, create an anonymous array
 230    --  type of the right size, and add a component to the corresponding_record.
 231
 232    function Family_Offset
 233      (Loc  : Source_Ptr;
 234       Hi   : Node_Id;
 235       Lo   : Node_Id;
 236       Ttyp : Entity_Id) return Node_Id;
 237    --  Compute (Hi - Lo) for two entry family indices. Hi is the index in
 238    --  an accept statement, or the upper bound in the discrete subtype of
 239    --  an entry declaration. Lo is the corresponding lower bound. Ttyp is
 240    --  the concurrent type of the entry.
 241
 242    function Family_Size
 243      (Loc  : Source_Ptr;
 244       Hi   : Node_Id;
 245       Lo   : Node_Id;
 246       Ttyp : Entity_Id) return Node_Id;
 247    --  Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
 248    --  a family, and handle properly the superflat case. This is equivalent
 249    --  to the use of 'Length on the index type, but must use Family_Offset
 250    --  to handle properly the case of bounds that depend on discriminants.
 251
 252    procedure Extract_Entry
 253      (N       : Node_Id;
 254       Concval : out Node_Id;
 255       Ename   : out Node_Id;
 256       Index   : out Node_Id);
 257    --  Given an entry call, returns the associated concurrent object,
 258    --  the entry name, and the entry family index.
 259
 260    function Find_Task_Or_Protected_Pragma
 261      (T : Node_Id;
 262       P : Name_Id) return Node_Id;
 263    --  Searches the task or protected definition T for the first occurrence
 264    --  of the pragma whose name is given by P. The caller has ensured that
 265    --  the pragma is present in the task definition. A special case is that
 266    --  when P is Name_uPriority, the call will also find Interrupt_Priority.
 267    --  ??? Should be implemented with the rep item chain mechanism.
 268
 269    procedure Update_Prival_Subtypes (N : Node_Id);
 270    --  The actual subtypes of the privals will differ from the type of the
 271    --  private declaration in the original protected type, if the protected
 272    --  type has discriminants or if the prival has constrained components.
 273    --  This is because the privals are generated out of sequence w.r.t. the
 274    --  analysis of a protected body. After generating the bodies for protected
 275    --  operations, we set correctly the type of all references to privals, by
 276    --  means of a recursive tree traversal, which is heavy-handed but
 277    --  correct.
 278
 279    -----------------------------
 280    -- Actual_Index_Expression --
 281    -----------------------------
 282
 283    function Actual_Index_Expression
 284      (Sloc  : Source_Ptr;
 285       Ent   : Entity_Id;
 286       Index : Node_Id;
 287       Tsk   : Entity_Id) return Node_Id
 288    is
 289       Ttyp : constant Entity_Id := Etype (Tsk);
 290       Expr : Node_Id;
 291       Num  : Node_Id;
 292       Lo   : Node_Id;
 293       Hi   : Node_Id;
 294       Prev : Entity_Id;
 295       S    : Node_Id;
 296
 297       function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
 298       --  Compute difference between bounds of entry family.
 299
 300       --------------------------
 301       -- Actual_Family_Offset --
 302       --------------------------
 303
 304       function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
 305
 306          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
 307          --  Replace a reference to a discriminant with a selected component
 308          --  denoting the discriminant of the target task.
 309
 310          -----------------------------
 311          -- Actual_Discriminant_Ref --
 312          -----------------------------
 313
 314          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
 315             Typ : constant Entity_Id := Etype (Bound);
 316             B   : Node_Id;
 317
 318          begin
 319             if not Is_Entity_Name (Bound)
 320               or else Ekind (Entity (Bound)) /= E_Discriminant
 321             then
 322                if Nkind (Bound) = N_Attribute_Reference then
 323                   return Bound;
 324                else
 325                   B := New_Copy_Tree (Bound);
 326                end if;
 327
 328             else
 329                B :=
 330                  Make_Selected_Component (Sloc,
 331                    Prefix => New_Copy_Tree (Tsk),
 332                    Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
 333
 334                Analyze_And_Resolve (B, Typ);
 335             end if;
 336
 337             return
 338               Make_Attribute_Reference (Sloc,
 339                 Attribute_Name => Name_Pos,
 340                 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
 341                 Expressions => New_List (B));
 342          end Actual_Discriminant_Ref;
 343
 344       --  Start of processing for Actual_Family_Offset
 345
 346       begin
 347          return
 348            Make_Op_Subtract (Sloc,
 349              Left_Opnd  => Actual_Discriminant_Ref (Hi),
 350              Right_Opnd => Actual_Discriminant_Ref (Lo));
 351       end Actual_Family_Offset;
 352
 353    --  Start of processing for Actual_Index_Expression
 354
 355    begin
 356       --  The queues of entries and entry families appear in  textual
 357       --  order in the associated record. The entry index is computed as
 358       --  the sum of the number of queues for all entries that precede the
 359       --  designated one, to which is added the index expression, if this
 360       --  expression denotes a member of a family.
 361
 362       --  The following is a place holder for the count of simple entries.
 363
 364       Num := Make_Integer_Literal (Sloc, 1);
 365
 366       --  We construct an expression which is a series of addition
 367       --  operations. See comments in Entry_Index_Expression, which is
 368       --  identical in structure.
 369
 370       if Present (Index) then
 371          S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
 372
 373          Expr :=
 374            Make_Op_Add (Sloc,
 375              Left_Opnd  => Num,
 376
 377              Right_Opnd =>
 378                Actual_Family_Offset (
 379                  Make_Attribute_Reference (Sloc,
 380                    Attribute_Name => Name_Pos,
 381                    Prefix => New_Reference_To (Base_Type (S), Sloc),
 382                    Expressions => New_List (Relocate_Node (Index))),
 383                  Type_Low_Bound (S)));
 384       else
 385          Expr := Num;
 386       end if;
 387
 388       --  Now add lengths of preceding entries and entry families.
 389
 390       Prev := First_Entity (Ttyp);
 391
 392       while Chars (Prev) /= Chars (Ent)
 393         or else (Ekind (Prev) /= Ekind (Ent))
 394         or else not Sem_Ch6.Type_Conformant (Ent, Prev)
 395       loop
 396          if Ekind (Prev) = E_Entry then
 397             Set_Intval (Num, Intval (Num) + 1);
 398
 399          elsif Ekind (Prev) = E_Entry_Family then
 400             S :=
 401               Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
 402             Lo := Type_Low_Bound  (S);
 403             Hi := Type_High_Bound (S);
 404
 405             Expr :=
 406               Make_Op_Add (Sloc,
 407               Left_Opnd  => Expr,
 408               Right_Opnd =>
 409                 Make_Op_Add (Sloc,
 410                   Left_Opnd =>
 411                     Actual_Family_Offset (Hi, Lo),
 412                   Right_Opnd =>
 413                     Make_Integer_Literal (Sloc, 1)));
 414
 415          --  Other components are anonymous types to be ignored.
 416
 417          else
 418             null;
 419          end if;
 420
 421          Next_Entity (Prev);
 422       end loop;
 423
 424       return Expr;
 425    end Actual_Index_Expression;
 426
 427    ----------------------------------
 428    -- Add_Discriminal_Declarations --
 429    ----------------------------------
 430
 431    procedure Add_Discriminal_Declarations
 432      (Decls : List_Id;
 433       Typ   : Entity_Id;
 434       Name  : Name_Id;
 435       Loc   : Source_Ptr)
 436    is
 437       D     : Entity_Id;
 438
 439    begin
 440       if Has_Discriminants (Typ) then
 441          D := First_Discriminant (Typ);
 442
 443          while Present (D) loop
 444
 445             Prepend_To (Decls,
 446               Make_Object_Renaming_Declaration (Loc,
 447                 Defining_Identifier => Discriminal (D),
 448                 Subtype_Mark => New_Reference_To (Etype (D), Loc),
 449                 Name =>
 450                   Make_Selected_Component (Loc,
 451                     Prefix        => Make_Identifier (Loc, Name),
 452                     Selector_Name => Make_Identifier (Loc, Chars (D)))));
 453
 454             Next_Discriminant (D);
 455          end loop;
 456       end if;
 457    end Add_Discriminal_Declarations;
 458
 459    ------------------------
 460    -- Add_Object_Pointer --
 461    ------------------------
 462
 463    procedure Add_Object_Pointer
 464      (Decls : List_Id;
 465       Pid   : Entity_Id;
 466       Loc   : Source_Ptr)
 467    is
 468       Obj_Ptr : Node_Id;
 469
 470    begin
 471       --  Prepend the declaration of _object. This must be first in the
 472       --  declaration list, since it is used by the discriminal and
 473       --  prival declarations.
 474       --  ??? An attempt to make this a renaming was unsuccessful.
 475       --
 476       --     type poVP is access poV;
 477       --     _object : poVP := poVP!O;
 478
 479       Obj_Ptr :=
 480         Make_Defining_Identifier (Loc,
 481           Chars =>
 482             New_External_Name
 483               (Chars (Corresponding_Record_Type (Pid)), 'P'));
 484
 485       Prepend_To (Decls,
 486         Make_Object_Declaration (Loc,
 487           Defining_Identifier =>
 488             Make_Defining_Identifier (Loc, Name_uObject),
 489           Object_Definition => New_Reference_To (Obj_Ptr, Loc),
 490           Expression =>
 491             Unchecked_Convert_To (Obj_Ptr,
 492               Make_Identifier (Loc, Name_uO))));
 493
 494       Prepend_To (Decls,
 495         Make_Full_Type_Declaration (Loc,
 496           Defining_Identifier => Obj_Ptr,
 497           Type_Definition => Make_Access_To_Object_Definition (Loc,
 498             Subtype_Indication =>
 499               New_Reference_To (Corresponding_Record_Type (Pid), Loc))));
 500    end Add_Object_Pointer;
 501
 502    ------------------------------
 503    -- Add_Private_Declarations --
 504    ------------------------------
 505
 506    procedure Add_Private_Declarations
 507      (Decls : List_Id;
 508       Typ   : Entity_Id;
 509       Name  : Name_Id;
 510       Loc   : Source_Ptr)
 511    is
 512       Def      : constant Node_Id   := Protected_Definition (Parent (Typ));
 513       Body_Ent : constant Entity_Id := Corresponding_Body   (Parent (Typ));
 514       P        : Node_Id;
 515       Pdef     : Entity_Id;
 516
 517    begin
 518       pragma Assert (Nkind (Def) = N_Protected_Definition);
 519
 520       if Present (Private_Declarations (Def)) then
 521          P := First (Private_Declarations (Def));
 522
 523          while Present (P) loop
 524             if Nkind (P) = N_Component_Declaration then
 525                Pdef := Defining_Identifier (P);
 526                Prepend_To (Decls,
 527                  Make_Object_Renaming_Declaration (Loc,
 528                    Defining_Identifier => Prival (Pdef),
 529                    Subtype_Mark => New_Reference_To (Etype (Pdef), Loc),
 530                    Name =>
 531                      Make_Selected_Component (Loc,
 532                        Prefix        => Make_Identifier (Loc, Name),
 533                        Selector_Name => Make_Identifier (Loc, Chars (Pdef)))));
 534             end if;
 535             Next (P);
 536          end loop;
 537       end if;
 538
 539       --  One more "prival" for the object itself, with the right protection
 540       --  type.
 541
 542       declare
 543          Protection_Type : RE_Id;
 544       begin
 545          if Has_Attach_Handler (Typ) then
 546             if Restricted_Profile then
 547                if Has_Entries (Typ) then
 548                   Protection_Type := RE_Protection_Entry;
 549                else
 550                   Protection_Type := RE_Protection;
 551                end if;
 552             else
 553                Protection_Type := RE_Static_Interrupt_Protection;
 554             end if;
 555
 556          elsif Has_Interrupt_Handler (Typ) then
 557             Protection_Type := RE_Dynamic_Interrupt_Protection;
 558
 559          elsif Has_Entries (Typ) then
 560             if Abort_Allowed
 561               or else Restriction_Active (No_Entry_Queue) = False
 562               or else Number_Entries (Typ) > 1
 563             then
 564                Protection_Type := RE_Protection_Entries;
 565             else
 566                Protection_Type := RE_Protection_Entry;
 567             end if;
 568
 569          else
 570             Protection_Type := RE_Protection;
 571          end if;
 572
 573          Prepend_To (Decls,
 574            Make_Object_Renaming_Declaration (Loc,
 575              Defining_Identifier => Object_Ref (Body_Ent),
 576              Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc),
 577              Name =>
 578                Make_Selected_Component (Loc,
 579                  Prefix        => Make_Identifier (Loc, Name),
 580                  Selector_Name => Make_Identifier (Loc, Name_uObject))));
 581       end;
 582    end Add_Private_Declarations;
 583
 584    -----------------------
 585    -- Build_Accept_Body --
 586    -----------------------
 587
 588    function Build_Accept_Body (Astat : Node_Id) return  Node_Id is
 589       Loc     : constant Source_Ptr := Sloc (Astat);
 590       Stats   : constant Node_Id    := Handled_Statement_Sequence (Astat);
 591       New_S   : Node_Id;
 592       Hand    : Node_Id;
 593       Call    : Node_Id;
 594       Ohandle : Node_Id;
 595
 596    begin
 597       --  At the end of the statement sequence, Complete_Rendezvous is called.
 598       --  A label skipping the Complete_Rendezvous, and all other
 599       --  accept processing, has already been added for the expansion
 600       --  of requeue statements.
 601
 602       Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
 603       Insert_Before (Last (Statements (Stats)), Call);
 604       Analyze (Call);
 605
 606       --  If exception handlers are present, then append Complete_Rendezvous
 607       --  calls to the handlers, and construct the required outer block.
 608
 609       if Present (Exception_Handlers (Stats)) then
 610          Hand := First (Exception_Handlers (Stats));
 611
 612          while Present (Hand) loop
 613             Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
 614             Append (Call, Statements (Hand));
 615             Analyze (Call);
 616             Next (Hand);
 617          end loop;
 618
 619          New_S :=
 620            Make_Handled_Sequence_Of_Statements (Loc,
 621              Statements => New_List (
 622                Make_Block_Statement (Loc,
 623                  Handled_Statement_Sequence => Stats)));
 624
 625       else
 626          New_S := Stats;
 627       end if;
 628
 629       --  At this stage we know that the new statement sequence does not
 630       --  have an exception handler part, so we supply one to call
 631       --  Exceptional_Complete_Rendezvous. This handler is
 632
 633       --    when all others =>
 634       --       Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
 635
 636       --  We handle Abort_Signal to make sure that we properly catch the abort
 637       --  case and wake up the caller.
 638
 639       Ohandle := Make_Others_Choice (Loc);
 640       Set_All_Others (Ohandle);
 641
 642       Set_Exception_Handlers (New_S,
 643         New_List (
 644           Make_Exception_Handler (Loc,
 645             Exception_Choices => New_List (Ohandle),
 646
 647             Statements =>  New_List (
 648               Make_Procedure_Call_Statement (Loc,
 649                 Name => New_Reference_To (
 650                   RTE (RE_Exceptional_Complete_Rendezvous), Loc),
 651                 Parameter_Associations => New_List (
 652                   Make_Function_Call (Loc,
 653                     Name => New_Reference_To (
 654                       RTE (RE_Get_GNAT_Exception), Loc))))))));
 655
 656       Set_Parent (New_S, Astat); -- temp parent for Analyze call
 657       Analyze_Exception_Handlers (Exception_Handlers (New_S));
 658       Expand_Exception_Handlers (New_S);
 659
 660       --  Exceptional_Complete_Rendezvous must be called with abort
 661       --  still deferred, which is the case for a "when all others" handler.
 662
 663       return New_S;
 664    end Build_Accept_Body;
 665
 666    -----------------------------------
 667    -- Build_Activation_Chain_Entity --
 668    -----------------------------------
 669
 670    procedure Build_Activation_Chain_Entity (N : Node_Id) is
 671       P     : Node_Id;
 672       B     : Node_Id;
 673       Decls : List_Id;
 674
 675    begin
 676       --  Loop to find enclosing construct containing activation chain variable
 677
 678       P := Parent (N);
 679
 680       while Nkind (P) /= N_Subprogram_Body
 681         and then Nkind (P) /= N_Package_Declaration
 682         and then Nkind (P) /= N_Package_Body
 683         and then Nkind (P) /= N_Block_Statement
 684         and then Nkind (P) /= N_Task_Body
 685       loop
 686          P := Parent (P);
 687       end loop;
 688
 689       --  If we are in a package body, the activation chain variable is
 690       --  allocated in the corresponding spec. First, we save the package
 691       --  body node because we enter the new entity in its Declarations list.
 692
 693       B := P;
 694
 695       if Nkind (P) = N_Package_Body then
 696          P := Unit_Declaration_Node (Corresponding_Spec (P));
 697          Decls := Declarations (B);
 698
 699       elsif Nkind (P) = N_Package_Declaration then
 700          Decls := Visible_Declarations (Specification (B));
 701
 702       else
 703          Decls := Declarations (B);
 704       end if;
 705
 706       --  If activation chain entity not already declared, declare it
 707
 708       if No (Activation_Chain_Entity (P)) then
 709          Set_Activation_Chain_Entity
 710            (P, Make_Defining_Identifier (Sloc (N), Name_uChain));
 711
 712          Prepend_To (Decls,
 713            Make_Object_Declaration (Sloc (P),
 714              Defining_Identifier => Activation_Chain_Entity (P),
 715              Aliased_Present => True,
 716              Object_Definition   =>
 717                New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
 718
 719          Analyze (First (Decls));
 720       end if;
 721    end Build_Activation_Chain_Entity;
 722
 723    ----------------------------
 724    -- Build_Barrier_Function --
 725    ----------------------------
 726
 727    function Build_Barrier_Function
 728      (N    : Node_Id;
 729       Ent  : Entity_Id;
 730       Pid  : Node_Id) return Node_Id
 731    is
 732       Loc         : constant Source_Ptr := Sloc (N);
 733       Ent_Formals : constant Node_Id    := Entry_Body_Formal_Part (N);
 734       Index_Spec  : constant Node_Id    := Entry_Index_Specification
 735                                                            (Ent_Formals);
 736       Op_Decls    : constant List_Id    := New_List;
 737       Bdef        : Entity_Id;
 738       Bspec       : Node_Id;
 739
 740    begin
 741       Bdef :=
 742         Make_Defining_Identifier (Loc, Chars (Barrier_Function (Ent)));
 743       Bspec := Build_Barrier_Function_Specification (Bdef, Loc);
 744
 745       --  <object pointer declaration>
 746       --  <discriminant renamings>
 747       --  <private object renamings>
 748       --  Add discriminal and private renamings. These names have
 749       --  already been used to expand references to discriminants
 750       --  and private data.
 751
 752       Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc);
 753       Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc);
 754       Add_Object_Pointer (Op_Decls, Pid, Loc);
 755
 756       --  If this is the barrier for an entry family, the entry index is
 757       --  visible in the body of the barrier. Create a local variable that
 758       --  converts the entry index (which is the last formal of the barrier
 759       --  function) into the appropriate offset into the entry array. The
 760       --  entry index constant must be set, as for the entry body, so that
 761       --  local references to the entry index are correctly replaced with
 762       --  the local variable. This parallels what is done for entry bodies.
 763
 764       if Present (Index_Spec) then
 765          declare
 766             Index_Id  : constant Entity_Id := Defining_Identifier (Index_Spec);
 767             Index_Con : constant Entity_Id :=
 768                           Make_Defining_Identifier (Loc,
 769                             Chars => New_Internal_Name ('J'));
 770
 771          begin
 772             Set_Entry_Index_Constant (Index_Id, Index_Con);
 773             Append_List_To (Op_Decls,
 774               Index_Constant_Declaration (N, Index_Id, Pid));
 775          end;
 776       end if;
 777
 778       --  Note: the condition in the barrier function needs to be properly
 779       --  processed for the C/Fortran boolean possibility, but this happens
 780       --  automatically since the return statement does this normalization.
 781
 782       return
 783         Make_Subprogram_Body (Loc,
 784           Specification => Bspec,
 785           Declarations => Op_Decls,
 786           Handled_Statement_Sequence =>
 787             Make_Handled_Sequence_Of_Statements (Loc,
 788               Statements => New_List (
 789                 Make_Return_Statement (Loc,
 790                   Expression => Condition (Ent_Formals)))));
 791    end Build_Barrier_Function;
 792
 793    ------------------------------------------
 794    -- Build_Barrier_Function_Specification --
 795    ------------------------------------------
 796
 797    function Build_Barrier_Function_Specification
 798      (Def_Id : Entity_Id;
 799       Loc    : Source_Ptr) return Node_Id
 800    is
 801    begin
 802       return Make_Function_Specification (Loc,
 803         Defining_Unit_Name => Def_Id,
 804         Parameter_Specifications => New_List (
 805           Make_Parameter_Specification (Loc,
 806             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
 807             Parameter_Type =>
 808               New_Reference_To (RTE (RE_Address), Loc)),
 809
 810           Make_Parameter_Specification (Loc,
 811             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
 812             Parameter_Type =>
 813               New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
 814
 815         Subtype_Mark => New_Reference_To (Standard_Boolean, Loc));
 816    end Build_Barrier_Function_Specification;
 817
 818    --------------------------
 819    -- Build_Call_With_Task --
 820    --------------------------
 821
 822    function Build_Call_With_Task
 823      (N : Node_Id;
 824       E : Entity_Id) return Node_Id
 825    is
 826       Loc : constant Source_Ptr := Sloc (N);
 827
 828    begin
 829       return
 830         Make_Function_Call (Loc,
 831           Name => New_Reference_To (E, Loc),
 832           Parameter_Associations => New_List (Concurrent_Ref (N)));
 833    end Build_Call_With_Task;
 834
 835    --------------------------------
 836    -- Build_Corresponding_Record --
 837    --------------------------------
 838
 839    function Build_Corresponding_Record
 840     (N    : Node_Id;
 841      Ctyp : Entity_Id;
 842      Loc  : Source_Ptr) return Node_Id
 843    is
 844       Rec_Ent  : constant Entity_Id :=
 845                    Make_Defining_Identifier
 846                      (Loc, New_External_Name (Chars (Ctyp), 'V'));
 847       Disc     : Entity_Id;
 848       Dlist    : List_Id;
 849       New_Disc : Entity_Id;
 850       Cdecls   : List_Id;
 851
 852    begin
 853       Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
 854       Set_Ekind                         (Rec_Ent, E_Record_Type);
 855       Set_Has_Delayed_Freeze            (Rec_Ent, Has_Delayed_Freeze (Ctyp));
 856       Set_Is_Concurrent_Record_Type     (Rec_Ent, True);
 857       Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
 858       Set_Stored_Constraint             (Rec_Ent, No_Elist);
 859       Cdecls := New_List;
 860
 861       --  Use discriminals to create list of discriminants for record, and
 862       --  create new discriminals for use in default expressions, etc. It is
 863       --  worth noting that a task discriminant gives rise to 5 entities;
 864
 865       --  a) The original discriminant.
 866       --  b) The discriminal for use in the task.
 867       --  c) The discriminant of the corresponding record.
 868       --  d) The discriminal for the init proc of the corresponding record.
 869       --  e) The local variable that renames the discriminant in the procedure
 870       --     for the task body.
 871
 872       --  In fact the discriminals b) are used in the renaming declarations
 873       --  for e). See details in  einfo (Handling of Discriminants).
 874
 875       if Present (Discriminant_Specifications (N)) then
 876          Dlist := New_List;
 877          Disc := First_Discriminant (Ctyp);
 878
 879          while Present (Disc) loop
 880             New_Disc := CR_Discriminant (Disc);
 881
 882             Append_To (Dlist,
 883               Make_Discriminant_Specification (Loc,
 884                 Defining_Identifier => New_Disc,
 885                 Discriminant_Type =>
 886                   New_Occurrence_Of (Etype (Disc), Loc),
 887                 Expression =>
 888                   New_Copy (Discriminant_Default_Value (Disc))));
 889
 890             Next_Discriminant (Disc);
 891          end loop;
 892
 893       else
 894          Dlist := No_List;
 895       end if;
 896
 897       --  Now we can construct the record type declaration. Note that this
 898       --  record is limited, reflecting the underlying limitedness of the
 899       --  task or protected object that it represents, and ensuring for
 900       --  example that it is properly passed by reference.
 901
 902       return
 903         Make_Full_Type_Declaration (Loc,
 904           Defining_Identifier => Rec_Ent,
 905           Discriminant_Specifications => Dlist,
 906           Type_Definition =>
 907             Make_Record_Definition (Loc,
 908               Component_List =>
 909                 Make_Component_List (Loc,
 910                   Component_Items => Cdecls),
 911               Limited_Present => True));
 912    end Build_Corresponding_Record;
 913
 914    ----------------------------------
 915    -- Build_Entry_Count_Expression --
 916    ----------------------------------
 917
 918    function Build_Entry_Count_Expression
 919      (Concurrent_Type : Node_Id;
 920       Component_List  : List_Id;
 921       Loc             : Source_Ptr) return Node_Id
 922    is
 923       Eindx  : Nat;
 924       Ent    : Entity_Id;
 925       Ecount : Node_Id;
 926       Comp   : Node_Id;
 927       Lo     : Node_Id;
 928       Hi     : Node_Id;
 929       Typ    : Entity_Id;
 930
 931    begin
 932       Ent := First_Entity (Concurrent_Type);
 933       Eindx := 0;
 934
 935       --  Count number of non-family entries
 936
 937       while Present (Ent) loop
 938          if Ekind (Ent) = E_Entry then
 939             Eindx := Eindx + 1;
 940          end if;
 941
 942          Next_Entity (Ent);
 943       end loop;
 944
 945       Ecount := Make_Integer_Literal (Loc, Eindx);
 946
 947       --  Loop through entry families building the addition nodes
 948
 949       Ent := First_Entity (Concurrent_Type);
 950       Comp := First (Component_List);
 951
 952       while Present (Ent) loop
 953          if Ekind (Ent) = E_Entry_Family then
 954             while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
 955                Next (Comp);
 956             end loop;
 957
 958             Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
 959             Hi := Type_High_Bound (Typ);
 960             Lo := Type_Low_Bound  (Typ);
 961
 962             Ecount :=
 963               Make_Op_Add (Loc,
 964                 Left_Opnd  => Ecount,
 965                 Right_Opnd => Family_Size (Loc, Hi, Lo, Concurrent_Type));
 966          end if;
 967
 968          Next_Entity (Ent);
 969       end loop;
 970
 971       return Ecount;
 972    end Build_Entry_Count_Expression;
 973
 974    ---------------------------
 975    -- Build_Find_Body_Index --
 976    ---------------------------
 977
 978    function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
 979       Loc   : constant Source_Ptr := Sloc (Typ);
 980       Ent   : Entity_Id;
 981       E_Typ : Entity_Id;
 982       Has_F : Boolean := False;
 983       Index : Nat;
 984       If_St : Node_Id := Empty;
 985       Lo    : Node_Id;
 986       Hi    : Node_Id;
 987       Decls : List_Id := New_List;
 988       Ret   : Node_Id;
 989       Spec  : Node_Id;
 990       Siz   : Node_Id := Empty;
 991
 992       procedure Add_If_Clause (Expr : Node_Id);
 993       --  Add test for range of current entry.
 994
 995       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
 996       --  If a bound of an entry is given by a discriminant, retrieve the
 997       --  actual value of the discriminant from the enclosing object.
 998
 999       -------------------
1000       -- Add_If_Clause --
1001       -------------------
1002
1003       procedure Add_If_Clause (Expr : Node_Id) is
1004          Cond  : Node_Id;
1005          Stats : constant List_Id :=
1006                    New_List (
1007                      Make_Return_Statement (Loc,
1008                        Expression => Make_Integer_Literal (Loc, Index + 1)));
1009
1010       begin
1011          --  Index for current entry body.
1012
1013          Index := Index + 1;
1014
1015          --  Compute total length of entry queues so far.
1016
1017          if No (Siz) then
1018             Siz := Expr;
1019          else
1020             Siz :=
1021               Make_Op_Add (Loc,
1022                 Left_Opnd => Siz,
1023                 Right_Opnd => Expr);
1024          end if;
1025
1026          Cond :=
1027            Make_Op_Le (Loc,
1028              Left_Opnd => Make_Identifier (Loc, Name_uE),
1029              Right_Opnd => Siz);
1030
1031          --  Map entry queue indices in the range of the current family
1032          --  into the current index, that designates the entry body.
1033
1034          if No (If_St) then
1035             If_St :=
1036               Make_Implicit_If_Statement (Typ,
1037                 Condition => Cond,
1038                 Then_Statements => Stats,
1039                 Elsif_Parts   => New_List);
1040
1041             Ret := If_St;
1042
1043          else
1044             Append (
1045               Make_Elsif_Part (Loc,
1046                 Condition => Cond,
1047                 Then_Statements => Stats),
1048               Elsif_Parts (If_St));
1049          end if;
1050       end Add_If_Clause;
1051
1052       ------------------------------
1053       -- Convert_Discriminant_Ref --
1054       ------------------------------
1055
1056       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
1057          B   : Node_Id;
1058
1059       begin
1060          if Is_Entity_Name (Bound)
1061            and then Ekind (Entity (Bound)) = E_Discriminant
1062          then
1063             B :=
1064               Make_Selected_Component (Loc,
1065                Prefix =>
1066                  Unchecked_Convert_To (Corresponding_Record_Type (Typ),
1067                    Make_Explicit_Dereference (Loc,
1068                      Make_Identifier (Loc, Name_uObject))),
1069                Selector_Name => Make_Identifier (Loc, Chars (Bound)));
1070             Set_Etype (B, Etype (Entity (Bound)));
1071          else
1072             B := New_Copy_Tree (Bound);
1073          end if;
1074
1075          return B;
1076       end Convert_Discriminant_Ref;
1077
1078    --  Start of processing for Build_Find_Body_Index
1079
1080    begin
1081       Spec := Build_Find_Body_Index_Spec (Typ);
1082
1083       Ent := First_Entity (Typ);
1084
1085       while Present (Ent) loop
1086
1087          if Ekind (Ent) = E_Entry_Family then
1088             Has_F := True;
1089             exit;
1090          end if;
1091
1092          Next_Entity (Ent);
1093       end loop;
1094
1095       if not Has_F then
1096
1097          --  If the protected type has no entry families, there is a one-one
1098          --  correspondence between entry queue and entry body.
1099
1100          Ret :=
1101            Make_Return_Statement (Loc,
1102              Expression => Make_Identifier (Loc, Name_uE));
1103
1104       else
1105          --  Suppose entries e1, e2, ... have size l1, l2, ... we generate
1106          --  the following:
1107          --
1108          --  if E <= l1 then return 1;
1109          --  elsif E <= l1 + l2 then return 2;
1110          --  ...
1111
1112          Index := 0;
1113          Siz   := Empty;
1114          Ent   := First_Entity (Typ);
1115
1116          Add_Object_Pointer (Decls, Typ, Loc);
1117
1118          while Present (Ent) loop
1119
1120             if Ekind (Ent) = E_Entry then
1121                Add_If_Clause (Make_Integer_Literal (Loc, 1));
1122
1123             elsif Ekind (Ent) = E_Entry_Family then
1124
1125                E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1126                Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
1127                Lo := Convert_Discriminant_Ref (Type_Low_Bound  (E_Typ));
1128                Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ));
1129             end if;
1130
1131             Next_Entity (Ent);
1132          end loop;
1133
1134          if Index = 1 then
1135             Decls := New_List;
1136             Ret :=
1137               Make_Return_Statement (Loc,
1138                 Expression => Make_Integer_Literal (Loc, 1));
1139
1140          elsif Nkind (Ret) = N_If_Statement then
1141
1142             --  Ranges are in increasing order, so last one doesn't need a
1143             --  guard.
1144
1145             declare
1146                Nod : constant Node_Id := Last (Elsif_Parts (Ret));
1147
1148             begin
1149                Remove (Nod);
1150                Set_Else_Statements (Ret, Then_Statements (Nod));
1151             end;
1152          end if;
1153       end if;
1154
1155       return
1156         Make_Subprogram_Body (Loc,
1157           Specification => Spec,
1158           Declarations  => Decls,
1159           Handled_Statement_Sequence =>
1160             Make_Handled_Sequence_Of_Statements (Loc,
1161               Statements => New_List (Ret)));
1162    end Build_Find_Body_Index;
1163
1164    --------------------------------
1165    -- Build_Find_Body_Index_Spec --
1166    --------------------------------
1167
1168    function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
1169       Loc   : constant Source_Ptr := Sloc (Typ);
1170       Id    : constant Entity_Id :=
1171                Make_Defining_Identifier (Loc,
1172                  Chars => New_External_Name (Chars (Typ), 'F'));
1173       Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
1174       Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
1175
1176    begin
1177       return
1178         Make_Function_Specification (Loc,
1179           Defining_Unit_Name => Id,
1180           Parameter_Specifications => New_List (
1181             Make_Parameter_Specification (Loc,
1182               Defining_Identifier => Parm1,
1183               Parameter_Type =>
1184                 New_Reference_To (RTE (RE_Address), Loc)),
1185
1186             Make_Parameter_Specification (Loc,
1187               Defining_Identifier => Parm2,
1188               Parameter_Type =>
1189                 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
1190           Subtype_Mark => New_Occurrence_Of (
1191             RTE (RE_Protected_Entry_Index), Loc));
1192    end Build_Find_Body_Index_Spec;
1193
1194    -------------------------
1195    -- Build_Master_Entity --
1196    -------------------------
1197
1198    procedure Build_Master_Entity (E : Entity_Id) is
1199       Loc  : constant Source_Ptr := Sloc (E);
1200       P    : Node_Id;
1201       Decl : Node_Id;
1202       S    : Entity_Id;
1203
1204    begin
1205       S := Scope (E);
1206
1207       --  Ada 0Y (AI-287): Do not set/get the has_master_entity reminder in
1208       --  internal scopes. Required for nested limited aggregates.
1209
1210       if Extensions_Allowed then
1211          while Is_Internal (S) loop
1212             S := Scope (S);
1213          end loop;
1214       end if;
1215
1216       --  Nothing to do if we already built a master entity for this scope
1217       --  or if there is no task hierarchy.
1218
1219       if Has_Master_Entity (S)
1220         or else Restriction_Active (No_Task_Hierarchy)
1221       then
1222          return;
1223       end if;
1224
1225       --  Otherwise first build the master entity
1226       --    _Master : constant Master_Id := Current_Master.all;
1227       --  and insert it just before the current declaration
1228
1229       Decl :=
1230         Make_Object_Declaration (Loc,
1231           Defining_Identifier =>
1232             Make_Defining_Identifier (Loc, Name_uMaster),
1233           Constant_Present => True,
1234           Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc),
1235           Expression =>
1236             Make_Explicit_Dereference (Loc,
1237               New_Reference_To (RTE (RE_Current_Master), Loc)));
1238
1239       P := Parent (E);
1240       Insert_Before (P, Decl);
1241       Analyze (Decl);
1242
1243       --  Ada 0Y (AI-287): Set the has_master_entity reminder in the
1244       --  non-internal scope selected above.
1245
1246       if not Extensions_Allowed then
1247          Set_Has_Master_Entity (Scope (E));
1248       else
1249          Set_Has_Master_Entity (S);
1250       end if;
1251
1252       --  Now mark the containing scope as a task master
1253
1254       while Nkind (P) /= N_Compilation_Unit loop
1255          P := Parent (P);
1256
1257          --  If we fall off the top, we are at the outer level, and the
1258          --  environment task is our effective master, so nothing to mark.
1259
1260          if Nkind (P) = N_Task_Body
1261            or else Nkind (P) = N_Block_Statement
1262            or else Nkind (P) = N_Subprogram_Body
1263          then
1264             Set_Is_Task_Master (P, True);
1265             return;
1266
1267          elsif Nkind (Parent (P)) = N_Subunit then
1268             P := Corresponding_Stub (Parent (P));
1269          end if;
1270       end loop;
1271    end Build_Master_Entity;
1272
1273    ---------------------------
1274    -- Build_Protected_Entry --
1275    ---------------------------
1276
1277    function Build_Protected_Entry
1278      (N   : Node_Id;
1279       Ent : Entity_Id;
1280       Pid : Node_Id) return Node_Id
1281    is
1282       Loc      : constant Source_Ptr := Sloc (N);
1283       Op_Decls : constant List_Id    := New_List;
1284       Edef     : Entity_Id;
1285       Espec    : Node_Id;
1286       Op_Stats : List_Id;
1287       Ohandle  : Node_Id;
1288       Complete : Node_Id;
1289
1290    begin
1291       Edef :=
1292         Make_Defining_Identifier (Loc,
1293           Chars => Chars (Protected_Body_Subprogram (Ent)));
1294       Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc);
1295
1296       --  <object pointer declaration>
1297       --  Add object pointer declaration. This is needed by the
1298       --  discriminal and prival renamings, which should already
1299       --  have been inserted into the declaration list.
1300
1301       Add_Object_Pointer (Op_Decls, Pid, Loc);
1302
1303       if Abort_Allowed
1304         or else Restriction_Active (No_Entry_Queue) = False
1305         or else Number_Entries (Pid) > 1
1306       then
1307          Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
1308       else
1309          Complete :=
1310            New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc);
1311       end if;
1312
1313       Op_Stats := New_List (
1314          Make_Block_Statement (Loc,
1315            Declarations => Declarations (N),
1316            Handled_Statement_Sequence =>
1317              Handled_Statement_Sequence (N)),
1318
1319          Make_Procedure_Call_Statement (Loc,
1320            Name => Complete,
1321            Parameter_Associations => New_List (
1322              Make_Attribute_Reference (Loc,
1323                Prefix =>
1324                  Make_Selected_Component (Loc,
1325                    Prefix =>
1326                      Make_Identifier (Loc, Name_uObject),
1327
1328                    Selector_Name =>
1329                      Make_Identifier (Loc, Name_uObject)),
1330                  Attribute_Name => Name_Unchecked_Access))));
1331
1332       if Restriction_Active (No_Exception_Handlers) then
1333          return
1334            Make_Subprogram_Body (Loc,
1335              Specification => Espec,
1336              Declarations => Op_Decls,
1337              Handled_Statement_Sequence =>
1338                Make_Handled_Sequence_Of_Statements (Loc, Op_Stats));
1339
1340       else
1341          Ohandle := Make_Others_Choice (Loc);
1342          Set_All_Others (Ohandle);
1343
1344          if Abort_Allowed
1345            or else Restriction_Active (No_Entry_Queue) = False
1346            or else Number_Entries (Pid) > 1
1347          then
1348             Complete :=
1349               New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
1350
1351          else
1352             Complete := New_Reference_To (
1353               RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
1354          end if;
1355
1356          return
1357            Make_Subprogram_Body (Loc,
1358              Specification => Espec,
1359              Declarations => Op_Decls,
1360              Handled_Statement_Sequence =>
1361                Make_Handled_Sequence_Of_Statements (Loc,
1362                  Statements => Op_Stats,
1363                  Exception_Handlers => New_List (
1364                    Make_Exception_Handler (Loc,
1365                      Exception_Choices => New_List (Ohandle),
1366
1367                      Statements =>  New_List (
1368                        Make_Procedure_Call_Statement (Loc,
1369                          Name => Complete,
1370                          Parameter_Associations => New_List (
1371                            Make_Attribute_Reference (Loc,
1372                              Prefix =>
1373                                Make_Selected_Component (Loc,
1374                                  Prefix =>
1375                                    Make_Identifier (Loc, Name_uObject),
1376                                  Selector_Name =>
1377                                    Make_Identifier (Loc, Name_uObject)),
1378                                Attribute_Name => Name_Unchecked_Access),
1379
1380                            Make_Function_Call (Loc,
1381                              Name => New_Reference_To (
1382                                RTE (RE_Get_GNAT_Exception), Loc)))))))));
1383       end if;
1384    end Build_Protected_Entry;
1385
1386    -----------------------------------------
1387    -- Build_Protected_Entry_Specification --
1388    -----------------------------------------
1389
1390    function Build_Protected_Entry_Specification
1391      (Def_Id : Entity_Id;
1392       Ent_Id : Entity_Id;
1393       Loc    : Source_Ptr) return Node_Id
1394    is
1395       P : Entity_Id;
1396
1397    begin
1398       P := Make_Defining_Identifier (Loc, Name_uP);
1399
1400       if Present (Ent_Id) then
1401          Append_Elmt (P, Accept_Address (Ent_Id));
1402       end if;
1403
1404       return Make_Procedure_Specification (Loc,
1405         Defining_Unit_Name => Def_Id,
1406         Parameter_Specifications => New_List (
1407           Make_Parameter_Specification (Loc,
1408             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1409             Parameter_Type =>
1410               New_Reference_To (RTE (RE_Address), Loc)),
1411
1412           Make_Parameter_Specification (Loc,
1413             Defining_Identifier => P,
1414             Parameter_Type =>
1415               New_Reference_To (RTE (RE_Address), Loc)),
1416
1417           Make_Parameter_Specification (Loc,
1418             Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
1419             Parameter_Type =>
1420               New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))));
1421    end Build_Protected_Entry_Specification;
1422
1423    --------------------------
1424    -- Build_Protected_Spec --
1425    --------------------------
1426
1427    function Build_Protected_Spec
1428      (N           : Node_Id;
1429       Obj_Type    : Entity_Id;
1430       Unprotected : Boolean := False;
1431       Ident       : Entity_Id) return List_Id
1432    is
1433       Loc         : constant Source_Ptr := Sloc (N);
1434       Formal      : Entity_Id;
1435       New_Plist   : List_Id;
1436       New_Param   : Node_Id;
1437
1438    begin
1439       New_Plist := New_List;
1440       Formal := First_Formal (Ident);
1441
1442       while Present (Formal) loop
1443          New_Param :=
1444            Make_Parameter_Specification (Loc,
1445              Defining_Identifier =>
1446                Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
1447              In_Present => In_Present (Parent (Formal)),
1448              Out_Present => Out_Present (Parent (Formal)),
1449              Parameter_Type =>
1450                New_Reference_To (Etype (Formal), Loc));
1451
1452          if Unprotected then
1453             Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
1454          end if;
1455
1456          Append (New_Param, New_Plist);
1457          Next_Formal (Formal);
1458       end loop;
1459
1460       --  If the subprogram is a procedure and the context is not an access
1461       --  to protected subprogram, the parameter is in-out. Otherwise it is
1462       --  an in parameter.
1463
1464       Prepend_To (New_Plist,
1465         Make_Parameter_Specification (Loc,
1466           Defining_Identifier =>
1467             Make_Defining_Identifier (Loc, Name_uObject),
1468           In_Present => True,
1469           Out_Present =>
1470            (Etype (Ident) = Standard_Void_Type
1471               and then not Is_RTE (Obj_Type, RE_Address)),
1472           Parameter_Type => New_Reference_To (Obj_Type, Loc)));
1473
1474       return New_Plist;
1475    end Build_Protected_Spec;
1476
1477    ---------------------------------------
1478    -- Build_Protected_Sub_Specification --
1479    ---------------------------------------
1480
1481    function Build_Protected_Sub_Specification
1482      (N           : Node_Id;
1483       Prottyp     : Entity_Id;
1484       Unprotected : Boolean := False) return Node_Id
1485    is
1486       Loc         : constant Source_Ptr := Sloc (N);
1487       Decl        : Node_Id;
1488       Protnm      : constant Name_Id := Chars (Prottyp);
1489       Ident       : Entity_Id;
1490       Nam         : Name_Id;
1491       New_Id      : Entity_Id;
1492       New_Plist   : List_Id;
1493       Append_Char : Character;
1494       New_Spec    : Node_Id;
1495
1496    begin
1497       if Ekind
1498          (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
1499       then
1500          Decl := Unit_Declaration_Node (Corresponding_Spec (N));
1501       else
1502          Decl := N;
1503       end if;
1504
1505       Ident := Defining_Unit_Name (Specification (Decl));
1506       Nam := Chars (Ident);
1507
1508       New_Plist := Build_Protected_Spec
1509                         (Decl, Corresponding_Record_Type (Prottyp),
1510                          Unprotected, Ident);
1511
1512       if Unprotected then
1513          Append_Char := 'N';
1514       else
1515          Append_Char := 'P';
1516       end if;
1517
1518       New_Id :=
1519         Make_Defining_Identifier (Loc,
1520           Chars => Build_Selected_Name (Protnm, Nam, Append_Char));
1521
1522       --  The unprotected operation carries the user code, and debugging
1523       --  information must be generated for it, even though this spec does
1524       --  not come from source. It is also convenient to allow gdb to step
1525       --  into the protected operation, even though it only contains lock/
1526       --  unlock calls.
1527
1528       Set_Needs_Debug_Info (New_Id);
1529
1530       if Nkind (Specification (Decl)) = N_Procedure_Specification then
1531          return
1532            Make_Procedure_Specification (Loc,
1533              Defining_Unit_Name => New_Id,
1534              Parameter_Specifications => New_Plist);
1535
1536       else
1537          New_Spec :=
1538            Make_Function_Specification (Loc,
1539              Defining_Unit_Name => New_Id,
1540              Parameter_Specifications => New_Plist,
1541              Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl))));
1542          Set_Return_Present (Defining_Unit_Name (New_Spec));
1543          return New_Spec;
1544       end if;
1545    end Build_Protected_Sub_Specification;
1546
1547    -------------------------------------
1548    -- Build_Protected_Subprogram_Body --
1549    -------------------------------------
1550
1551    function Build_Protected_Subprogram_Body
1552      (N         : Node_Id;
1553       Pid       : Node_Id;
1554       N_Op_Spec : Node_Id) return Node_Id
1555    is
1556       Loc          : constant Source_Ptr := Sloc (N);
1557       Op_Spec      : Node_Id;
1558       P_Op_Spec    : Node_Id;
1559       Uactuals     : List_Id;
1560       Pformal      : Node_Id;
1561       Unprot_Call  : Node_Id;
1562       Sub_Body     : Node_Id;
1563       Lock_Name    : Node_Id;
1564       Lock_Stmt    : Node_Id;
1565       Service_Name : Node_Id;
1566       R            : Node_Id;
1567       Return_Stmt  : Node_Id := Empty;    -- init to avoid gcc 3 warning
1568       Pre_Stmts    : List_Id := No_List;  -- init to avoid gcc 3 warning
1569       Stmts        : List_Id;
1570       Object_Parm  : Node_Id;
1571       Exc_Safe     : Boolean;
1572
1573       function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
1574       --  Tell whether a given subprogram cannot raise an exception
1575
1576       -----------------------
1577       -- Is_Exception_Safe --
1578       -----------------------
1579
1580       function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
1581
1582          function Has_Side_Effect (N : Node_Id) return Boolean;
1583          --  Return True whenever encountering a subprogram call or a
1584          --  raise statement of any kind in the sequence of statements N
1585
1586          ---------------------
1587          -- Has_Side_Effect --
1588          ---------------------
1589
1590          --  What is this doing buried two levels down in exp_ch9. It
1591          --  seems like a generally useful function, and indeed there
1592          --  may be code duplication going on here ???
1593
1594          function Has_Side_Effect (N : Node_Id) return Boolean is
1595             Stmt : Node_Id := N;
1596             Expr : Node_Id;
1597
1598             function Is_Call_Or_Raise (N : Node_Id) return Boolean;
1599             --  Indicate whether N is a subprogram call or a raise statement
1600
1601             function Is_Call_Or_Raise (N : Node_Id) return Boolean is
1602             begin
1603                return Nkind (N) = N_Procedure_Call_Statement
1604                  or else Nkind (N) = N_Function_Call
1605                  or else Nkind (N) = N_Raise_Statement
1606                  or else Nkind (N) = N_Raise_Constraint_Error
1607                  or else Nkind (N) = N_Raise_Program_Error
1608                  or else Nkind (N) = N_Raise_Storage_Error;
1609             end Is_Call_Or_Raise;
1610
1611          --  Start of processing for Has_Side_Effect
1612
1613          begin
1614             while Present (Stmt) loop
1615                if Is_Call_Or_Raise (Stmt) then
1616                   return True;
1617                end if;
1618
1619                --  An object declaration can also contain a function call
1620                --  or a raise statement
1621
1622                if Nkind (Stmt) = N_Object_Declaration then
1623                   Expr := Expression (Stmt);
1624
1625                   if Present (Expr) and then Is_Call_Or_Raise (Expr) then
1626                      return True;
1627                   end if;
1628                end if;
1629
1630                Next (Stmt);
1631             end loop;
1632
1633             return False;
1634          end Has_Side_Effect;
1635
1636       --  Start of processing for Is_Exception_Safe
1637
1638       begin
1639          --  If the checks handled by the back end are not disabled, we cannot
1640          --  ensure that no exception will be raised.
1641
1642          if not Access_Checks_Suppressed (Empty)
1643            or else not Discriminant_Checks_Suppressed (Empty)
1644            or else not Range_Checks_Suppressed (Empty)
1645            or else not Index_Checks_Suppressed (Empty)
1646            or else Opt.Stack_Checking_Enabled
1647          then
1648             return False;
1649          end if;
1650
1651          if Has_Side_Effect (First (Declarations (Subprogram)))
1652            or else
1653               Has_Side_Effect (
1654                 First (Statements (Handled_Statement_Sequence (Subprogram))))
1655          then
1656             return False;
1657          else
1658             return True;
1659          end if;
1660       end Is_Exception_Safe;
1661
1662    --  Start of processing for Build_Protected_Subprogram_Body
1663
1664    begin
1665       Op_Spec := Specification (N);
1666       Exc_Safe := Is_Exception_Safe (N);
1667
1668       P_Op_Spec :=
1669         Build_Protected_Sub_Specification (N,
1670           Pid, Unprotected => False);
1671
1672       --  Build a list of the formal parameters of the protected
1673       --  version of the subprogram to use as the actual parameters
1674       --  of the unprotected version.
1675
1676       Uactuals := New_List;
1677       Pformal := First (Parameter_Specifications (P_Op_Spec));
1678
1679       while Present (Pformal) loop
1680          Append (
1681            Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))),
1682            Uactuals);
1683          Next (Pformal);
1684       end loop;
1685
1686       --  Make a call to the unprotected version of the subprogram
1687       --  built above for use by the protected version built below.
1688
1689       if Nkind (Op_Spec) = N_Function_Specification then
1690          if Exc_Safe then
1691             R := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
1692             Unprot_Call :=
1693               Make_Object_Declaration (Loc,
1694                 Defining_Identifier => R,
1695                 Constant_Present => True,
1696                 Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)),
1697                 Expression =>
1698                   Make_Function_Call (Loc,
1699                     Name => Make_Identifier (Loc,
1700                       Chars (Defining_Unit_Name (N_Op_Spec))),
1701                     Parameter_Associations => Uactuals));
1702             Return_Stmt := Make_Return_Statement (Loc,
1703               Expression => New_Reference_To (R, Loc));
1704
1705          else
1706             Unprot_Call := Make_Return_Statement (Loc,
1707               Expression => Make_Function_Call (Loc,
1708                 Name =>
1709                   Make_Identifier (Loc,
1710                     Chars (Defining_Unit_Name (N_Op_Spec))),
1711                 Parameter_Associations => Uactuals));
1712          end if;
1713
1714       else
1715          Unprot_Call := Make_Procedure_Call_Statement (Loc,
1716            Name =>
1717              Make_Identifier (Loc,
1718                Chars (Defining_Unit_Name (N_Op_Spec))),
1719            Parameter_Associations => Uactuals);
1720       end if;
1721
1722       --  Wrap call in block that will be covered by an at_end handler.
1723
1724       if not Exc_Safe then
1725          Unprot_Call := Make_Block_Statement (Loc,
1726            Handled_Statement_Sequence =>
1727              Make_Handled_Sequence_Of_Statements (Loc,
1728                Statements => New_List (Unprot_Call)));
1729       end if;
1730
1731       --  Make the protected subprogram body. This locks the protected
1732       --  object and calls the unprotected version of the subprogram.
1733
1734       --  If the protected object is controlled (i.e it has entries or
1735       --  needs finalization for interrupt handling), call Lock_Entries,
1736       --  except if the protected object follows the Ravenscar profile, in
1737       --  which case call Lock_Entry, otherwise call the simplified version,
1738       --  Lock.
1739
1740       if Has_Entries (Pid)
1741         or else Has_Interrupt_Handler (Pid)
1742         or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
1743       then
1744          if Abort_Allowed
1745            or else Restriction_Active (No_Entry_Queue) = False
1746            or else Number_Entries (Pid) > 1
1747          then
1748             Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
1749             Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
1750
1751          else
1752             Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc);
1753             Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
1754          end if;
1755
1756       else
1757          Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
1758          Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
1759       end if;
1760
1761       Object_Parm :=
1762         Make_Attribute_Reference (Loc,
1763            Prefix =>
1764              Make_Selected_Component (Loc,
1765                Prefix =>
1766                  Make_Identifier (Loc, Name_uObject),
1767              Selector_Name =>
1768                  Make_Identifier (Loc, Name_uObject)),
1769            Attribute_Name => Name_Unchecked_Access);
1770
1771       Lock_Stmt := Make_Procedure_Call_Statement (Loc,
1772         Name => Lock_Name,
1773         Parameter_Associations => New_List (Object_Parm));
1774
1775       if Abort_Allowed then
1776          Stmts := New_List (
1777            Make_Procedure_Call_Statement (Loc,
1778              Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
1779              Parameter_Associations => Empty_List),
1780            Lock_Stmt);
1781
1782       else
1783          Stmts := New_List (Lock_Stmt);
1784       end if;
1785
1786       if not Exc_Safe then
1787          Append (Unprot_Call, Stmts);
1788       else
1789          if Nkind (Op_Spec) = N_Function_Specification then
1790             Pre_Stmts := Stmts;
1791             Stmts     := Empty_List;
1792          else
1793             Append (Unprot_Call, Stmts);
1794          end if;
1795
1796          Append (
1797            Make_Procedure_Call_Statement (Loc,
1798              Name => Service_Name,
1799              Parameter_Associations =>
1800                New_List (New_Copy_Tree (Object_Parm))),
1801            Stmts);
1802
1803          if Abort_Allowed then
1804             Append (
1805               Make_Procedure_Call_Statement (Loc,
1806                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
1807                 Parameter_Associations => Empty_List),
1808               Stmts);
1809          end if;
1810
1811          if Nkind (Op_Spec) = N_Function_Specification then
1812             Append (Return_Stmt, Stmts);
1813             Append (Make_Block_Statement (Loc,
1814               Declarations => New_List (Unprot_Call),
1815               Handled_Statement_Sequence =>
1816                 Make_Handled_Sequence_Of_Statements (Loc,
1817                   Statements => Stmts)), Pre_Stmts);
1818             Stmts := Pre_Stmts;
1819          end if;
1820       end if;
1821
1822       Sub_Body :=
1823         Make_Subprogram_Body (Loc,
1824           Declarations => Empty_List,
1825           Specification => P_Op_Spec,
1826           Handled_Statement_Sequence =>
1827             Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
1828
1829       if not Exc_Safe then
1830          Set_Is_Protected_Subprogram_Body (Sub_Body);
1831       end if;
1832
1833       return Sub_Body;
1834    end Build_Protected_Subprogram_Body;
1835
1836    -------------------------------------
1837    -- Build_Protected_Subprogram_Call --
1838    -------------------------------------
1839
1840    procedure Build_Protected_Subprogram_Call
1841      (N        : Node_Id;
1842       Name     : Node_Id;
1843       Rec      : Node_Id;
1844       External : Boolean := True)
1845    is
1846       Loc     : constant Source_Ptr := Sloc (N);
1847       Sub     : constant Entity_Id  := Entity (Name);
1848       New_Sub : Node_Id;
1849       Params  : List_Id;
1850
1851    begin
1852       if External then
1853          New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
1854       else
1855          New_Sub :=
1856            New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
1857       end if;
1858
1859       if Present (Parameter_Associations (N)) then
1860          Params := New_Copy_List_Tree (Parameter_Associations (N));
1861       else
1862          Params := New_List;
1863       end if;
1864
1865       Prepend (Rec, Params);
1866
1867       if Ekind (Sub) = E_Procedure then
1868          Rewrite (N,
1869            Make_Procedure_Call_Statement (Loc,
1870              Name => New_Sub,
1871              Parameter_Associations => Params));
1872
1873       else
1874          pragma Assert (Ekind (Sub) = E_Function);
1875          Rewrite (N,
1876            Make_Function_Call (Loc,
1877              Name => New_Sub,
1878              Parameter_Associations => Params));
1879       end if;
1880
1881       if External
1882         and then Nkind (Rec) = N_Unchecked_Type_Conversion
1883         and then Is_Entity_Name (Expression (Rec))
1884         and then Is_Shared_Passive (Entity (Expression (Rec)))
1885       then
1886          Add_Shared_Var_Lock_Procs (N);
1887       end if;
1888    end Build_Protected_Subprogram_Call;
1889
1890    -------------------------
1891    -- Build_Selected_Name --
1892    -------------------------
1893
1894    function Build_Selected_Name
1895      (Prefix, Selector : Name_Id;
1896       Append_Char      : Character := ' ') return Name_Id
1897    is
1898       Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
1899       Select_Len    : Natural;
1900
1901    begin
1902       Get_Name_String (Selector);
1903       Select_Len := Name_Len;
1904       Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
1905       Get_Name_String (Prefix);
1906
1907       --  If scope is anonymous type, discard suffix to recover name of
1908       --  single protected object. Otherwise use protected type name.
1909
1910       if Name_Buffer (Name_Len) = 'T' then
1911          Name_Len := Name_Len - 1;
1912       end if;
1913
1914       Name_Buffer (Name_Len + 1) := 'P';
1915       Name_Buffer (Name_Len + 2) := 'T';
1916       Name_Buffer (Name_Len + 3) := '_';
1917       Name_Buffer (Name_Len + 4) := '_';
1918
1919       Name_Len := Name_Len + 4;
1920       for J in 1 .. Select_Len loop
1921          Name_Len := Name_Len + 1;
1922          Name_Buffer (Name_Len) := Select_Buffer (J);
1923       end loop;
1924
1925       if Append_Char /= ' ' then
1926          Name_Len := Name_Len + 1;
1927          Name_Buffer (Name_Len) := Append_Char;
1928       end if;
1929
1930       return Name_Find;
1931    end Build_Selected_Name;
1932
1933    -----------------------------
1934    -- Build_Simple_Entry_Call --
1935    -----------------------------
1936
1937    --  A task entry call is converted to a call to Call_Simple
1938
1939    --    declare
1940    --       P : parms := (parm, parm, parm);
1941    --    begin
1942    --       Call_Simple (acceptor-task, entry-index, P'Address);
1943    --       parm := P.param;
1944    --       parm := P.param;
1945    --       ...
1946    --    end;
1947
1948    --  Here Pnn is an aggregate of the type constructed for the entry to hold
1949    --  the parameters, and the constructed aggregate value contains either the
1950    --  parameters or, in the case of non-elementary types, references to these
1951    --  parameters. Then the address of this aggregate is passed to the runtime
1952    --  routine, along with the task id value and the task entry index value.
1953    --  Pnn is only required if parameters are present.
1954
1955    --  The assignments after the call are present only in the case of in-out
1956    --  or out parameters for elementary types, and are used to assign back the
1957    --  resulting values of such parameters.
1958
1959    --  Note: the reason that we insert a block here is that in the context
1960    --  of selects, conditional entry calls etc. the entry call statement
1961    --  appears on its own, not as an element of a list.
1962
1963    --  A protected entry call is converted to a Protected_Entry_Call:
1964
1965    --  declare
1966    --     P   : E1_Params := (param, param, param);
1967    --     Pnn : Boolean;
1968    --     Bnn : Communications_Block;
1969
1970    --  declare
1971    --     P   : E1_Params := (param, param, param);
1972    --     Bnn : Communications_Block;
1973
1974    --  begin
1975    --     Protected_Entry_Call (
1976    --       Object => po._object'Access,
1977    --       E => <entry index>;
1978    --       Uninterpreted_Data => P'Address;
1979    --       Mode => Simple_Call;
1980    --       Block => Bnn);
1981    --     parm := P.param;
1982    --     parm := P.param;
1983    --       ...
1984    --  end;
1985
1986    procedure Build_Simple_Entry_Call
1987      (N       : Node_Id;
1988       Concval : Node_Id;
1989       Ename   : Node_Id;
1990       Index   : Node_Id)
1991    is
1992    begin
1993       Expand_Call (N);
1994
1995       --  Convert entry call to Call_Simple call
1996
1997       declare
1998          Loc       : constant Source_Ptr := Sloc (N);
1999          Parms     : constant List_Id    := Parameter_Associations (N);
2000          Stats     : constant List_Id    := New_List;
2001          Pdecl     : Node_Id;
2002          Xdecl     : Node_Id;
2003          Decls     : List_Id;
2004          Conctyp   : Node_Id;
2005          Ent       : Entity_Id;
2006          Ent_Acc   : Entity_Id;
2007          P         : Entity_Id;
2008          X         : Entity_Id;
2009          Plist     : List_Id;
2010          Parm1     : Node_Id;
2011          Parm2     : Node_Id;
2012          Parm3     : Node_Id;
2013          Call      : Node_Id;
2014          Actual    : Node_Id;
2015          Formal    : Node_Id;
2016          N_Node    : Node_Id;
2017          N_Var     : Node_Id;
2018          Comm_Name : Entity_Id;
2019
2020       begin
2021          --  Simple entry and entry family cases merge here
2022
2023          Ent     := Entity (Ename);
2024          Ent_Acc := Entry_Parameters_Type (Ent);
2025          Conctyp := Etype (Concval);
2026
2027          --  If prefix is an access type, dereference to obtain the task type
2028
2029          if Is_Access_Type (Conctyp) then
2030             Conctyp := Designated_Type (Conctyp);
2031          end if;
2032
2033          --  Special case for protected subprogram calls.
2034
2035          if Is_Protected_Type (Conctyp)
2036            and then Is_Subprogram (Entity (Ename))
2037          then
2038             if not Is_Eliminated (Entity (Ename)) then
2039                Build_Protected_Subprogram_Call
2040                  (N, Ename, Convert_Concurrent (Concval, Conctyp));
2041                Analyze (N);
2042             end if;
2043
2044             return;
2045          end if;
2046
2047          --  First parameter is the Task_Id value from the task value or the
2048          --  Object from the protected object value, obtained by selecting
2049          --  the _Task_Id or _Object from the result of doing an unchecked
2050          --  conversion to convert the value to the corresponding record type.
2051
2052          Parm1 := Concurrent_Ref (Concval);
2053
2054          --  Second parameter is the entry index, computed by the routine
2055          --  provided for this purpose. The value of this expression is
2056          --  assigned to an intermediate variable to assure that any entry
2057          --  family index expressions are evaluated before the entry
2058          --  parameters.
2059
2060          if Abort_Allowed
2061            or else Restriction_Active (No_Entry_Queue) = False
2062            or else not Is_Protected_Type (Conctyp)
2063            or else Number_Entries (Conctyp) > 1
2064          then
2065             X := Make_Defining_Identifier (Loc, Name_uX);
2066
2067             Xdecl :=
2068               Make_Object_Declaration (Loc,
2069                 Defining_Identifier => X,
2070                 Object_Definition =>
2071                   New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2072                 Expression => Actual_Index_Expression (
2073                   Loc, Entity (Ename), Index, Concval));
2074
2075             Decls := New_List (Xdecl);
2076             Parm2 := New_Reference_To (X, Loc);
2077
2078          else
2079             Xdecl := Empty;
2080             Decls := New_List;
2081             Parm2 := Empty;
2082          end if;
2083
2084          --  The third parameter is the packaged parameters. If there are
2085          --  none, then it is just the null address, since nothing is passed
2086
2087          if No (Parms) then
2088             Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc);
2089             P := Empty;
2090
2091          --  Case of parameters present, where third argument is the address
2092          --  of a packaged record containing the required parameter values.
2093
2094          else
2095             --  First build a list of parameter values, which are
2096             --  references to objects of the parameter types.
2097
2098             Plist := New_List;
2099
2100             Actual := First_Actual (N);
2101             Formal := First_Formal (Ent);
2102
2103             while Present (Actual) loop
2104
2105                --  If it is a by_copy_type, copy it to a new variable. The
2106                --  packaged record has a field that points to this variable.
2107
2108                if Is_By_Copy_Type (Etype (Actual)) then
2109                   N_Node :=
2110                     Make_Object_Declaration (Loc,
2111                       Defining_Identifier =>
2112                         Make_Defining_Identifier (Loc,
2113                           Chars => New_Internal_Name ('J')),
2114                       Aliased_Present => True,
2115                       Object_Definition =>
2116                         New_Reference_To (Etype (Formal), Loc));
2117
2118                   --  We have to make an assignment statement separate for
2119                   --  the case of limited type. We can not assign it unless
2120                   --  the Assignment_OK flag is set first.
2121
2122                   if Ekind (Formal) /= E_Out_Parameter then
2123                      N_Var :=
2124                        New_Reference_To (Defining_Identifier (N_Node), Loc);
2125                      Set_Assignment_OK (N_Var);
2126                      Append_To (Stats,
2127                        Make_Assignment_Statement (Loc,
2128                          Name => N_Var,
2129                          Expression => Relocate_Node (Actual)));
2130                   end if;
2131
2132                   Append (N_Node, Decls);
2133
2134                   Append_To (Plist,
2135                     Make_Attribute_Reference (Loc,
2136                       Attribute_Name => Name_Unchecked_Access,
2137                     Prefix =>
2138                       New_Reference_To (Defining_Identifier (N_Node), Loc)));
2139                else
2140                   Append_To (Plist,
2141                     Make_Reference (Loc, Prefix => Relocate_Node (Actual)));
2142                end if;
2143
2144                Next_Actual (Actual);
2145                Next_Formal_With_Extras (Formal);
2146             end loop;
2147
2148             --  Now build the declaration of parameters initialized with the
2149             --  aggregate containing this constructed parameter list.
2150
2151             P := Make_Defining_Identifier (Loc, Name_uP);
2152
2153             Pdecl :=
2154               Make_Object_Declaration (Loc,
2155                 Defining_Identifier => P,
2156                 Object_Definition =>
2157                   New_Reference_To (Designated_Type (Ent_Acc), Loc),
2158                 Expression =>
2159                   Make_Aggregate (Loc, Expressions => Plist));
2160
2161             Parm3 :=
2162               Make_Attribute_Reference (Loc,
2163                 Attribute_Name => Name_Address,
2164                 Prefix => New_Reference_To (P, Loc));
2165
2166             Append (Pdecl, Decls);
2167          end if;
2168
2169          --  Now we can create the call, case of protected type
2170
2171          if Is_Protected_Type (Conctyp) then
2172             if Abort_Allowed
2173               or else Restriction_Active (No_Entry_Queue) = False
2174               or else Number_Entries (Conctyp) > 1
2175             then
2176                --  Change the type of the index declaration
2177
2178                Set_Object_Definition (Xdecl,
2179                  New_Reference_To (RTE (RE_Protected_Entry_Index), Loc));
2180
2181                --  Some additional declarations for protected entry calls
2182
2183                if No (Decls) then
2184                   Decls := New_List;
2185                end if;
2186
2187                --  Bnn : Communications_Block;
2188
2189                Comm_Name :=
2190                  Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
2191
2192                Append_To (Decls,
2193                  Make_Object_Declaration (Loc,
2194                    Defining_Identifier => Comm_Name,
2195                    Object_Definition =>
2196                      New_Reference_To (RTE (RE_Communication_Block), Loc)));
2197
2198                --  Some additional statements for protected entry calls
2199
2200                --     Protected_Entry_Call (
2201                --       Object => po._object'Access,
2202                --       E => <entry index>;
2203                --       Uninterpreted_Data => P'Address;
2204                --       Mode => Simple_Call;
2205                --       Block => Bnn);
2206
2207                Call :=
2208                  Make_Procedure_Call_Statement (Loc,
2209                    Name =>
2210                      New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2211
2212                    Parameter_Associations => New_List (
2213                      Make_Attribute_Reference (Loc,
2214                        Attribute_Name => Name_Unchecked_Access,
2215                        Prefix         => Parm1),
2216                      Parm2,
2217                      Parm3,
2218                      New_Reference_To (RTE (RE_Simple_Call), Loc),
2219                      New_Occurrence_Of (Comm_Name, Loc)));
2220
2221             else
2222                --     Protected_Single_Entry_Call (
2223                --       Object => po._object'Access,
2224                --       Uninterpreted_Data => P'Address;
2225                --       Mode => Simple_Call);
2226
2227                Call :=
2228                  Make_Procedure_Call_Statement (Loc,
2229                    Name => New_Reference_To (
2230                      RTE (RE_Protected_Single_Entry_Call), Loc),
2231
2232                    Parameter_Associations => New_List (
2233                      Make_Attribute_Reference (Loc,
2234                        Attribute_Name => Name_Unchecked_Access,
2235                        Prefix         => Parm1),
2236                      Parm3,
2237                      New_Reference_To (RTE (RE_Simple_Call), Loc)));
2238             end if;
2239
2240          --  Case of task type
2241
2242          else
2243             Call :=
2244               Make_Procedure_Call_Statement (Loc,
2245                 Name => New_Reference_To (RTE (RE_Call_Simple), Loc),
2246                 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
2247
2248          end if;
2249
2250          Append_To (Stats, Call);
2251
2252          --  If there are out or in/out parameters by copy
2253          --  add assignment statements for the result values.
2254
2255          if Present (Parms) then
2256             Actual := First_Actual (N);
2257             Formal := First_Formal (Ent);
2258
2259             Set_Assignment_OK (Actual);
2260             while Present (Actual) loop
2261                if Is_By_Copy_Type (Etype (Actual))
2262                  and then Ekind (Formal) /= E_In_Parameter
2263                then
2264                   N_Node :=
2265                     Make_Assignment_Statement (Loc,
2266                       Name => New_Copy (Actual),
2267                       Expression =>
2268                         Make_Explicit_Dereference (Loc,
2269                           Make_Selected_Component (Loc,
2270                             Prefix => New_Reference_To (P, Loc),
2271                             Selector_Name =>
2272                               Make_Identifier (Loc, Chars (Formal)))));
2273
2274                   --  In all cases (including limited private types) we
2275                   --  want the assignment to be valid.
2276
2277                   Set_Assignment_OK (Name (N_Node));
2278
2279                   --  If the call is the triggering alternative in an
2280                   --  asynchronous select, or the entry_call alternative
2281                   --  of a conditional entry call, the assignments for in-out
2282                   --  parameters are incorporated into the statement list
2283                   --  that follows, so that there are executed only if the
2284                   --  entry call succeeds.
2285
2286                   if (Nkind (Parent (N)) = N_Triggering_Alternative
2287                        and then N = Triggering_Statement (Parent (N)))
2288                     or else
2289                      (Nkind (Parent (N)) = N_Entry_Call_Alternative
2290                        and then N = Entry_Call_Statement (Parent (N)))
2291                   then
2292                      if No (Statements (Parent (N))) then
2293                         Set_Statements (Parent (N), New_List);
2294                      end if;
2295
2296                      Prepend (N_Node, Statements (Parent (N)));
2297
2298                   else
2299                      Insert_After (Call, N_Node);
2300                   end if;
2301                end if;
2302
2303                Next_Actual (Actual);
2304                Next_Formal_With_Extras (Formal);
2305             end loop;
2306          end if;
2307
2308          --  Finally, create block and analyze it
2309
2310          Rewrite (N,
2311            Make_Block_Statement (Loc,
2312              Declarations => Decls,
2313              Handled_Statement_Sequence =>
2314                Make_Handled_Sequence_Of_Statements (Loc,
2315                  Statements => Stats)));
2316
2317          Analyze (N);
2318       end;
2319    end Build_Simple_Entry_Call;
2320
2321    --------------------------------
2322    -- Build_Task_Activation_Call --
2323    --------------------------------
2324
2325    procedure Build_Task_Activation_Call (N : Node_Id) is
2326       Loc        : constant Source_Ptr := Sloc (N);
2327       Chain      : Entity_Id;
2328       Call       : Node_Id;
2329       Name       : Node_Id;
2330       P          : Node_Id;
2331
2332    begin
2333       --  Get the activation chain entity. Except in the case of a package
2334       --  body, this is in the node that w as passed. For a package body, we
2335       --  have to find the corresponding package declaration node.
2336
2337       if Nkind (N) = N_Package_Body then
2338          P := Corresponding_Spec (N);
2339
2340          loop
2341             P := Parent (P);
2342             exit when Nkind (P) = N_Package_Declaration;
2343          end loop;
2344
2345          Chain := Activation_Chain_Entity (P);
2346
2347       else
2348          Chain := Activation_Chain_Entity (N);
2349       end if;
2350
2351       if Present (Chain) then
2352          if Restricted_Profile then
2353             Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc);
2354          else
2355             Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
2356          end if;
2357
2358          Call :=
2359            Make_Procedure_Call_Statement (Loc,
2360              Name => Name,
2361              Parameter_Associations =>
2362                New_List (Make_Attribute_Reference (Loc,
2363                  Prefix => New_Occurrence_Of (Chain, Loc),
2364                  Attribute_Name => Name_Unchecked_Access)));
2365
2366          if Nkind (N) = N_Package_Declaration then
2367             if Present (Corresponding_Body (N)) then
2368                null;
2369
2370             elsif Present (Private_Declarations (Specification (N))) then
2371                Append (Call, Private_Declarations (Specification (N)));
2372
2373             else
2374                Append (Call, Visible_Declarations (Specification (N)));
2375             end if;
2376
2377          else
2378             if Present (Handled_Statement_Sequence (N)) then
2379
2380                --  The call goes at the start of the statement sequence, but
2381                --  after the start of exception range label if one is present.
2382
2383                declare
2384                   Stm : Node_Id;
2385
2386                begin
2387                   Stm := First (Statements (Handled_Statement_Sequence (N)));
2388
2389                   if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
2390                      Next (Stm);
2391                   end if;
2392
2393                   Insert_Before (Stm, Call);
2394                end;
2395
2396             else
2397                Set_Handled_Statement_Sequence (N,
2398                   Make_Handled_Sequence_Of_Statements (Loc,
2399                      Statements => New_List (Call)));
2400             end if;
2401          end if;
2402
2403          Analyze (Call);
2404          Check_Task_Activation (N);
2405       end if;
2406    end Build_Task_Activation_Call;
2407
2408    -------------------------------
2409    -- Build_Task_Allocate_Block --
2410    -------------------------------
2411
2412    procedure Build_Task_Allocate_Block
2413      (Actions : List_Id;
2414       N       : Node_Id;
2415       Args    : List_Id)
2416    is
2417       T      : constant Entity_Id  := Entity (Expression (N));
2418       Init   : constant Entity_Id  := Base_Init_Proc (T);
2419       Loc    : constant Source_Ptr := Sloc (N);
2420       Chain  : constant Entity_Id  :=
2421                  Make_Defining_Identifier (Loc, Name_uChain);
2422
2423       Blkent : Entity_Id;
2424       Block  : Node_Id;
2425
2426    begin
2427       Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2428
2429       Block :=
2430         Make_Block_Statement (Loc,
2431           Identifier => New_Reference_To (Blkent, Loc),
2432           Declarations => New_List (
2433
2434             --  _Chain  : Activation_Chain;
2435
2436             Make_Object_Declaration (Loc,
2437               Defining_Identifier => Chain,
2438               Aliased_Present => True,
2439               Object_Definition   =>
2440                 New_Reference_To (RTE (RE_Activation_Chain), Loc))),
2441
2442           Handled_Statement_Sequence =>
2443             Make_Handled_Sequence_Of_Statements (Loc,
2444
2445               Statements => New_List (
2446
2447                --  Init (Args);
2448
2449                 Make_Procedure_Call_Statement (Loc,
2450                   Name => New_Reference_To (Init, Loc),
2451                   Parameter_Associations => Args),
2452
2453                --  Activate_Tasks (_Chain);
2454
2455                 Make_Procedure_Call_Statement (Loc,
2456                   Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
2457                   Parameter_Associations => New_List (
2458                     Make_Attribute_Reference (Loc,
2459                       Prefix => New_Reference_To (Chain, Loc),
2460                       Attribute_Name => Name_Unchecked_Access))))),
2461
2462           Has_Created_Identifier => True,
2463           Is_Task_Allocation_Block => True);
2464
2465       Append_To (Actions,
2466         Make_Implicit_Label_Declaration (Loc,
2467           Defining_Identifier => Blkent,
2468           Label_Construct     => Block));
2469
2470       Append_To (Actions, Block);
2471
2472       Set_Activation_Chain_Entity (Block, Chain);
2473    end Build_Task_Allocate_Block;
2474
2475    -----------------------------------------------
2476    -- Build_Task_Allocate_Block_With_Init_Stmts --
2477    -----------------------------------------------
2478
2479    procedure Build_Task_Allocate_Block_With_Init_Stmts
2480      (Actions    : List_Id;
2481       N          : Node_Id;
2482       Init_Stmts : List_Id)
2483    is
2484       Loc    : constant Source_Ptr := Sloc (N);
2485       Chain  : constant Entity_Id  :=
2486                  Make_Defining_Identifier (Loc, Name_uChain);
2487       Blkent : Entity_Id;
2488       Block  : Node_Id;
2489
2490    begin
2491       Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2492
2493       Append_To (Init_Stmts,
2494         Make_Procedure_Call_Statement (Loc,
2495           Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
2496           Parameter_Associations => New_List (
2497             Make_Attribute_Reference (Loc,
2498               Prefix => New_Reference_To (Chain, Loc),
2499               Attribute_Name => Name_Unchecked_Access))));
2500
2501       Block :=
2502         Make_Block_Statement (Loc,
2503           Identifier => New_Reference_To (Blkent, Loc),
2504           Declarations => New_List (
2505
2506             --  _Chain  : Activation_Chain;
2507
2508             Make_Object_Declaration (Loc,
2509               Defining_Identifier => Chain,
2510               Aliased_Present => True,
2511               Object_Definition   =>
2512                 New_Reference_To (RTE (RE_Activation_Chain), Loc))),
2513
2514           Handled_Statement_Sequence =>
2515             Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
2516
2517           Has_Created_Identifier => True,
2518           Is_Task_Allocation_Block => True);
2519
2520       Append_To (Actions,
2521         Make_Implicit_Label_Declaration (Loc,
2522           Defining_Identifier => Blkent,
2523           Label_Construct     => Block));
2524
2525       Append_To (Actions, Block);
2526
2527       Set_Activation_Chain_Entity (Block, Chain);
2528    end Build_Task_Allocate_Block_With_Init_Stmts;
2529
2530    -----------------------------------
2531    -- Build_Task_Proc_Specification --
2532    -----------------------------------
2533
2534    function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
2535       Loc  : constant Source_Ptr := Sloc (T);
2536       Nam  : constant Name_Id    := Chars (T);
2537       Tdec : constant Node_Id    := Declaration_Node (T);
2538       Ent  : Entity_Id;
2539
2540    begin
2541       Ent :=
2542         Make_Defining_Identifier (Loc,
2543           Chars => New_External_Name (Nam, 'B'));
2544       Set_Is_Internal (Ent);
2545
2546       --  Associate the procedure with the task, if this is the declaration
2547       --  (and not the body) of the procedure.
2548
2549       if No (Task_Body_Procedure (Tdec)) then
2550          Set_Task_Body_Procedure (Tdec, Ent);
2551       end if;
2552
2553       return
2554         Make_Procedure_Specification (Loc,
2555           Defining_Unit_Name       => Ent,
2556           Parameter_Specifications =>
2557             New_List (
2558               Make_Parameter_Specification (Loc,
2559                 Defining_Identifier =>
2560                   Make_Defining_Identifier (Loc, Name_uTask),
2561                 Parameter_Type =>
2562                   Make_Access_Definition (Loc,
2563                     Subtype_Mark =>
2564                       New_Reference_To
2565                         (Corresponding_Record_Type (T), Loc)))));
2566    end Build_Task_Proc_Specification;
2567
2568    ---------------------------------------
2569    -- Build_Unprotected_Subprogram_Body --
2570    ---------------------------------------
2571
2572    function Build_Unprotected_Subprogram_Body
2573      (N   : Node_Id;
2574       Pid : Node_Id) return Node_Id
2575    is
2576       Loc       : constant Source_Ptr := Sloc (N);
2577       N_Op_Spec : Node_Id;
2578       Op_Decls  : List_Id;
2579
2580    begin
2581       --  Make an unprotected version of the subprogram for use
2582       --  within the same object, with a new name and an additional
2583       --  parameter representing the object.
2584
2585       Op_Decls := Declarations (N);
2586       N_Op_Spec :=
2587         Build_Protected_Sub_Specification
2588           (N, Pid, Unprotected => True);
2589
2590       return
2591         Make_Subprogram_Body (Loc,
2592           Specification => N_Op_Spec,
2593           Declarations => Op_Decls,
2594           Handled_Statement_Sequence =>
2595             Handled_Statement_Sequence (N));
2596    end Build_Unprotected_Subprogram_Body;
2597
2598    ----------------------------
2599    -- Collect_Entry_Families --
2600    ----------------------------
2601
2602    procedure Collect_Entry_Families
2603      (Loc          : Source_Ptr;
2604       Cdecls       : List_Id;
2605       Current_Node : in out Node_Id;
2606       Conctyp      : Entity_Id)
2607    is
2608       Efam      : Entity_Id;
2609       Efam_Decl : Node_Id;
2610       Efam_Type : Entity_Id;
2611
2612    begin
2613       Efam := First_Entity (Conctyp);
2614
2615       while Present (Efam) loop
2616
2617          if Ekind (Efam) = E_Entry_Family then
2618             Efam_Type :=
2619               Make_Defining_Identifier (Loc,
2620                 Chars => New_Internal_Name ('F'));
2621
2622             Efam_Decl :=
2623               Make_Full_Type_Declaration (Loc,
2624                 Defining_Identifier => Efam_Type,
2625                 Type_Definition =>
2626                   Make_Unconstrained_Array_Definition (Loc,
2627                     Subtype_Marks => (New_List (
2628                       New_Occurrence_Of (
2629                        Base_Type
2630                          (Etype (Discrete_Subtype_Definition
2631                            (Parent (Efam)))), Loc))),
2632
2633                     Component_Definition =>
2634                       Make_Component_Definition (Loc,
2635                         Aliased_Present    => False,
2636                         Subtype_Indication =>
2637                           New_Reference_To (Standard_Character, Loc))));
2638
2639             Insert_After (Current_Node, Efam_Decl);
2640             Current_Node := Efam_Decl;
2641             Analyze (Efam_Decl);
2642
2643             Append_To (Cdecls,
2644               Make_Component_Declaration (Loc,
2645                 Defining_Identifier =>
2646                   Make_Defining_Identifier (Loc, Chars (Efam)),
2647
2648                 Component_Definition =>
2649                   Make_Component_Definition (Loc,
2650                     Aliased_Present    => False,
2651                     Subtype_Indication =>
2652                       Make_Subtype_Indication (Loc,
2653                         Subtype_Mark =>
2654                           New_Occurrence_Of (Efam_Type, Loc),
2655
2656                         Constraint  =>
2657                           Make_Index_Or_Discriminant_Constraint (Loc,
2658                             Constraints => New_List (
2659                               New_Occurrence_Of
2660                                 (Etype (Discrete_Subtype_Definition
2661                                   (Parent (Efam))), Loc)))))));
2662
2663          end if;
2664
2665          Next_Entity (Efam);
2666       end loop;
2667    end Collect_Entry_Families;
2668
2669    --------------------
2670    -- Concurrent_Ref --
2671    --------------------
2672
2673    --  The expression returned for a reference to a concurrent
2674    --  object has the form:
2675
2676    --    taskV!(name)._Task_Id
2677
2678    --  for a task, and
2679
2680    --    objectV!(name)._Object
2681
2682    --  for a protected object.
2683
2684    --  For the case of an access to a concurrent object,
2685    --  there is an extra explicit dereference:
2686
2687    --    taskV!(name.all)._Task_Id
2688    --    objectV!(name.all)._Object
2689
2690    --  here taskV and objectV are the types for the associated records, which
2691    --  contain the required _Task_Id and _Object fields for tasks and
2692    --  protected objects, respectively.
2693
2694    --  For the case of a task type name, the expression is
2695
2696    --    Self;
2697
2698    --  i.e. a call to the Self function which returns precisely this Task_Id
2699
2700    --  For the case of a protected type name, the expression is
2701
2702    --    objectR
2703
2704    --  which is a renaming of the _object field of the current object
2705    --  object record, passed into protected operations as a parameter.
2706
2707    function Concurrent_Ref (N : Node_Id) return Node_Id is
2708       Loc  : constant Source_Ptr := Sloc (N);
2709       Ntyp : constant Entity_Id  := Etype (N);
2710       Dtyp : Entity_Id;
2711       Sel  : Name_Id;
2712
2713       function Is_Current_Task (T : Entity_Id) return Boolean;
2714       --  Check whether the reference is to the immediately enclosing task
2715       --  type, or to an outer one (rare but legal).
2716
2717       ---------------------
2718       -- Is_Current_Task --
2719       ---------------------
2720
2721       function Is_Current_Task (T : Entity_Id) return Boolean is
2722          Scop : Entity_Id;
2723
2724       begin
2725          Scop := Current_Scope;
2726          while Present (Scop)
2727            and then Scop /= Standard_Standard
2728          loop
2729
2730             if Scop = T then
2731                return True;
2732
2733             elsif Is_Task_Type (Scop) then
2734                return False;
2735
2736             --  If this is a procedure nested within the task type, we must
2737             --  assume that it can be called from an inner task, and therefore
2738             --  cannot treat it as a local reference.
2739
2740             elsif Is_Overloadable (Scop)
2741               and then In_Open_Scopes (T)
2742             then
2743                return False;
2744
2745             else
2746                Scop := Scope (Scop);
2747             end if;
2748          end loop;
2749
2750          --  We know that we are within the task body, so should have
2751          --  found it in scope.
2752
2753          raise Program_Error;
2754       end Is_Current_Task;
2755
2756    --  Start of processing for Concurrent_Ref
2757
2758    begin
2759       if Is_Access_Type (Ntyp) then
2760          Dtyp := Designated_Type (Ntyp);
2761
2762          if Is_Protected_Type (Dtyp) then
2763             Sel := Name_uObject;
2764          else
2765             Sel := Name_uTask_Id;
2766          end if;
2767
2768          return
2769            Make_Selected_Component (Loc,
2770              Prefix =>
2771                Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
2772                  Make_Explicit_Dereference (Loc, N)),
2773              Selector_Name => Make_Identifier (Loc, Sel));
2774
2775       elsif Is_Entity_Name (N)
2776         and then Is_Concurrent_Type (Entity (N))
2777       then
2778          if Is_Task_Type (Entity (N)) then
2779
2780             if Is_Current_Task (Entity (N)) then
2781                return
2782                  Make_Function_Call (Loc,
2783                    Name => New_Reference_To (RTE (RE_Self), Loc));
2784
2785             else
2786                declare
2787                   Decl   : Node_Id;
2788                   T_Self : constant Entity_Id
2789                     := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2790                   T_Body : constant Node_Id
2791                     := Parent (Corresponding_Body (Parent (Entity (N))));
2792
2793                begin
2794                   Decl := Make_Object_Declaration (Loc,
2795                      Defining_Identifier => T_Self,
2796                      Object_Definition =>
2797                        New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
2798                      Expression =>
2799                        Make_Function_Call (Loc,
2800                          Name => New_Reference_To (RTE (RE_Self), Loc)));
2801                   Prepend (Decl, Declarations (T_Body));
2802                   Analyze (Decl);
2803                   Set_Scope (T_Self, Entity (N));
2804                   return New_Occurrence_Of (T_Self,  Loc);
2805                end;
2806             end if;
2807
2808          else
2809             pragma Assert (Is_Protected_Type (Entity (N)));
2810             return
2811               New_Reference_To (
2812                 Object_Ref (Corresponding_Body (Parent (Base_Type (Ntyp)))),
2813                 Loc);
2814          end if;
2815
2816       else
2817          pragma Assert (Is_Concurrent_Type (Ntyp));
2818
2819          if Is_Protected_Type (Ntyp) then
2820             Sel := Name_uObject;
2821          else
2822             Sel := Name_uTask_Id;
2823          end if;
2824
2825          return
2826            Make_Selected_Component (Loc,
2827              Prefix =>
2828                Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
2829                  New_Copy_Tree (N)),
2830              Selector_Name => Make_Identifier (Loc, Sel));
2831       end if;
2832    end Concurrent_Ref;
2833
2834    ------------------------
2835    -- Convert_Concurrent --
2836    ------------------------
2837
2838    function Convert_Concurrent
2839      (N   : Node_Id;
2840       Typ : Entity_Id) return Node_Id
2841    is
2842    begin
2843       if not Is_Concurrent_Type (Typ) then
2844          return N;
2845       else
2846          return
2847            Unchecked_Convert_To (Corresponding_Record_Type (Typ),
2848              New_Copy_Tree (N));
2849       end if;
2850    end Convert_Concurrent;
2851
2852    ----------------------------
2853    -- Entry_Index_Expression --
2854    ----------------------------
2855
2856    function Entry_Index_Expression
2857      (Sloc  : Source_Ptr;
2858       Ent   : Entity_Id;
2859       Index : Node_Id;
2860       Ttyp  : Entity_Id) return Node_Id
2861    is
2862       Expr : Node_Id;
2863       Num  : Node_Id;
2864       Lo   : Node_Id;
2865       Hi   : Node_Id;
2866       Prev : Entity_Id;
2867       S    : Node_Id;
2868
2869    begin
2870       --  The queues of entries and entry families appear in  textual
2871       --  order in the associated record. The entry index is computed as
2872       --  the sum of the number of queues for all entries that precede the
2873       --  designated one, to which is added the index expression, if this
2874       --  expression denotes a member of a family.
2875
2876       --  The following is a place holder for the count of simple entries.
2877
2878       Num := Make_Integer_Literal (Sloc, 1);
2879
2880       --  We construct an expression which is a series of addition
2881       --  operations. The first operand is the number of single entries that
2882       --  precede this one, the second operand is the index value relative
2883       --  to the start of the referenced family, and the remaining operands
2884       --  are the lengths of the entry families that precede this entry, i.e.
2885       --  the constructed expression is:
2886
2887       --    number_simple_entries +
2888       --      (s'pos (index-value) - s'pos (family'first)) + 1 +
2889       --      family'length + ...
2890
2891       --  where index-value is the given index value, and s is the index
2892       --  subtype (we have to use pos because the subtype might be an
2893       --  enumeration type preventing direct subtraction).
2894       --  Note that the task entry array is one-indexed.
2895
2896       --  The upper bound of the entry family may be a discriminant, so we
2897       --  retrieve the lower bound explicitly to compute offset, rather than
2898       --  using the index subtype which may mention a discriminant.
2899
2900       if Present (Index) then
2901          S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
2902
2903          Expr :=
2904            Make_Op_Add (Sloc,
2905              Left_Opnd  => Num,
2906
2907              Right_Opnd =>
2908                Family_Offset (
2909                  Sloc,
2910                  Make_Attribute_Reference (Sloc,
2911                    Attribute_Name => Name_Pos,
2912                    Prefix => New_Reference_To (Base_Type (S), Sloc),
2913                    Expressions => New_List (Relocate_Node (Index))),
2914                  Type_Low_Bound (S),
2915                  Ttyp));
2916       else
2917          Expr := Num;
2918       end if;
2919
2920       --  Now add lengths of preceding entries and entry families.
2921
2922       Prev := First_Entity (Ttyp);
2923
2924       while Chars (Prev) /= Chars (Ent)
2925         or else (Ekind (Prev) /= Ekind (Ent))
2926         or else not Sem_Ch6.Type_Conformant (Ent, Prev)
2927       loop
2928          if Ekind (Prev) = E_Entry then
2929             Set_Intval (Num, Intval (Num) + 1);
2930
2931          elsif Ekind (Prev) = E_Entry_Family then
2932             S :=
2933               Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
2934             Lo := Type_Low_Bound  (S);
2935             Hi := Type_High_Bound (S);
2936
2937             Expr :=
2938               Make_Op_Add (Sloc,
2939               Left_Opnd  => Expr,
2940               Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp));
2941
2942          --  Other components are anonymous types to be ignored.
2943
2944          else
2945             null;
2946          end if;
2947
2948          Next_Entity (Prev);
2949       end loop;
2950
2951       return Expr;
2952    end Entry_Index_Expression;
2953
2954    ---------------------------
2955    -- Establish_Task_Master --
2956    ---------------------------
2957
2958    procedure Establish_Task_Master (N : Node_Id) is
2959       Call : Node_Id;
2960
2961    begin
2962       if Restriction_Active (No_Task_Hierarchy) = False then
2963          Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
2964          Prepend_To (Declarations (N), Call);
2965          Analyze (Call);
2966       end if;
2967    end Establish_Task_Master;
2968
2969    --------------------------------
2970    -- Expand_Accept_Declarations --
2971    --------------------------------
2972
2973    --  Part of the expansion of an accept statement involves the creation of
2974    --  a declaration that can be referenced from the statement sequence of
2975    --  the accept:
2976
2977    --    Ann : Address;
2978
2979    --  This declaration is inserted immediately before the accept statement
2980    --  and it is important that it be inserted before the statements of the
2981    --  statement sequence are analyzed. Thus it would be too late to create
2982    --  this declaration in the Expand_N_Accept_Statement routine, which is
2983    --  why there is a separate procedure to be called directly from Sem_Ch9.
2984
2985    --  Ann is used to hold the address of the record containing the parameters
2986    --  (see Expand_N_Entry_Call for more details on how this record is built).
2987    --  References to the parameters do an unchecked conversion of this address
2988    --  to a pointer to the required record type, and then access the field that
2989    --  holds the value of the required parameter. The entity for the address
2990    --  variable is held as the top stack element (i.e. the last element) of the
2991    --  Accept_Address stack in the corresponding entry entity, and this element
2992    --  must be set in place  before the statements are processed.
2993
2994    --  The above description applies to the case of a stand alone accept
2995    --  statement, i.e. one not appearing as part of a select alternative.
2996
2997    --  For the case of an accept that appears as part of a select alternative
2998    --  of a selective accept, we must still create the declaration right away,
2999    --  since Ann is needed immediately, but there is an important difference:
3000
3001    --    The declaration is inserted before the selective accept, not before
3002    --    the accept statement (which is not part of a list anyway, and so would
3003    --    not accommodate inserted declarations)
3004
3005    --    We only need one address variable for the entire selective accept. So
3006    --    the Ann declaration is created only for the first accept alternative,
3007    --    and subsequent accept alternatives reference the same Ann variable.
3008
3009    --  We can distinguish the two cases by seeing whether the accept statement
3010    --  is part of a list. If not, then it must be in an accept alternative.
3011
3012    --  To expand the requeue statement, a label is provided at the end of
3013    --  the accept statement or alternative of which it is a part, so that
3014    --  the statement can be skipped after the requeue is complete.
3015    --  This label is created here rather than during the expansion of the
3016    --  accept statement, because it will be needed by any requeue
3017    --  statements within the accept, which are expanded before the
3018    --  accept.
3019
3020    procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
3021       Loc    : constant Source_Ptr := Sloc (N);
3022       Ann    : Entity_Id := Empty;
3023       Adecl  : Node_Id;
3024       Lab_Id : Node_Id;
3025       Lab    : Node_Id;
3026       Ldecl  : Node_Id;
3027       Ldecl2 : Node_Id;
3028
3029    begin
3030       if Expander_Active then
3031
3032          --  If we have no handled statement sequence, then build a dummy
3033          --  sequence consisting of a null statement. This is only done if
3034          --  pragma FIFO_Within_Priorities is specified. The issue here is
3035          --  that even a null accept body has an effect on the called task
3036          --  in terms of its position in the queue, so we cannot optimize
3037          --  the context switch away. However, if FIFO_Within_Priorities
3038          --  is not active, the optimization is legitimate, since we can
3039          --  say that our dispatching policy (i.e. the default dispatching
3040          --  policy) reorders the queue to be the same as just before the
3041          --  call. In the absence of a specified dispatching policy, we are
3042          --  allowed to modify queue orders for a given priority at will!
3043
3044          if Opt.Task_Dispatching_Policy = 'F' and then
3045            not Present (Handled_Statement_Sequence (N))
3046          then
3047             Set_Handled_Statement_Sequence (N,
3048               Make_Handled_Sequence_Of_Statements (Loc,
3049                 New_List (Make_Null_Statement (Loc))));
3050          end if;
3051
3052          --  Create and declare two labels to be placed at the end of the
3053          --  accept statement. The first label is used to allow requeues to
3054          --  skip the remainder of entry processing. The second label is
3055          --  used to skip the remainder of entry processing if the rendezvous
3056          --  completes in the middle of the accept body.
3057
3058          if Present (Handled_Statement_Sequence (N)) then
3059             Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
3060             Set_Entity (Lab_Id,
3061               Make_Defining_Identifier (Loc, Chars (Lab_Id)));
3062             Lab := Make_Label (Loc, Lab_Id);
3063             Ldecl :=
3064               Make_Implicit_Label_Declaration (Loc,
3065                 Defining_Identifier  => Entity (Lab_Id),
3066                 Label_Construct      => Lab);
3067             Append (Lab, Statements (Handled_Statement_Sequence (N)));
3068
3069             Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
3070             Set_Entity (Lab_Id,
3071               Make_Defining_Identifier (Loc, Chars (Lab_Id)));
3072             Lab := Make_Label (Loc, Lab_Id);
3073             Ldecl2 :=
3074               Make_Implicit_Label_Declaration (Loc,
3075                 Defining_Identifier  => Entity (Lab_Id),
3076                 Label_Construct      => Lab);
3077             Append (Lab, Statements (Handled_Statement_Sequence (N)));
3078
3079          else
3080             Ldecl := Empty;
3081             Ldecl2 := Empty;
3082          end if;
3083
3084          --  Case of stand alone accept statement
3085
3086          if Is_List_Member (N) then
3087
3088             if Present (Handled_Statement_Sequence (N)) then
3089                Ann :=
3090                  Make_Defining_Identifier (Loc,
3091                    Chars => New_Internal_Name ('A'));
3092
3093                Adecl :=
3094                  Make_Object_Declaration (Loc,
3095                    Defining_Identifier => Ann,
3096                    Object_Definition =>
3097                      New_Reference_To (RTE (RE_Address), Loc));
3098
3099                Insert_Before (N, Adecl);
3100                Analyze (Adecl);
3101
3102                Insert_Before (N, Ldecl);
3103                Analyze (Ldecl);
3104
3105                Insert_Before (N, Ldecl2);
3106                Analyze (Ldecl2);
3107             end if;
3108
3109          --  Case of accept statement which is in an accept alternative
3110
3111          else
3112             declare
3113                Acc_Alt : constant Node_Id := Parent (N);
3114                Sel_Acc : constant Node_Id := Parent (Acc_Alt);
3115                Alt     : Node_Id;
3116
3117             begin
3118                pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
3119                pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
3120
3121                --  ??? Consider a single label for select statements.
3122
3123                if Present (Handled_Statement_Sequence (N)) then
3124                   Prepend (Ldecl2,
3125                      Statements (Handled_Statement_Sequence (N)));
3126                   Analyze (Ldecl2);
3127
3128                   Prepend (Ldecl,
3129                      Statements (Handled_Statement_Sequence (N)));
3130                   Analyze (Ldecl);
3131                end if;
3132
3133                --  Find first accept alternative of the selective accept. A
3134                --  valid selective accept must have at least one accept in it.
3135
3136                Alt := First (Select_Alternatives (Sel_Acc));
3137
3138                while Nkind (Alt) /= N_Accept_Alternative loop
3139                   Next (Alt);
3140                end loop;
3141
3142                --  If we are the first accept statement, then we have to
3143                --  create the Ann variable, as for the stand alone case,
3144                --  except that it is inserted before the selective accept.
3145                --  Similarly, a label for requeue expansion must be
3146                --  declared.
3147
3148                if N = Accept_Statement (Alt) then
3149                   Ann :=
3150                     Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
3151
3152                   Adecl :=
3153                     Make_Object_Declaration (Loc,
3154                       Defining_Identifier => Ann,
3155                       Object_Definition =>
3156                         New_Reference_To (RTE (RE_Address), Loc));
3157
3158                   Insert_Before (Sel_Acc, Adecl);
3159                   Analyze (Adecl);
3160
3161                --  If we are not the first accept statement, then find the
3162                --  Ann variable allocated by the first accept and use it.
3163
3164                else
3165                   Ann :=
3166                     Node (Last_Elmt (Accept_Address
3167                       (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
3168                end if;
3169             end;
3170          end if;
3171
3172          --  Merge here with Ann either created or referenced, and Adecl
3173          --  pointing to the corresponding declaration. Remaining processing
3174          --  is the same for the two cases.
3175
3176          if Present (Ann) then
3177             Append_Elmt (Ann, Accept_Address (Ent));
3178             Set_Needs_Debug_Info (Ann);
3179          end if;
3180
3181          --  Create renaming declarations for the entry formals. Each
3182          --  reference to a formal becomes a dereference of a component
3183          --  of the parameter block, whose address is held in Ann.
3184          --  These declarations are eventually inserted into the accept
3185          --  block, and analyzed there so that they have the proper scope
3186          --  for gdb and do not conflict with other declarations.
3187
3188          if Present (Parameter_Specifications (N))
3189            and then Present (Handled_Statement_Sequence (N))
3190          then
3191             declare
3192                Formal : Entity_Id;
3193                New_F  : Entity_Id;
3194                Comp   : Entity_Id;
3195                Decl   : Node_Id;
3196
3197             begin
3198                New_Scope (Ent);
3199                Formal := First_Formal (Ent);
3200
3201                while Present (Formal) loop
3202                   Comp   := Entry_Component (Formal);
3203                   New_F  :=
3204                     Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
3205                   Set_Etype (New_F, Etype (Formal));
3206                   Set_Scope (New_F, Ent);
3207                   Set_Needs_Debug_Info (New_F);   --  That's the whole point.
3208
3209                   if Ekind (Formal) = E_In_Parameter then
3210                      Set_Ekind (New_F, E_Constant);
3211                   else
3212                      Set_Ekind (New_F, E_Variable);
3213                      Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
3214                   end if;
3215
3216                   Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
3217
3218                   Decl :=
3219                     Make_Object_Renaming_Declaration (Loc,
3220                     Defining_Identifier => New_F,
3221                     Subtype_Mark => New_Reference_To (Etype (Formal), Loc),
3222                     Name =>
3223                       Make_Explicit_Dereference (Loc,
3224                         Make_Selected_Component (Loc,
3225                           Prefix =>
3226                             Unchecked_Convert_To (Entry_Parameters_Type (Ent),
3227                               New_Reference_To (Ann, Loc)),
3228                           Selector_Name =>
3229                             New_Reference_To (Comp, Loc))));
3230
3231                   if No (Declarations (N)) then
3232                      Set_Declarations (N, New_List);
3233                   end if;
3234
3235                   Append (Decl, Declarations (N));
3236                   Set_Renamed_Object (Formal, New_F);
3237                   Next_Formal (Formal);
3238                end loop;
3239
3240                End_Scope;
3241             end;
3242          end if;
3243       end if;
3244    end Expand_Accept_Declarations;
3245
3246    ---------------------------------------------
3247    -- Expand_Access_Protected_Subprogram_Type --
3248    ---------------------------------------------
3249
3250    procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
3251       Loc    : constant Source_Ptr := Sloc (N);
3252       Comps  : List_Id;
3253       T      : constant Entity_Id  := Defining_Identifier (N);
3254       D_T    : constant Entity_Id  := Designated_Type (T);
3255       D_T2   : constant Entity_Id  := Make_Defining_Identifier
3256                                         (Loc, New_Internal_Name ('D'));
3257       E_T    : constant Entity_Id  := Make_Defining_Identifier
3258                                         (Loc, New_Internal_Name ('E'));
3259       P_List : constant List_Id    := Build_Protected_Spec
3260                                         (N, RTE (RE_Address), False, D_T);
3261       Decl1  : Node_Id;
3262       Decl2  : Node_Id;
3263       Def1   : Node_Id;
3264
3265    begin
3266       --  Create access to protected subprogram with full signature.
3267
3268       if Nkind (Type_Definition (N)) = N_Access_Function_Definition then
3269          Def1 :=
3270            Make_Access_Function_Definition (Loc,
3271              Parameter_Specifications => P_List,
3272              Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N))));
3273
3274       else
3275          Def1 :=
3276            Make_Access_Procedure_Definition (Loc,
3277              Parameter_Specifications => P_List);
3278       end if;
3279
3280       Decl1 :=
3281         Make_Full_Type_Declaration (Loc,
3282           Defining_Identifier => D_T2,
3283           Type_Definition => Def1);
3284
3285       Analyze (Decl1);
3286       Insert_After (N, Decl1);
3287
3288       --  Create Equivalent_Type, a record with two components for an
3289       --  access to object and an access to subprogram.
3290
3291       Comps := New_List (
3292         Make_Component_Declaration (Loc,
3293           Defining_Identifier =>
3294             Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
3295           Component_Definition =>
3296             Make_Component_Definition (Loc,
3297               Aliased_Present    => False,
3298               Subtype_Indication =>
3299                 New_Occurrence_Of (RTE (RE_Address), Loc))),
3300
3301         Make_Component_Declaration (Loc,
3302           Defining_Identifier =>
3303             Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
3304           Component_Definition =>
3305             Make_Component_Definition (Loc,
3306               Aliased_Present    => False,
3307               Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
3308
3309       Decl2 :=
3310         Make_Full_Type_Declaration (Loc,
3311           Defining_Identifier => E_T,
3312           Type_Definition     =>
3313             Make_Record_Definition (Loc,
3314               Component_List =>
3315                 Make_Component_List (Loc,
3316                   Component_Items => Comps)));
3317
3318       Analyze (Decl2);
3319       Insert_After (Decl1, Decl2);
3320       Set_Equivalent_Type (T, E_T);
3321    end Expand_Access_Protected_Subprogram_Type;
3322
3323    --------------------------
3324    -- Expand_Entry_Barrier --
3325    --------------------------
3326
3327    procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
3328       Loc       : constant Source_Ptr := Sloc (N);
3329       Prot      : constant Entity_Id  := Scope (Ent);
3330       Spec_Decl : constant Node_Id    := Parent (Prot);
3331       Cond      : constant Node_Id    :=
3332                     Condition (Entry_Body_Formal_Part (N));
3333       Func      : Node_Id;
3334       B_F       : Node_Id;
3335       Body_Decl : Node_Id;
3336
3337    begin
3338       if No_Run_Time_Mode then
3339          Error_Msg_CRT ("entry barrier", N);
3340          return;
3341       end if;
3342
3343       --  The body of the entry barrier must be analyzed in the context of
3344       --  the protected object, but its scope is external to it, just as any
3345       --  other unprotected version of a protected operation. The specification
3346       --  has been produced when the protected type declaration was elaborated.
3347       --  We build the body, insert it in the enclosing scope, but analyze it
3348       --  in the current context. A more uniform approach would be to treat a
3349       --  barrier just as a protected function, and discard the protected
3350       --  version of it because it is never called.
3351
3352       if Expander_Active then
3353          B_F := Build_Barrier_Function (N, Ent, Prot);
3354          Func := Barrier_Function (Ent);
3355          Set_Corresponding_Spec (B_F, Func);
3356
3357          Body_Decl := Parent (Corresponding_Body (Spec_Decl));
3358
3359          if Nkind (Parent (Body_Decl)) = N_Subunit then
3360             Body_Decl := Corresponding_Stub (Parent (Body_Decl));
3361          end if;
3362
3363          Insert_Before_And_Analyze (Body_Decl, B_F);
3364
3365          Update_Prival_Subtypes (B_F);
3366
3367          Set_Privals (Spec_Decl, N, Loc);
3368          Set_Discriminals (Spec_Decl);
3369          Set_Scope (Func, Scope (Prot));
3370
3371       else
3372          Analyze_And_Resolve (Cond, Any_Boolean);
3373       end if;
3374
3375       --  The Ravenscar profile restricts barriers to simple variables
3376       --  declared within the protected object. We also allow Boolean
3377       --  constants, since these appear in several published examples
3378       --  and are also allowed by the Aonix compiler.
3379
3380       --  Note that after analysis variables in this context will be
3381       --  replaced by the corresponding prival, that is to say a renaming
3382       --  of a selected component of the form _Object.Var. If expansion is
3383       --  disabled, as within a generic, we check that the entity appears in
3384       --  the current scope.
3385
3386       if Is_Entity_Name (Cond) then
3387
3388          if Entity (Cond) = Standard_False
3389               or else
3390             Entity (Cond) = Standard_True
3391          then
3392             return;
3393
3394          elsif not Expander_Active
3395            and then Scope (Entity (Cond)) = Current_Scope
3396          then
3397             return;
3398
3399          --  Check for case of _object.all.field (note that the explicit
3400          --  dereference gets inserted by analyze/expand of _object.field)
3401
3402          elsif Present (Renamed_Object (Entity (Cond)))
3403            and then
3404              Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component
3405            and then
3406              Chars
3407                (Prefix
3408                  (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject
3409          then
3410             return;
3411          end if;
3412       end if;
3413
3414       --  It is not a boolean variable or literal, so check the restriction
3415
3416       Check_Restriction (Simple_Barriers, Cond);
3417    end Expand_Entry_Barrier;
3418
3419    ------------------------------------
3420    -- Expand_Entry_Body_Declarations --
3421    ------------------------------------
3422
3423    procedure Expand_Entry_Body_Declarations (N : Node_Id) is
3424       Loc        : constant Source_Ptr := Sloc (N);
3425       Index_Spec : Node_Id;
3426
3427    begin
3428       if Expander_Active then
3429
3430          --  Expand entry bodies corresponding to entry families
3431          --  by assigning a placeholder for the constant that will
3432          --  be used to expand references to the entry index parameter.
3433
3434          Index_Spec :=
3435            Entry_Index_Specification (Entry_Body_Formal_Part (N));
3436
3437          if Present (Index_Spec) then
3438             Set_Entry_Index_Constant (
3439               Defining_Identifier (Index_Spec),
3440               Make_Defining_Identifier (Loc, New_Internal_Name ('J')));
3441          end if;
3442       end if;
3443    end Expand_Entry_Body_Declarations;
3444
3445    ------------------------------
3446    -- Expand_N_Abort_Statement --
3447    ------------------------------
3448
3449    --  Expand abort T1, T2, .. Tn; into:
3450    --    Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
3451
3452    procedure Expand_N_Abort_Statement (N : Node_Id) is
3453       Loc    : constant Source_Ptr := Sloc (N);
3454       Tlist  : constant List_Id    := Names (N);
3455       Count  : Nat;
3456       Aggr   : Node_Id;
3457       Tasknm : Node_Id;
3458
3459    begin
3460       Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
3461       Count := 0;
3462
3463       Tasknm := First (Tlist);
3464
3465       while Present (Tasknm) loop
3466          Count := Count + 1;
3467          Append_To (Component_Associations (Aggr),
3468            Make_Component_Association (Loc,
3469              Choices => New_List (
3470                Make_Integer_Literal (Loc, Count)),
3471              Expression => Concurrent_Ref (Tasknm)));
3472          Next (Tasknm);
3473       end loop;
3474
3475       Rewrite (N,
3476         Make_Procedure_Call_Statement (Loc,
3477           Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc),
3478           Parameter_Associations => New_List (
3479             Make_Qualified_Expression (Loc,
3480               Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc),
3481               Expression => Aggr))));
3482
3483       Analyze (N);
3484    end Expand_N_Abort_Statement;
3485
3486    -------------------------------
3487    -- Expand_N_Accept_Statement --
3488    -------------------------------
3489
3490    --  This procedure handles expansion of accept statements that stand
3491    --  alone, i.e. they are not part of an accept alternative. The expansion
3492    --  of accept statement in accept alternatives is handled by the routines
3493    --  Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
3494    --  following description applies only to stand alone accept statements.
3495
3496    --  If there is no handled statement sequence, or only null statements,
3497    --  then this is called a trivial accept, and the expansion is:
3498
3499    --    Accept_Trivial (entry-index)
3500
3501    --  If there is a handled statement sequence, then the expansion is:
3502
3503    --    Ann : Address;
3504    --    {Lnn : Label}
3505
3506    --    begin
3507    --       begin
3508    --          Accept_Call (entry-index, Ann);
3509    --          Renaming_Declarations for formals
3510    --          <statement sequence from N_Accept_Statement node>
3511    --          Complete_Rendezvous;
3512    --          <<Lnn>>
3513    --
3514    --       exception
3515    --          when ... =>
3516    --             <exception handler from N_Accept_Statement node>
3517    --             Complete_Rendezvous;
3518    --          when ... =>
3519    --             <exception handler from N_Accept_Statement node>
3520    --             Complete_Rendezvous;
3521    --          ...
3522    --       end;
3523
3524    --    exception
3525    --       when all others =>
3526    --          Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
3527    --    end;
3528
3529    --  The first three declarations were already inserted ahead of the
3530    --  accept statement by the Expand_Accept_Declarations procedure, which
3531    --  was called directly from the semantics during analysis of the accept.
3532    --  statement, before analyzing its contained statements.
3533
3534    --  The declarations from the N_Accept_Statement, as noted in Sinfo, come
3535    --  from possible expansion activity (the original source of course does
3536    --  not have any declarations associated with the accept statement, since
3537    --  an accept statement has no declarative part). In particular, if the
3538    --  expander is active, the first such declaration is the declaration of
3539    --  the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
3540    --
3541    --  The two blocks are merged into a single block if the inner block has
3542    --  no exception handlers, but otherwise two blocks are required, since
3543    --  exceptions might be raised in the exception handlers of the inner
3544    --  block, and Exceptional_Complete_Rendezvous must be called.
3545
3546    procedure Expand_N_Accept_Statement (N : Node_Id) is
3547       Loc     : constant Source_Ptr := Sloc (N);
3548       Stats   : constant Node_Id    := Handled_Statement_Sequence (N);
3549       Ename   : constant Node_Id    := Entry_Direct_Name (N);
3550       Eindx   : constant Node_Id    := Entry_Index (N);
3551       Eent    : constant Entity_Id  := Entity (Ename);
3552       Acstack : constant Elist_Id   := Accept_Address (Eent);
3553       Ann     : constant Entity_Id  := Node (Last_Elmt (Acstack));
3554       Ttyp    : constant Entity_Id  := Etype (Scope (Eent));
3555       Blkent  : Entity_Id;
3556       Call    : Node_Id;
3557       Block   : Node_Id;
3558
3559       function Null_Statements (Stats : List_Id) return Boolean;
3560       --  Check for null statement sequence (i.e a list of labels and
3561       --  null statements)
3562
3563       function Null_Statements (Stats : List_Id) return Boolean is
3564          Stmt : Node_Id;
3565
3566       begin
3567          Stmt := First (Stats);
3568          while Nkind (Stmt) /= N_Empty
3569            and then (Nkind (Stmt) = N_Null_Statement
3570                        or else
3571                      Nkind (Stmt) = N_Label)
3572          loop
3573             Next (Stmt);
3574          end loop;
3575
3576          return Nkind (Stmt) = N_Empty;
3577       end Null_Statements;
3578
3579    --  Start of processing for Expand_N_Accept_Statement
3580
3581    begin
3582       --  If accept statement is not part of a list, then its parent must be
3583       --  an accept alternative, and, as described above, we do not do any
3584       --  expansion for such accept statements at this level.
3585
3586       if not Is_List_Member (N) then
3587          pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
3588          return;
3589
3590       --  Trivial accept case (no statement sequence, or null statements).
3591       --  If the accept statement has declarations, then just insert them
3592       --  before the procedure call.
3593
3594       --  We avoid this optimization when FIFO_Within_Priorities is active,
3595       --  since it is not correct according to annex D semantics. The problem
3596       --  is that the call is required to reorder the acceptors position on
3597       --  its ready queue, even though there is nothing to be done. However,
3598       --  if no policy is specified, then we decide that our dispatching
3599       --  policy always reorders the queue right after the RV to look the
3600       --  way they were just before the RV. Since we are allowed to freely
3601       --  reorder same-priority queues (this is part of what dispatching
3602       --  policies are all about), the optimization is legitimate.
3603
3604       elsif Opt.Task_Dispatching_Policy /= 'F'
3605         and then (No (Stats) or else Null_Statements (Statements (Stats)))
3606       then
3607          --  Remove declarations for renamings, because the parameter block
3608          --  will not be assigned.
3609
3610          declare
3611             D      : Node_Id;
3612             Next_D : Node_Id;
3613
3614          begin
3615             D := First (Declarations (N));
3616
3617             while Present (D) loop
3618                Next_D := Next (D);
3619                if Nkind (D) = N_Object_Renaming_Declaration then
3620                   Remove (D);
3621                end if;
3622
3623                D := Next_D;
3624             end loop;
3625          end;
3626
3627          if Present (Declarations (N)) then
3628             Insert_Actions (N, Declarations (N));
3629          end if;
3630
3631          Rewrite (N,
3632            Make_Procedure_Call_Statement (Loc,
3633              Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc),
3634              Parameter_Associations => New_List (
3635                Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
3636
3637          Analyze (N);
3638
3639          --  Discard Entry_Address that was created for it, so it will not be
3640          --  emitted if this accept statement is in the statement part of a
3641          --  delay alternative.
3642
3643          if Present (Stats) then
3644             Remove_Last_Elmt (Acstack);
3645          end if;
3646
3647       --  Case of statement sequence present
3648
3649       else
3650          --  Construct the block, using the declarations from the accept
3651          --  statement if any to initialize the declarations of the block.
3652
3653          Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
3654          Set_Ekind (Blkent, E_Block);
3655          Set_Etype (Blkent, Standard_Void_Type);
3656          Set_Scope (Blkent, Current_Scope);
3657
3658          Block :=
3659            Make_Block_Statement (Loc,
3660              Identifier                 => New_Reference_To (Blkent, Loc),
3661              Declarations               => Declarations (N),
3662              Handled_Statement_Sequence => Build_Accept_Body (N));
3663
3664          --  Prepend call to Accept_Call to main statement sequence
3665          --  If the accept has exception handlers, the statement sequence
3666          --  is wrapped in a block. Insert call and renaming declarations
3667          --  in the declarations of the block, so they are elaborated before
3668          --  the handlers.
3669
3670          Call :=
3671            Make_Procedure_Call_Statement (Loc,
3672              Name => New_Reference_To (RTE (RE_Accept_Call), Loc),
3673              Parameter_Associations => New_List (
3674                Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
3675                New_Reference_To (Ann, Loc)));
3676
3677          if Parent (Stats) = N then
3678             Prepend (Call, Statements (Stats));
3679          else
3680             Set_Declarations
3681               (Parent (Stats),
3682                 New_List (Call));
3683          end if;
3684
3685          Analyze (Call);
3686
3687          New_Scope (Blkent);
3688
3689          declare
3690             D      : Node_Id;
3691             Next_D : Node_Id;
3692             Typ    : Entity_Id;
3693          begin
3694             D := First (Declarations (N));
3695
3696             while Present (D) loop
3697                Next_D := Next (D);
3698
3699                if Nkind (D) = N_Object_Renaming_Declaration then
3700                   --  The renaming declarations for the formals were
3701                   --  created during analysis of the accept statement,
3702                   --  and attached to the list of declarations. Place
3703                   --  them now in the context of the accept block or
3704                   --  subprogram.
3705
3706                   Remove (D);
3707                   Typ := Entity (Subtype_Mark (D));
3708                   Insert_After (Call, D);
3709                   Analyze (D);
3710
3711                   --  If the formal is class_wide, it does not have an
3712                   --  actual subtype. The analysis of the renaming declaration
3713                   --  creates one, but we need to retain the class-wide
3714                   --  nature of the entity.
3715
3716                   if Is_Class_Wide_Type (Typ) then
3717                      Set_Etype (Defining_Identifier (D), Typ);
3718                   end if;
3719
3720                end if;
3721
3722                D := Next_D;
3723             end loop;
3724          end;
3725
3726          End_Scope;
3727
3728          --  Replace the accept statement by the new block
3729
3730          Rewrite (N, Block);
3731          Analyze (N);
3732
3733          --  Last step is to unstack the Accept_Address value
3734
3735          Remove_Last_Elmt (Acstack);
3736       end if;
3737    end Expand_N_Accept_Statement;
3738
3739    ----------------------------------
3740    -- Expand_N_Asynchronous_Select --
3741    ----------------------------------
3742
3743    --  This procedure assumes that the trigger statement is an entry
3744    --  call. A delay alternative should already have been expanded
3745    --  into an entry call to the appropriate delay object Wait entry.
3746
3747    --  If the trigger is a task entry call, the select is implemented
3748    --  with Task_Entry_Call:
3749
3750    --    declare
3751    --       B : Boolean;
3752    --       C : Boolean;
3753    --       P : parms := (parm, parm, parm);
3754
3755    --        --  Clean is added by Exp_Ch7.Expand_Cleanup_Actions.
3756
3757    --       procedure _clean is
3758    --       begin
3759    --          ...
3760    --          Cancel_Task_Entry_Call (C);
3761    --          ...
3762    --       end _clean;
3763
3764    --    begin
3765    --       Abort_Defer;
3766    --       Task_Entry_Call
3767    --         (acceptor-task,
3768    --          entry-index,
3769    --          P'Address,
3770    --          Asynchronous_Call,
3771    --          B);
3772
3773    --       begin
3774    --          begin
3775    --             Abort_Undefer;
3776    --             abortable-part
3777    --          at end
3778    --             _clean;        --  Added by Exp_Ch7.Expand_Cleanup_Actions.
3779    --          end;
3780
3781    --       exception
3782    --       when Abort_Signal => Abort_Undefer;
3783    --       end;
3784    --       parm := P.param;
3785    --       parm := P.param;
3786    --       ...
3787    --       if not C then
3788    --          triggered-statements
3789    --       end if;
3790    --    end;
3791
3792    --  Note that Build_Simple_Entry_Call is used to expand the entry
3793    --  of the asynchronous entry call (by the
3794    --  Expand_N_Entry_Call_Statement procedure) as follows:
3795
3796    --    declare
3797    --       P : parms := (parm, parm, parm);
3798    --    begin
3799    --       Call_Simple (acceptor-task, entry-index, P'Address);
3800    --       parm := P.param;
3801    --       parm := P.param;
3802    --       ...
3803    --    end;
3804
3805    --  so the task at hand is to convert the latter expansion into the former
3806
3807    --  If the trigger is a protected entry call, the select is
3808    --  implemented with Protected_Entry_Call:
3809
3810    --  declare
3811    --     P   : E1_Params := (param, param, param);
3812    --     Bnn : Communications_Block;
3813
3814    --  begin
3815    --     declare
3816    --        --  Clean is added by Exp_Ch7.Expand_Cleanup_Actions.
3817    --        procedure _clean is
3818    --        begin
3819    --           ...
3820    --           if Enqueued (Bnn) then
3821    --              Cancel_Protected_Entry_Call (Bnn);
3822    --           end if;
3823    --           ...
3824    --        end _clean;
3825
3826    --     begin
3827    --        begin
3828    --           Protected_Entry_Call (
3829    --             Object => po._object'Access,
3830    --             E => <entry index>;
3831    --             Uninterpreted_Data => P'Address;
3832    --             Mode => Asynchronous_Call;
3833    --             Block => Bnn);
3834    --           if Enqueued (Bnn) then
3835    --              <abortable part>
3836    --           end if;
3837    --        at end
3838    --           _clean;        --  Added by Exp_Ch7.Expand_Cleanup_Actions.
3839    --        end;
3840
3841    --     exception
3842    --        when Abort_Signal =>
3843    --           Abort_Undefer;
3844    --           null;
3845    --     end;
3846
3847    --     if not Cancelled (Bnn) then
3848    --        triggered statements
3849    --     end if;
3850    --  end;
3851
3852    --  Build_Simple_Entry_Call is used to expand the all to a simple
3853    --  protected entry call:
3854
3855    --  declare
3856    --     P   : E1_Params := (param, param, param);
3857    --     Bnn : Communications_Block;
3858
3859    --  begin
3860    --     Protected_Entry_Call (
3861    --       Object => po._object'Access,
3862    --       E => <entry index>;
3863    --       Uninterpreted_Data => P'Address;
3864    --       Mode => Simple_Call;
3865    --       Block => Bnn);
3866    --     parm := P.param;
3867    --     parm := P.param;
3868    --       ...
3869    --  end;
3870
3871    --  The job is to convert this to the asynchronous form.
3872
3873    --  If the trigger is a delay statement, it will have been expanded
3874    --  into a call to one of the GNARL delay procedures. This routine
3875    --  will convert this into a protected entry call on a delay object
3876    --  and then continue processing as for a protected entry call trigger.
3877    --  This requires declaring a Delay_Block object and adding a pointer
3878    --  to this object to the parameter list of the delay procedure to form
3879    --  the parameter list of the entry call. This object is used by
3880    --  the runtime to queue the delay request.
3881
3882    --  For a description of the use of P and the assignments after the
3883    --  call, see Expand_N_Entry_Call_Statement.
3884
3885    procedure Expand_N_Asynchronous_Select (N : Node_Id) is
3886       Loc    : constant Source_Ptr := Sloc (N);
3887       Trig   : constant Node_Id    := Triggering_Alternative (N);
3888       Abrt   : constant Node_Id    := Abortable_Part (N);
3889       Tstats : constant List_Id    := Statements (Trig);
3890       Astats : constant List_Id    := Statements (Abrt);
3891
3892       Ecall           : Node_Id;
3893       Concval         : Node_Id;
3894       Ename           : Node_Id;
3895       Index           : Node_Id;
3896       Hdle            : List_Id;
3897       Decls           : List_Id;
3898       Decl            : Node_Id;
3899       Parms           : List_Id;
3900       Parm            : Node_Id;
3901       Call            : Node_Id;
3902       Stmts           : List_Id;
3903       Enqueue_Call    : Node_Id;
3904       Stmt            : Node_Id;
3905       B               : Entity_Id;
3906       Pdef            : Entity_Id;
3907       Dblock_Ent      : Entity_Id;
3908       N_Orig          : Node_Id;
3909       Abortable_Block : Node_Id;
3910       Cancel_Param    : Entity_Id;
3911       Blkent          : Entity_Id;
3912       Target_Undefer  : RE_Id;
3913       Undefer_Args    : List_Id := No_List;
3914
3915    begin
3916       Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
3917       Ecall := Triggering_Statement (Trig);
3918
3919       --  The arguments in the call may require dynamic allocation, and the
3920       --  call statement may have been transformed into a block. The block
3921       --  may contain additional declarations for internal entities, and the
3922       --  original call is found by sequential search.
3923
3924       if Nkind (Ecall) = N_Block_Statement then
3925          Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
3926
3927          while Nkind (Ecall) /= N_Procedure_Call_Statement
3928            and then Nkind (Ecall) /= N_Entry_Call_Statement
3929          loop
3930             Next (Ecall);
3931          end loop;
3932       end if;
3933
3934       --  If a delay was used as a trigger, it will have been expanded
3935       --  into a procedure call. Convert it to the appropriate sequence of
3936       --  statements, similar to what is done for a task entry call.
3937       --  Note that this currently supports only Duration, Real_Time.Time,
3938       --  and Calendar.Time.
3939
3940       if Nkind (Ecall) = N_Procedure_Call_Statement then
3941
3942          --  Add a Delay_Block object to the parameter list of the
3943          --  delay procedure to form the parameter list of the Wait
3944          --  entry call.
3945
3946          Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
3947
3948          Pdef := Entity (Name (Ecall));
3949
3950          if Is_RTE (Pdef, RO_CA_Delay_For) then
3951             Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
3952
3953          elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
3954             Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
3955
3956          else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
3957             Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
3958          end if;
3959
3960          Append_To (Parameter_Associations (Ecall),
3961            Make_Attribute_Reference (Loc,
3962              Prefix => New_Reference_To (Dblock_Ent, Loc),
3963              Attribute_Name => Name_Unchecked_Access));
3964
3965          --  Create the inner block to protect the abortable part.
3966
3967          Hdle := New_List (
3968            Make_Exception_Handler (Loc,
3969              Exception_Choices =>
3970                New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
3971              Statements => New_List (
3972                Make_Procedure_Call_Statement (Loc,
3973                  Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
3974
3975          Prepend_To (Astats,
3976            Make_Procedure_Call_Statement (Loc,
3977              Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
3978
3979          Abortable_Block :=
3980            Make_Block_Statement (Loc,
3981              Identifier => New_Reference_To (Blkent, Loc),
3982              Handled_Statement_Sequence =>
3983                Make_Handled_Sequence_Of_Statements (Loc,
3984                  Statements => Astats),
3985              Has_Created_Identifier => True,
3986              Is_Asynchronous_Call_Block => True);
3987
3988          --  Append call to if Enqueue (When, DB'Unchecked_Access) then
3989
3990          Rewrite (Ecall,
3991            Make_Implicit_If_Statement (N,
3992              Condition => Make_Function_Call (Loc,
3993                Name => Enqueue_Call,
3994                Parameter_Associations => Parameter_Associations (Ecall)),
3995              Then_Statements =>
3996                New_List (Make_Block_Statement (Loc,
3997                  Handled_Statement_Sequence =>
3998                    Make_Handled_Sequence_Of_Statements (Loc,
3999                      Statements => New_List (
4000                        Make_Implicit_Label_Declaration (Loc,
4001                          Defining_Identifier => Blkent,
4002                          Label_Construct     => Abortable_Block),
4003                        Abortable_Block),
4004                      Exception_Handlers => Hdle)))));
4005
4006          Stmts := New_List (Ecall);
4007
4008          --  Construct statement sequence for new block
4009
4010          Append_To (Stmts,
4011            Make_Implicit_If_Statement (N,
4012              Condition => Make_Function_Call (Loc,
4013                Name => New_Reference_To (
4014                  RTE (RE_Timed_Out), Loc),
4015                Parameter_Associations => New_List (
4016                  Make_Attribute_Reference (Loc,
4017                    Prefix => New_Reference_To (Dblock_Ent, Loc),
4018                    Attribute_Name => Name_Unchecked_Access))),
4019              Then_Statements => Tstats));
4020
4021          --  The result is the new block
4022
4023          Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent);
4024
4025          Rewrite (N,
4026            Make_Block_Statement (Loc,
4027              Declarations => New_List (
4028                Make_Object_Declaration (Loc,
4029                  Defining_Identifier => Dblock_Ent,
4030                  Aliased_Present => True,
4031                  Object_Definition => New_Reference_To (
4032                    RTE (RE_Delay_Block), Loc))),
4033
4034              Handled_Statement_Sequence =>
4035                Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
4036
4037          Analyze (N);
4038          return;
4039
4040       else
4041          N_Orig := N;
4042       end if;
4043
4044       Extract_Entry (Ecall, Concval, Ename, Index);
4045       Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
4046
4047       Stmts := Statements (Handled_Statement_Sequence (Ecall));
4048       Decls := Declarations (Ecall);
4049
4050       if Is_Protected_Type (Etype (Concval)) then
4051
4052          --  Get the declarations of the block expanded from the entry call
4053
4054          Decl := First (Decls);
4055          while Present (Decl)
4056            and then (Nkind (Decl) /= N_Object_Declaration
4057              or else not Is_RTE
4058                (Etype (Object_Definition (Decl)), RE_Communication_Block))
4059          loop
4060             Next (Decl);
4061          end loop;
4062
4063          pragma Assert (Present (Decl));
4064          Cancel_Param := Defining_Identifier (Decl);
4065
4066          --  Change the mode of the Protected_Entry_Call call.
4067          --  Protected_Entry_Call (
4068          --    Object => po._object'Access,
4069          --    E => <entry index>;
4070          --    Uninterpreted_Data => P'Address;
4071          --    Mode => Asynchronous_Call;
4072          --    Block => Bnn);
4073
4074          Stmt := First (Stmts);
4075
4076          --  Skip assignments to temporaries created for in-out parameters.
4077          --  This makes unwarranted assumptions about the shape of the expanded
4078          --  tree for the call, and should be cleaned up ???
4079
4080          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
4081             Next (Stmt);
4082          end loop;
4083
4084          Call := Stmt;
4085
4086          Parm := First (Parameter_Associations (Call));
4087          while Present (Parm)
4088            and then not Is_RTE (Etype (Parm), RE_Call_Modes)
4089          loop
4090             Next (Parm);
4091          end loop;
4092
4093          pragma Assert (Present (Parm));
4094          Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
4095          Analyze (Parm);
4096
4097          --  Append an if statement to execute the abortable part.
4098          --  if Enqueued (Bnn) then
4099
4100          Append_To (Stmts,
4101            Make_Implicit_If_Statement (N,
4102              Condition => Make_Function_Call (Loc,
4103                Name => New_Reference_To (
4104                  RTE (RE_Enqueued), Loc),
4105                Parameter_Associations => New_List (
4106                  New_Reference_To (Cancel_Param, Loc))),
4107              Then_Statements => Astats));
4108
4109          Abortable_Block :=
4110            Make_Block_Statement (Loc,
4111              Identifier => New_Reference_To (Blkent, Loc),
4112              Handled_Statement_Sequence =>
4113                Make_Handled_Sequence_Of_Statements (Loc,
4114                  Statements => Stmts),
4115              Has_Created_Identifier => True,
4116              Is_Asynchronous_Call_Block => True);
4117
4118          --  For the JVM call Update_Exception instead of Abort_Undefer.
4119          --  See 4jexcept.ads for an explanation.
4120
4121          if Hostparm.Java_VM then
4122             Target_Undefer := RE_Update_Exception;
4123             Undefer_Args :=
4124               New_List (Make_Function_Call (Loc,
4125                           Name => New_Occurrence_Of
4126                                     (RTE (RE_Current_Target_Exception), Loc)));
4127          else
4128             Target_Undefer := RE_Abort_Undefer;
4129          end if;
4130
4131          Stmts := New_List (
4132            Make_Block_Statement (Loc,
4133              Handled_Statement_Sequence =>
4134                Make_Handled_Sequence_Of_Statements (Loc,
4135                  Statements => New_List (
4136                    Make_Implicit_Label_Declaration (Loc,
4137                      Defining_Identifier => Blkent,
4138                      Label_Construct     => Abortable_Block),
4139                    Abortable_Block),
4140
4141                --  exception
4142
4143                  Exception_Handlers => New_List (
4144                    Make_Exception_Handler (Loc,
4145
4146                --  when Abort_Signal =>
4147                --     Abort_Undefer.all;
4148
4149                      Exception_Choices =>
4150                        New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
4151                      Statements => New_List (
4152                        Make_Procedure_Call_Statement (Loc,
4153                          Name => New_Reference_To (
4154                            RTE (Target_Undefer), Loc),
4155                          Parameter_Associations => Undefer_Args)))))),
4156
4157          --  if not Cancelled (Bnn) then
4158          --     triggered statements
4159          --  end if;
4160
4161            Make_Implicit_If_Statement (N,
4162              Condition => Make_Op_Not (Loc,
4163                Right_Opnd =>
4164                  Make_Function_Call (Loc,
4165                    Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
4166                    Parameter_Associations => New_List (
4167                      New_Occurrence_Of (Cancel_Param, Loc)))),
4168              Then_Statements => Tstats));
4169
4170       --  Asynchronous task entry call
4171
4172       else
4173          if No (Decls) then
4174             Decls := New_List;
4175          end if;
4176
4177          B := Make_Defining_Identifier (Loc, Name_uB);
4178
4179          --  Insert declaration of B in declarations of existing block
4180
4181          Prepend_To (Decls,
4182            Make_Object_Declaration (Loc,
4183              Defining_Identifier => B,
4184              Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
4185
4186          Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
4187
4188          --  Insert declaration of C in declarations of existing block
4189
4190          Prepend_To (Decls,
4191            Make_Object_Declaration (Loc,
4192              Defining_Identifier => Cancel_Param,
4193              Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
4194
4195          --  Remove and save the call to Call_Simple.
4196
4197          Stmt := First (Stmts);
4198
4199          --  Skip assignments to temporaries created for in-out parameters.
4200          --  This makes unwarranted assumptions about the shape of the expanded
4201          --  tree for the call, and should be cleaned up ???
4202
4203          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
4204             Next (Stmt);
4205          end loop;
4206
4207          Call := Stmt;
4208
4209          --  Create the inner block to protect the abortable part.
4210
4211          Hdle :=  New_List (
4212            Make_Exception_Handler (Loc,
4213              Exception_Choices =>
4214                New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
4215              Statements => New_List (
4216                Make_Procedure_Call_Statement (Loc,
4217                  Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
4218
4219          Prepend_To (Astats,
4220            Make_Procedure_Call_Statement (Loc,
4221              Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
4222
4223          Abortable_Block :=
4224            Make_Block_Statement (Loc,
4225              Identifier => New_Reference_To (Blkent, Loc),
4226              Handled_Statement_Sequence =>
4227                Make_Handled_Sequence_Of_Statements (Loc,
4228                  Statements => Astats),
4229              Has_Created_Identifier => True,
4230              Is_Asynchronous_Call_Block => True);
4231
4232          Insert_After (Call,
4233            Make_Block_Statement (Loc,
4234              Handled_Statement_Sequence =>
4235                Make_Handled_Sequence_Of_Statements (Loc,
4236                  Statements => New_List (
4237                    Make_Implicit_Label_Declaration (Loc,
4238                      Defining_Identifier => Blkent,
4239                      Label_Construct     => Abortable_Block),
4240                    Abortable_Block),
4241                  Exception_Handlers => Hdle)));
4242
4243          --  Create new call statement
4244
4245          Parms := Parameter_Associations (Call);
4246          Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
4247          Append_To (Parms, New_Reference_To (B, Loc));
4248          Rewrite (Call,
4249            Make_Procedure_Call_Statement (Loc,
4250              Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
4251              Parameter_Associations => Parms));
4252
4253          --  Construct statement sequence for new block
4254
4255          Append_To (Stmts,
4256            Make_Implicit_If_Statement (N,
4257              Condition => Make_Op_Not (Loc,
4258                New_Reference_To (Cancel_Param, Loc)),
4259              Then_Statements => Tstats));
4260
4261          --  Protected the call against abortion
4262
4263          Prepend_To (Stmts,
4264            Make_Procedure_Call_Statement (Loc,
4265              Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
4266              Parameter_Associations => Empty_List));
4267       end if;
4268
4269       Set_Entry_Cancel_Parameter (Blkent, Cancel_Param);
4270
4271       --  The result is the new block
4272
4273       Rewrite (N_Orig,
4274         Make_Block_Statement (Loc,
4275           Declarations => Decls,
4276           Handled_Statement_Sequence =>
4277             Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
4278
4279       Analyze (N_Orig);
4280    end Expand_N_Asynchronous_Select;
4281
4282    -------------------------------------
4283    -- Expand_N_Conditional_Entry_Call --
4284    -------------------------------------
4285
4286    --  The conditional task entry call is converted to a call to
4287    --  Task_Entry_Call:
4288
4289    --    declare
4290    --       B : Boolean;
4291    --       P : parms := (parm, parm, parm);
4292
4293    --    begin
4294    --       Task_Entry_Call
4295    --         (acceptor-task,
4296    --          entry-index,
4297    --          P'Address,
4298    --          Conditional_Call,
4299    --          B);
4300    --       parm := P.param;
4301    --       parm := P.param;
4302    --       ...
4303    --       if B then
4304    --          normal-statements
4305    --       else
4306    --          else-statements
4307    --       end if;
4308    --    end;
4309
4310    --  For a description of the use of P and the assignments after the
4311    --  call, see Expand_N_Entry_Call_Statement. Note that the entry call
4312    --  of the conditional entry call has already been expanded (by the
4313    --  Expand_N_Entry_Call_Statement procedure) as follows:
4314
4315    --    declare
4316    --       P : parms := (parm, parm, parm);
4317    --    begin
4318    --       ... info for in-out parameters
4319    --       Call_Simple (acceptor-task, entry-index, P'Address);
4320    --       parm := P.param;
4321    --       parm := P.param;
4322    --       ...
4323    --    end;
4324
4325    --  so the task at hand is to convert the latter expansion into the former
4326
4327    --  The conditional protected entry call is converted to a call to
4328    --  Protected_Entry_Call:
4329
4330    --    declare
4331    --       P : parms := (parm, parm, parm);
4332    --       Bnn : Communications_Block;
4333
4334    --    begin
4335    --       Protected_Entry_Call (
4336    --         Object => po._object'Access,
4337    --         E => <entry index>;
4338    --         Uninterpreted_Data => P'Address;
4339    --         Mode => Conditional_Call;
4340    --         Block => Bnn);
4341    --       parm := P.param;
4342    --       parm := P.param;
4343    --       ...
4344    --       if Cancelled (Bnn) then
4345    --          else-statements
4346    --       else
4347    --          normal-statements
4348    --       end if;
4349    --    end;
4350
4351    --  As for tasks, the entry call of the conditional entry call has
4352    --  already been expanded (by the Expand_N_Entry_Call_Statement procedure)
4353    --  as follows:
4354
4355    --    declare
4356    --       P   : E1_Params := (param, param, param);
4357    --       Bnn : Communications_Block;
4358
4359    --    begin
4360    --       Protected_Entry_Call (
4361    --         Object => po._object'Access,
4362    --         E => <entry index>;
4363    --         Uninterpreted_Data => P'Address;
4364    --         Mode => Simple_Call;
4365    --         Block => Bnn);
4366    --       parm := P.param;
4367    --       parm := P.param;
4368    --         ...
4369    --    end;
4370
4371    procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
4372       Loc : constant Source_Ptr := Sloc (N);
4373       Alt : constant Node_Id    := Entry_Call_Alternative (N);
4374       Blk : Node_Id             := Entry_Call_Statement (Alt);
4375       Transient_Blk : Node_Id;
4376
4377       Parms   : List_Id;
4378       Parm    : Node_Id;
4379       Call    : Node_Id;
4380       Stmts   : List_Id;
4381       B       : Entity_Id;
4382       Decl    : Node_Id;
4383       Stmt    : Node_Id;
4384
4385    begin
4386       --  As described above, The entry alternative is transformed into a
4387       --  block that contains the gnulli call, and possibly assignment
4388       --  statements for in-out parameters. The gnulli call may itself be
4389       --  rewritten into a transient block if some unconstrained parameters
4390       --  require it. We need to retrieve the call to complete its parameter
4391       --  list.
4392
4393       Transient_Blk :=
4394          First_Real_Statement (Handled_Statement_Sequence (Blk));
4395
4396       if Present (Transient_Blk)
4397         and then
4398         Nkind (Transient_Blk) =  N_Block_Statement
4399       then
4400          Blk := Transient_Blk;
4401       end if;
4402
4403       Stmts := Statements (Handled_Statement_Sequence (Blk));
4404
4405       Stmt := First (Stmts);
4406
4407       while Nkind (Stmt) /= N_Procedure_Call_Statement loop
4408          Next (Stmt);
4409       end loop;
4410
4411       Call := Stmt;
4412
4413       Parms := Parameter_Associations (Call);
4414
4415       if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
4416
4417          --  Substitute Conditional_Entry_Call for Simple_Call
4418          --  parameter.
4419
4420          Parm := First (Parms);
4421          while Present (Parm)
4422            and then not Is_RTE (Etype (Parm), RE_Call_Modes)
4423          loop
4424             Next (Parm);
4425          end loop;
4426
4427          pragma Assert (Present (Parm));
4428          Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc));
4429
4430          Analyze (Parm);
4431
4432          --  Find the Communication_Block parameter for the call
4433          --  to the Cancelled function.
4434
4435          Decl := First (Declarations (Blk));
4436          while Present (Decl)
4437            and then not
4438              Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block)
4439          loop
4440             Next (Decl);
4441          end loop;
4442
4443          --  Add an if statement to execute the else part if the call
4444          --  does not succeed (as indicated by the Cancelled predicate).
4445
4446          Append_To (Stmts,
4447            Make_Implicit_If_Statement (N,
4448              Condition => Make_Function_Call (Loc,
4449                Name => New_Reference_To (RTE (RE_Cancelled), Loc),
4450                Parameter_Associations => New_List (
4451                  New_Reference_To (Defining_Identifier (Decl), Loc))),
4452              Then_Statements => Else_Statements (N),
4453              Else_Statements => Statements (Alt)));
4454
4455       else
4456          B := Make_Defining_Identifier (Loc, Name_uB);
4457
4458          --  Insert declaration of B in declarations of existing block
4459
4460          if No (Declarations (Blk)) then
4461             Set_Declarations (Blk, New_List);
4462          end if;
4463
4464          Prepend_To (Declarations (Blk),
4465          Make_Object_Declaration (Loc,
4466            Defining_Identifier => B,
4467            Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
4468
4469          --  Create new call statement
4470
4471          Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc));
4472          Append_To (Parms, New_Reference_To (B, Loc));
4473
4474          Rewrite (Call,
4475            Make_Procedure_Call_Statement (Loc,
4476              Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
4477              Parameter_Associations => Parms));
4478
4479          --  Construct statement sequence for new block
4480
4481          Append_To (Stmts,
4482            Make_Implicit_If_Statement (N,
4483              Condition => New_Reference_To (B, Loc),
4484              Then_Statements => Statements (Alt),
4485              Else_Statements => Else_Statements (N)));
4486
4487       end if;
4488
4489       --  The result is the new block
4490
4491       Rewrite (N,
4492         Make_Block_Statement (Loc,
4493           Declarations => Declarations (Blk),
4494           Handled_Statement_Sequence =>
4495             Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
4496
4497       Analyze (N);
4498    end Expand_N_Conditional_Entry_Call;
4499
4500    ---------------------------------------
4501    -- Expand_N_Delay_Relative_Statement --
4502    ---------------------------------------
4503
4504    --  Delay statement is implemented as a procedure call to Delay_For
4505    --  defined in Ada.Calendar.Delays in order to reduce the overhead of
4506    --  simple delays imposed by the use of Protected Objects.
4507
4508    procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
4509       Loc : constant Source_Ptr := Sloc (N);
4510
4511    begin
4512       Rewrite (N,
4513         Make_Procedure_Call_Statement (Loc,
4514           Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc),
4515           Parameter_Associations => New_List (Expression (N))));
4516       Analyze (N);
4517    end Expand_N_Delay_Relative_Statement;
4518
4519    ------------------------------------
4520    -- Expand_N_Delay_Until_Statement --
4521    ------------------------------------
4522
4523    --  Delay Until statement is implemented as a procedure call to
4524    --  Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
4525
4526    procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
4527       Loc : constant Source_Ptr := Sloc (N);
4528       Typ : Entity_Id;
4529
4530    begin
4531       if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
4532          Typ := RTE (RO_CA_Delay_Until);
4533       else
4534          Typ := RTE (RO_RT_Delay_Until);
4535       end if;
4536
4537       Rewrite (N,
4538         Make_Procedure_Call_Statement (Loc,
4539           Name => New_Reference_To (Typ, Loc),
4540           Parameter_Associations => New_List (Expression (N))));
4541
4542       Analyze (N);
4543    end Expand_N_Delay_Until_Statement;
4544
4545    -------------------------
4546    -- Expand_N_Entry_Body --
4547    -------------------------
4548
4549    procedure Expand_N_Entry_Body (N : Node_Id) is
4550       Loc         : constant Source_Ptr := Sloc (N);
4551       Dec         : constant Node_Id    := Parent (Current_Scope);
4552       Ent_Formals : constant Node_Id    := Entry_Body_Formal_Part (N);
4553       Index_Spec  : constant Node_Id    :=
4554                       Entry_Index_Specification (Ent_Formals);
4555       Next_Op     : Node_Id;
4556       First_Decl  : constant Node_Id := First (Declarations (N));
4557       Index_Decl  : List_Id;
4558
4559    begin
4560       --  Add the renamings for private declarations and discriminants.
4561
4562       Add_Discriminal_Declarations
4563         (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc);
4564       Add_Private_Declarations
4565         (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc);
4566
4567       if Present (Index_Spec) then
4568          Index_Decl :=
4569            Index_Constant_Declaration
4570              (N,
4571                Defining_Identifier (Index_Spec), Defining_Identifier (Dec));
4572
4573          --  If the entry has local declarations, insert index declaration
4574          --  before them, because the index may be used therein.
4575
4576          if Present (First_Decl) then
4577             Insert_List_Before (First_Decl, Index_Decl);
4578          else
4579             Append_List_To (Declarations (N), Index_Decl);
4580          end if;
4581       end if;
4582
4583       --  Associate privals and discriminals with the next protected
4584       --  operation body to be expanded. These are used to expand
4585       --  references to private data objects and discriminants,
4586       --  respectively.
4587
4588       Next_Op := Next_Protected_Operation (N);
4589
4590       if Present (Next_Op) then
4591          Set_Privals (Dec, Next_Op, Loc);
4592          Set_Discriminals (Dec);
4593       end if;
4594    end Expand_N_Entry_Body;
4595
4596    -----------------------------------
4597    -- Expand_N_Entry_Call_Statement --
4598    -----------------------------------
4599
4600    --  An entry call is expanded into GNARLI calls to implement
4601    --  a simple entry call (see Build_Simple_Entry_Call).
4602
4603    procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
4604       Concval : Node_Id;
4605       Ename   : Node_Id;
4606       Index   : Node_Id;
4607
4608    begin
4609       if No_Run_Time_Mode then
4610          Error_Msg_CRT ("entry call", N);
4611          return;
4612       end if;
4613
4614       --  If this entry call is part of an asynchronous select, don't
4615       --  expand it here; it will be expanded with the select statement.
4616       --  Don't expand timed entry calls either, as they are translated
4617       --  into asynchronous entry calls.
4618
4619       --  ??? This whole approach is questionable; it may be better
4620       --  to go back to allowing the expansion to take place and then
4621       --  attempting to fix it up in Expand_N_Asynchronous_Select.
4622       --  The tricky part is figuring out whether the expanded
4623       --  call is on a task or protected entry.
4624
4625       if (Nkind (Parent (N)) /= N_Triggering_Alternative
4626            or else N /= Triggering_Statement (Parent (N)))
4627         and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
4628                    or else N /= Entry_Call_Statement (Parent (N))
4629                    or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
4630       then
4631          Extract_Entry (N, Concval, Ename, Index);
4632          Build_Simple_Entry_Call (N, Concval, Ename, Index);
4633       end if;
4634    end Expand_N_Entry_Call_Statement;
4635
4636    --------------------------------
4637    -- Expand_N_Entry_Declaration --
4638    --------------------------------
4639
4640    --  If there are parameters, then first, each of the formals is marked
4641    --  by setting Is_Entry_Formal. Next a record type is built which is
4642    --  used to hold the parameter values. The name of this record type is
4643    --  entryP where entry is the name of the entry, with an additional
4644    --  corresponding access type called entryPA. The record type has matching
4645    --  components for each formal (the component names are the same as the
4646    --  formal names). For elementary types, the component type matches the
4647    --  formal type. For composite types, an access type is declared (with
4648    --  the name formalA) which designates the formal type, and the type of
4649    --  the component is this access type. Finally the Entry_Component of
4650    --  each formal is set to reference the corresponding record component.
4651
4652    procedure Expand_N_Entry_Declaration (N : Node_Id) is
4653       Loc        : constant Source_Ptr := Sloc (N);
4654       Entry_Ent  : constant Entity_Id  := Defining_Identifier (N);
4655       Components : List_Id;
4656       Formal     : Node_Id;
4657       Ftype      : Entity_Id;
4658       Last_Decl  : Node_Id;
4659       Component  : Entity_Id;
4660       Ctype      : Entity_Id;
4661       Decl       : Node_Id;
4662       Rec_Ent    : Entity_Id;
4663       Acc_Ent    : Entity_Id;
4664
4665    begin
4666       Formal := First_Formal (Entry_Ent);
4667       Last_Decl := N;
4668
4669       --  Most processing is done only if parameters are present
4670
4671       if Present (Formal) then
4672          Components := New_List;
4673
4674          --  Loop through formals
4675
4676          while Present (Formal) loop
4677             Set_Is_Entry_Formal (Formal);
4678             Component :=
4679               Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
4680             Set_Entry_Component (Formal, Component);
4681             Set_Entry_Formal (Component, Formal);
4682             Ftype := Etype (Formal);
4683
4684             --  Declare new access type and then append
4685
4686             Ctype :=
4687               Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4688
4689             Decl :=
4690               Make_Full_Type_Declaration (Loc,
4691                 Defining_Identifier => Ctype,
4692                 Type_Definition     =>
4693                   Make_Access_To_Object_Definition (Loc,
4694                     All_Present        => True,
4695                     Constant_Present   => Ekind (Formal) = E_In_Parameter,
4696                     Subtype_Indication => New_Reference_To (Ftype, Loc)));
4697
4698             Insert_After (Last_Decl, Decl);
4699             Last_Decl := Decl;
4700
4701             Append_To (Components,
4702               Make_Component_Declaration (Loc,
4703                 Defining_Identifier => Component,
4704                 Component_Definition =>
4705                   Make_Component_Definition (Loc,
4706                     Aliased_Present    => False,
4707                     Subtype_Indication => New_Reference_To (Ctype, Loc))));
4708
4709             Next_Formal_With_Extras (Formal);
4710          end loop;
4711
4712          --  Create the Entry_Parameter_Record declaration
4713
4714          Rec_Ent :=
4715            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4716
4717          Decl :=
4718            Make_Full_Type_Declaration (Loc,
4719              Defining_Identifier => Rec_Ent,
4720              Type_Definition     =>
4721                Make_Record_Definition (Loc,
4722                  Component_List =>
4723                    Make_Component_List (Loc,
4724                      Component_Items => Components)));
4725
4726          Insert_After (Last_Decl, Decl);
4727          Last_Decl := Decl;
4728
4729          --  Construct and link in the corresponding access type
4730
4731          Acc_Ent :=
4732            Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4733
4734          Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
4735
4736          Decl :=
4737            Make_Full_Type_Declaration (Loc,
4738              Defining_Identifier => Acc_Ent,
4739              Type_Definition     =>
4740                Make_Access_To_Object_Definition (Loc,
4741                  All_Present        => True,
4742                  Subtype_Indication => New_Reference_To (Rec_Ent, Loc)));
4743
4744          Insert_After (Last_Decl, Decl);
4745          Last_Decl := Decl;
4746       end if;
4747    end Expand_N_Entry_Declaration;
4748
4749    -----------------------------
4750    -- Expand_N_Protected_Body --
4751    -----------------------------
4752
4753    --  Protected bodies are expanded to the completion of the subprograms
4754    --  created for the corresponding protected type. These are a protected
4755    --  and unprotected version of each protected subprogram in the object,
4756    --  a function to calculate each entry barrier, and a procedure to
4757    --  execute the sequence of statements of each protected entry body.
4758    --  For example, for protected type ptype:
4759
4760    --  function entB
4761    --    (O : System.Address;
4762    --     E : Protected_Entry_Index)
4763    --     return Boolean
4764    --  is
4765    --     <discriminant renamings>
4766    --     <private object renamings>
4767    --  begin
4768    --     return <barrier expression>;
4769    --  end entB;
4770
4771    --  procedure pprocN (_object : in out poV;...) is
4772    --     <discriminant renamings>
4773    --     <private object renamings>
4774    --  begin
4775    --     <sequence of statements>
4776    --  end pprocN;
4777
4778    --  procedure pproc (_object : in out poV;...) is
4779    --     procedure _clean is
4780    --       Pn : Boolean;
4781    --     begin
4782    --       ptypeS (_object, Pn);
4783    --       Unlock (_object._object'Access);
4784    --       Abort_Undefer.all;
4785    --     end _clean;
4786
4787    --  begin
4788    --     Abort_Defer.all;
4789    --     Lock (_object._object'Access);
4790    --     pprocN (_object;...);
4791    --  at end
4792    --     _clean;
4793    --  end pproc;
4794
4795    --  function pfuncN (_object : poV;...) return Return_Type is
4796    --     <discriminant renamings>
4797    --     <private object renamings>
4798    --  begin
4799    --     <sequence of statements>
4800    --  end pfuncN;
4801
4802    --  function pfunc (_object : poV) return Return_Type is
4803    --     procedure _clean is
4804    --     begin
4805    --        Unlock (_object._object'Access);
4806    --        Abort_Undefer.all;
4807    --     end _clean;
4808
4809    --  begin
4810    --     Abort_Defer.all;
4811    --     Lock (_object._object'Access);
4812    --     return pfuncN (_object);
4813
4814    --  at end
4815    --     _clean;
4816    --  end pfunc;
4817
4818    --  procedure entE
4819    --    (O : System.Address;
4820    --     P : System.Address;
4821    --     E : Protected_Entry_Index)
4822    --  is
4823    --     <discriminant renamings>
4824    --     <private object renamings>
4825    --     type poVP is access poV;
4826    --     _Object : ptVP := ptVP!(O);
4827
4828    --  begin
4829    --     begin
4830    --        <statement sequence>
4831    --        Complete_Entry_Body (_Object._Object);
4832    --     exception
4833    --        when all others =>
4834    --           Exceptional_Complete_Entry_Body (
4835    --             _Object._Object, Get_GNAT_Exception);
4836    --     end;
4837    --  end entE;
4838
4839    --  The type poV is the record created for the protected type to hold
4840    --  the state of the protected object.
4841
4842    procedure Expand_N_Protected_Body (N : Node_Id) is
4843       Pid          : constant Entity_Id  := Corresponding_Spec (N);
4844       Has_Entries  : Boolean := False;
4845       Op_Decl      : Node_Id;
4846       Op_Body      : Node_Id;
4847       Op_Id        : Entity_Id;
4848       New_Op_Body  : Node_Id;
4849       Current_Node : Node_Id;
4850       Num_Entries  : Natural := 0;
4851
4852    begin
4853       if No_Run_Time_Mode then
4854          Error_Msg_CRT ("protected body", N);
4855          return;
4856       end if;
4857
4858       if Nkind (Parent (N)) = N_Subunit then
4859
4860          --  This is the proper body corresponding to a stub. The declarations
4861          --  must be inserted at the point of the stub, which is in the decla-
4862          --  rative part of the parent unit.
4863
4864          Current_Node := Corresponding_Stub (Parent (N));
4865
4866       else
4867          Current_Node := N;
4868       end if;
4869
4870       Op_Body := First (Declarations (N));
4871
4872       --  The protected body is replaced with the bodies of its
4873       --  protected operations, and the declarations for internal objects
4874       --  that may have been created for entry family bounds.
4875
4876       Rewrite (N, Make_Null_Statement (Sloc (N)));
4877       Analyze (N);
4878
4879       while Present (Op_Body) loop
4880          case Nkind (Op_Body) is
4881             when N_Subprogram_Declaration =>
4882                null;
4883
4884             when N_Subprogram_Body =>
4885
4886                --  Exclude functions created to analyze defaults.
4887
4888                if not Is_Eliminated (Defining_Entity (Op_Body))
4889                  and then not Is_Eliminated (Corresponding_Spec (Op_Body))
4890                then
4891                   New_Op_Body :=
4892                     Build_Unprotected_Subprogram_Body (Op_Body, Pid);
4893
4894                   Insert_After (Current_Node, New_Op_Body);
4895                   Current_Node := New_Op_Body;
4896                   Analyze (New_Op_Body);
4897
4898                   Update_Prival_Subtypes (New_Op_Body);
4899
4900                   --  Build the corresponding protected operation only if
4901                   --  this is a visible operation of the type, or if it is
4902                   --  an interrupt handler. Otherwise it is only callable
4903                   --  from within the object, and the unprotected version
4904                   --  is sufficient.
4905
4906                   if Present (Corresponding_Spec (Op_Body)) then
4907                      Op_Decl :=
4908                        Unit_Declaration_Node (Corresponding_Spec (Op_Body));
4909
4910                      if Nkind (Parent (Op_Decl)) = N_Protected_Definition
4911                        and then
4912                          (List_Containing (Op_Decl) =
4913                                   Visible_Declarations (Parent (Op_Decl))
4914                            or else
4915                             Is_Interrupt_Handler
4916                               (Corresponding_Spec (Op_Body)))
4917                      then
4918                         New_Op_Body :=
4919                            Build_Protected_Subprogram_Body (
4920                              Op_Body, Pid, Specification (New_Op_Body));
4921
4922                         Insert_After (Current_Node, New_Op_Body);
4923                         Analyze (New_Op_Body);
4924                      end if;
4925                   end if;
4926                end if;
4927
4928             when N_Entry_Body =>
4929                Op_Id := Defining_Identifier (Op_Body);
4930                Has_Entries := True;
4931                Num_Entries := Num_Entries + 1;
4932
4933                New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
4934
4935                Insert_After (Current_Node, New_Op_Body);
4936                Current_Node := New_Op_Body;
4937                Analyze (New_Op_Body);
4938
4939                Update_Prival_Subtypes (New_Op_Body);
4940
4941             when N_Implicit_Label_Declaration =>
4942                null;
4943
4944             when N_Itype_Reference =>
4945                Insert_After (Current_Node, New_Copy (Op_Body));
4946
4947             when N_Freeze_Entity =>
4948                New_Op_Body := New_Copy (Op_Body);
4949
4950                if Present (Entity (Op_Body))
4951                  and then Freeze_Node (Entity (Op_Body)) = Op_Body
4952                then
4953                   Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
4954                end if;
4955
4956                Insert_After (Current_Node, New_Op_Body);
4957                Current_Node := New_Op_Body;
4958                Analyze (New_Op_Body);
4959
4960             when N_Pragma =>
4961                New_Op_Body := New_Copy (Op_Body);
4962                Insert_After (Current_Node, New_Op_Body);
4963                Current_Node := New_Op_Body;
4964                Analyze (New_Op_Body);
4965
4966             when N_Object_Declaration =>
4967                pragma Assert (not Comes_From_Source (Op_Body));
4968                New_Op_Body := New_Copy (Op_Body);
4969                Insert_After (Current_Node, New_Op_Body);
4970                Current_Node := New_Op_Body;
4971                Analyze (New_Op_Body);
4972
4973             when others =>
4974                raise Program_Error;
4975
4976          end case;
4977
4978          Next (Op_Body);
4979       end loop;
4980
4981       --  Finally, create the body of the function that maps an entry index
4982       --  into the corresponding body index, except when there is no entry,
4983       --  or in a ravenscar-like profile (no abort, no entry queue, 1 entry)
4984
4985       if Has_Entries
4986         and then (Abort_Allowed
4987                     or else Restriction_Active (No_Entry_Queue) = False
4988                     or else Num_Entries > 1)
4989       then
4990          New_Op_Body := Build_Find_Body_Index (Pid);
4991          Insert_After (Current_Node, New_Op_Body);
4992          Analyze (New_Op_Body);
4993       end if;
4994    end Expand_N_Protected_Body;
4995
4996    -----------------------------------------
4997    -- Expand_N_Protected_Type_Declaration --
4998    -----------------------------------------
4999
5000    --  First we create a corresponding record type declaration used to
5001    --  represent values of this protected type.
5002    --  The general form of this type declaration is
5003
5004    --    type poV (discriminants) is record
5005    --      _Object       : aliased <kind>Protection
5006    --         [(<entry count> [, <handler count>])];
5007    --      [entry_family  : array (bounds) of Void;]
5008    --      <private data fields>
5009    --    end record;
5010
5011    --  The discriminants are present only if the corresponding protected
5012    --  type has discriminants, and they exactly mirror the protected type
5013    --  discriminants. The private data fields similarly mirror the
5014    --  private declarations of the protected type.
5015
5016    --  The Object field is always present. It contains RTS specific data
5017    --  used to control the protected object. It is declared as Aliased
5018    --  so that it can be passed as a pointer to the RTS. This allows the
5019    --  protected record to be referenced within RTS data structures.
5020    --  An appropriate Protection type and discriminant are generated.
5021
5022    --  The Service field is present for protected objects with entries. It
5023    --  contains sufficient information to allow the entry service procedure
5024    --  for this object to be called when the object is not known till runtime.
5025
5026    --  One entry_family component is present for each entry family in the
5027    --  task definition (see Expand_N_Task_Type_Declaration).
5028
5029    --  When a protected object is declared, an instance of the protected type
5030    --  value record is created. The elaboration of this declaration creates
5031    --  the correct bounds for the entry families, and also evaluates the
5032    --  priority expression if needed. The initialization routine for
5033    --  the protected type itself then calls Initialize_Protection with
5034    --  appropriate parameters to initialize the value of the Task_Id field.
5035    --  Install_Handlers may be also called if a pragma Attach_Handler applies.
5036
5037    --  Note: this record is passed to the subprograms created by the
5038    --  expansion of protected subprograms and entries. It is an in parameter
5039    --  to protected functions and an in out parameter to procedures and
5040    --  entry bodies. The Entity_Id for this created record type is placed
5041    --  in the Corresponding_Record_Type field of the associated protected
5042    --  type entity.
5043
5044    --  Next we create a procedure specifications for protected subprograms
5045    --  and entry bodies. For each protected subprograms two subprograms are
5046    --  created, an unprotected and a protected version. The unprotected
5047    --  version is called from within other operations of the same protected
5048    --  object.
5049
5050    --  We also build the call to register the procedure if a pragma
5051    --  Interrupt_Handler applies.
5052
5053    --  A single subprogram is created to service all entry bodies; it has an
5054    --  additional boolean out parameter indicating that the previous entry
5055    --  call made by the current task was serviced immediately, i.e. not by
5056    --  proxy. The O parameter contains a pointer to a record object of the
5057    --  type described above. An untyped interface is used here to allow this
5058    --  procedure to be called in places where the type of the object to be
5059    --  serviced is not known. This must be done, for example, when a call
5060    --  that may have been requeued is cancelled; the corresponding object
5061    --  must be serviced, but which object that is not known till runtime.
5062
5063    --  procedure ptypeS
5064    --    (O : System.Address; P : out Boolean);
5065    --  procedure pprocN (_object : in out poV);
5066    --  procedure pproc (_object : in out poV);
5067    --  function pfuncN (_object : poV);
5068    --  function pfunc (_object : poV);
5069    --  ...
5070
5071    --  Note that this must come after the record type declaration, since
5072    --  the specs refer to this type.
5073
5074    procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
5075       Loc     : constant Source_Ptr := Sloc (N);
5076       Prottyp : constant Entity_Id  := Defining_Identifier (N);
5077       Protnm  : constant Name_Id    := Chars (Prottyp);
5078
5079       Pdef : constant Node_Id    := Protected_Definition (N);
5080       --  This contains two lists; one for visible and one for private decls
5081
5082       Rec_Decl     : Node_Id;
5083       Cdecls       : List_Id;
5084       Discr_Map    : constant Elist_Id := New_Elmt_List;
5085       Priv         : Node_Id;
5086       Pent         : Entity_Id;
5087       New_Priv     : Node_Id;
5088       Comp         : Node_Id;
5089       Comp_Id      : Entity_Id;
5090       Sub          : Node_Id;
5091       Current_Node : Node_Id := N;
5092       Bdef         : Entity_Id := Empty; -- avoid uninit warning
5093       Edef         : Entity_Id := Empty; -- avoid uninit warning
5094       Entries_Aggr : Node_Id;
5095       Body_Id      : Entity_Id;
5096       Body_Arr     : Node_Id;
5097       E_Count      : Int;
5098       Object_Comp  : Node_Id;
5099
5100       procedure Register_Handler;
5101       --  for a protected operation that is an interrupt handler, add the
5102       --  freeze action that will register it as such.
5103
5104       ----------------------
5105       -- Register_Handler --
5106       ----------------------
5107
5108       procedure Register_Handler is
5109
5110          --  All semantic checks already done in Sem_Prag
5111
5112          Prot_Proc    : constant Entity_Id :=
5113                        Defining_Unit_Name
5114                          (Specification (Current_Node));
5115
5116          Proc_Address : constant Node_Id :=
5117                           Make_Attribute_Reference (Loc,
5118                           Prefix => New_Reference_To (Prot_Proc, Loc),
5119                           Attribute_Name => Name_Address);
5120
5121          RTS_Call     : constant Entity_Id :=
5122                           Make_Procedure_Call_Statement (Loc,
5123                             Name =>
5124                               New_Reference_To (
5125                                 RTE (RE_Register_Interrupt_Handler), Loc),
5126                             Parameter_Associations =>
5127                               New_List (Proc_Address));
5128       begin
5129          Append_Freeze_Action (Prot_Proc, RTS_Call);
5130       end Register_Handler;
5131
5132    --  Start of processing for Expand_N_Protected_Type_Declaration
5133
5134    begin
5135       if Present (Corresponding_Record_Type (Prottyp)) then
5136          return;
5137       else
5138          Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc);
5139          Cdecls   := Component_Items
5140                       (Component_List (Type_Definition (Rec_Decl)));
5141       end if;
5142
5143       Qualify_Entity_Names (N);
5144
5145       --  If the type has discriminants, their occurrences in the declaration
5146       --  have been replaced by the corresponding discriminals. For components
5147       --  that are constrained by discriminants, their homologues in the
5148       --  corresponding record type must refer to the discriminants of that
5149       --  record, so we must apply a new renaming to subtypes_indications:
5150
5151       --     protected discriminant => discriminal => record discriminant.
5152       --  This replacement is not applied to default expressions, for which
5153       --  the discriminal is correct.
5154
5155       if Has_Discriminants (Prottyp) then
5156          declare
5157             Disc : Entity_Id;
5158             Decl : Node_Id;
5159
5160          begin
5161             Disc := First_Discriminant (Prottyp);
5162             Decl := First (Discriminant_Specifications (Rec_Decl));
5163
5164             while Present (Disc) loop
5165                Append_Elmt (Discriminal (Disc), Discr_Map);
5166                Append_Elmt (Defining_Identifier (Decl), Discr_Map);
5167                Next_Discriminant (Disc);
5168                Next (Decl);
5169             end loop;
5170          end;
5171       end if;
5172
5173       --  Fill in the component declarations
5174
5175       --  Add components for entry families. For each entry family,
5176       --  create an anonymous type declaration with the same size, and
5177       --  analyze the type.
5178
5179       Collect_Entry_Families (Loc, Cdecls, Current_Node, Prottyp);
5180
5181       --  Prepend the _Object field with the right type to the component
5182       --  list. We need to compute the number of entries, and in some cases
5183       --  the number of Attach_Handler pragmas.
5184
5185       declare
5186          Ritem              : Node_Id;
5187          Num_Attach_Handler : Int := 0;
5188          Protection_Subtype : Node_Id;
5189          Entry_Count_Expr   : constant Node_Id :=
5190                                 Build_Entry_Count_Expression
5191                                   (Prottyp, Cdecls, Loc);
5192
5193       begin
5194          if Has_Attach_Handler (Prottyp) then
5195             Ritem := First_Rep_Item (Prottyp);
5196             while Present (Ritem) loop
5197                if Nkind (Ritem) = N_Pragma
5198                  and then Chars (Ritem) = Name_Attach_Handler
5199                then
5200                   Num_Attach_Handler := Num_Attach_Handler + 1;
5201                end if;
5202
5203                Next_Rep_Item (Ritem);
5204             end loop;
5205
5206             if Restricted_Profile then
5207                if Has_Entries (Prottyp) then
5208                   Protection_Subtype :=
5209                     New_Reference_To (RTE (RE_Protection_Entry), Loc);
5210                else
5211                   Protection_Subtype :=
5212                     New_Reference_To (RTE (RE_Protection), Loc);
5213                end if;
5214             else
5215                Protection_Subtype :=
5216                  Make_Subtype_Indication
5217                    (Sloc => Loc,
5218                     Subtype_Mark =>
5219                       New_Reference_To
5220                         (RTE (RE_Static_Interrupt_Protection), Loc),
5221                     Constraint =>
5222                       Make_Index_Or_Discriminant_Constraint (
5223                         Sloc => Loc,
5224                         Constraints => New_List (
5225                           Entry_Count_Expr,
5226                           Make_Integer_Literal (Loc, Num_Attach_Handler))));
5227             end if;
5228
5229          elsif Has_Interrupt_Handler (Prottyp) then
5230             Protection_Subtype :=
5231                Make_Subtype_Indication (
5232                  Sloc => Loc,
5233                  Subtype_Mark => New_Reference_To
5234                    (RTE (RE_Dynamic_Interrupt_Protection), Loc),
5235                  Constraint =>
5236                    Make_Index_Or_Discriminant_Constraint (
5237                      Sloc => Loc,
5238                      Constraints => New_List (Entry_Count_Expr)));
5239
5240          elsif Has_Entries (Prottyp) then
5241             if Abort_Allowed
5242               or else Restriction_Active (No_Entry_Queue) = False
5243               or else Number_Entries (Prottyp) > 1
5244             then
5245                Protection_Subtype :=
5246                   Make_Subtype_Indication (
5247                     Sloc => Loc,
5248                     Subtype_Mark =>
5249                       New_Reference_To (RTE (RE_Protection_Entries), Loc),
5250                     Constraint =>
5251                       Make_Index_Or_Discriminant_Constraint (
5252                         Sloc => Loc,
5253                         Constraints => New_List (Entry_Count_Expr)));
5254
5255             else
5256                Protection_Subtype :=
5257                  New_Reference_To (RTE (RE_Protection_Entry), Loc);
5258             end if;
5259
5260          else
5261             Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc);
5262          end if;
5263
5264          Object_Comp :=
5265            Make_Component_Declaration (Loc,
5266              Defining_Identifier =>
5267                Make_Defining_Identifier (Loc, Name_uObject),
5268              Component_Definition =>
5269                Make_Component_Definition (Loc,
5270                  Aliased_Present    => True,
5271                  Subtype_Indication => Protection_Subtype));
5272       end;
5273
5274       pragma Assert (Present (Pdef));
5275
5276       --  Add private field components
5277
5278       if Present (Private_Declarations (Pdef)) then
5279          Priv := First (Private_Declarations (Pdef));
5280
5281          while Present (Priv) loop
5282
5283             if Nkind (Priv) = N_Component_Declaration then
5284                Pent := Defining_Identifier (Priv);
5285                New_Priv :=
5286                  Make_Component_Declaration (Loc,
5287                    Defining_Identifier =>
5288                      Make_Defining_Identifier (Sloc (Pent), Chars (Pent)),
5289                    Component_Definition =>
5290                      Make_Component_Definition (Sloc (Pent),
5291                        Aliased_Present    => False,
5292                        Subtype_Indication =>
5293                          New_Copy_Tree (Subtype_Indication
5294                                          (Component_Definition (Priv)),
5295                                         Discr_Map)),
5296                    Expression => Expression (Priv));
5297
5298                Append_To (Cdecls, New_Priv);
5299
5300             elsif Nkind (Priv) = N_Subprogram_Declaration then
5301
5302                --  Make the unprotected version of the subprogram available
5303                --  for expansion of intra object calls. There is need for
5304                --  a protected version only if the subprogram is an interrupt
5305                --  handler, otherwise  this operation can only be called from
5306                --  within the body.
5307
5308                Sub :=
5309                  Make_Subprogram_Declaration (Loc,
5310                    Specification =>
5311                      Build_Protected_Sub_Specification
5312                        (Priv, Prottyp, Unprotected => True));
5313
5314                Insert_After (Current_Node, Sub);
5315                Analyze (Sub);
5316
5317                Set_Protected_Body_Subprogram
5318                  (Defining_Unit_Name (Specification (Priv)),
5319                   Defining_Unit_Name (Specification (Sub)));
5320
5321                Current_Node := Sub;
5322                if Is_Interrupt_Handler
5323                  (Defining_Unit_Name (Specification (Priv)))
5324                then
5325                   Sub :=
5326                     Make_Subprogram_Declaration (Loc,
5327                       Specification =>
5328                         Build_Protected_Sub_Specification
5329                           (Priv, Prottyp, Unprotected => False));
5330
5331                   Insert_After (Current_Node, Sub);
5332                   Analyze (Sub);
5333                   Current_Node := Sub;
5334
5335                   if not Restricted_Profile then
5336                      Register_Handler;
5337                   end if;
5338                end if;
5339             end if;
5340
5341             Next (Priv);
5342          end loop;
5343       end if;
5344
5345       --  Put the _Object component after the private component so that it
5346       --  be finalized early as required by 9.4 (20)
5347
5348       Append_To (Cdecls, Object_Comp);
5349
5350       Insert_After (Current_Node, Rec_Decl);
5351       Current_Node := Rec_Decl;
5352
5353       --  Analyze the record declaration immediately after construction,
5354       --  because the initialization procedure is needed for single object
5355       --  declarations before the next entity is analyzed (the freeze call
5356       --  that generates this initialization procedure is found below).
5357
5358       Analyze (Rec_Decl, Suppress => All_Checks);
5359
5360       --  Collect pointers to entry bodies and their barriers, to be placed
5361       --  in the Entry_Bodies_Array for the type. For each entry/family we
5362       --  add an expression to the aggregate which is the initial value of
5363       --  this array. The array is declared after all protected subprograms.
5364
5365       if Has_Entries (Prottyp) then
5366          Entries_Aggr :=
5367            Make_Aggregate (Loc, Expressions => New_List);
5368
5369       else
5370          Entries_Aggr := Empty;
5371       end if;
5372
5373       --  Build two new procedure specifications for each protected
5374       --  subprogram; one to call from outside the object and one to
5375       --  call from inside. Build a barrier function and an entry
5376       --  body action procedure specification for each protected entry.
5377       --  Initialize the entry body array. If subprogram is flagged as
5378       --  eliminated, do not generate any internal operations.
5379
5380       E_Count := 0;
5381
5382       Comp := First (Visible_Declarations (Pdef));
5383
5384       while Present (Comp) loop
5385          if Nkind (Comp) = N_Subprogram_Declaration
5386            and then not Is_Eliminated (Defining_Entity (Comp))
5387          then
5388             Sub :=
5389               Make_Subprogram_Declaration (Loc,
5390                 Specification =>
5391                   Build_Protected_Sub_Specification
5392                     (Comp, Prottyp, Unprotected => True));
5393
5394             Insert_After (Current_Node, Sub);
5395             Analyze (Sub);
5396
5397             Set_Protected_Body_Subprogram
5398               (Defining_Unit_Name (Specification (Comp)),
5399                Defining_Unit_Name (Specification (Sub)));
5400
5401             --  Make the protected version of the subprogram available
5402             --  for expansion of external calls.
5403
5404             Current_Node := Sub;
5405
5406             Sub :=
5407               Make_Subprogram_Declaration (Loc,
5408                 Specification =>
5409                   Build_Protected_Sub_Specification
5410                     (Comp, Prottyp, Unprotected => False));
5411
5412             Insert_After (Current_Node, Sub);
5413             Analyze (Sub);
5414             Current_Node := Sub;
5415
5416             --  If a pragma Interrupt_Handler applies, build and add
5417             --  a call to Register_Interrupt_Handler to the freezing actions
5418             --  of the protected version (Current_Node) of the subprogram:
5419             --    system.interrupts.register_interrupt_handler
5420             --       (prot_procP'address);
5421
5422             if not Restricted_Profile
5423               and then Is_Interrupt_Handler
5424                 (Defining_Unit_Name (Specification (Comp)))
5425             then
5426                Register_Handler;
5427             end if;
5428
5429          elsif Nkind (Comp) = N_Entry_Declaration then
5430             E_Count := E_Count + 1;
5431             Comp_Id := Defining_Identifier (Comp);
5432             Set_Privals_Chain (Comp_Id, New_Elmt_List);
5433             Edef :=
5434               Make_Defining_Identifier (Loc,
5435                 Build_Selected_Name
5436                  (Protnm,
5437                   New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
5438                   'E'));
5439             Sub :=
5440               Make_Subprogram_Declaration (Loc,
5441                 Specification =>
5442                   Build_Protected_Entry_Specification (Edef, Comp_Id, Loc));
5443
5444             Insert_After (Current_Node, Sub);
5445             Analyze (Sub);
5446
5447             Set_Protected_Body_Subprogram (
5448               Defining_Identifier (Comp),
5449               Defining_Unit_Name (Specification (Sub)));
5450
5451             Current_Node := Sub;
5452
5453             Bdef :=
5454               Make_Defining_Identifier (Loc,
5455                 Build_Selected_Name
5456                  (Protnm,
5457                   New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
5458                   'B'));
5459             Sub :=
5460               Make_Subprogram_Declaration (Loc,
5461                 Specification =>
5462                   Build_Barrier_Function_Specification (Bdef, Loc));
5463
5464             Insert_After (Current_Node, Sub);
5465             Analyze (Sub);
5466             Set_Protected_Body_Subprogram (Bdef, Bdef);
5467             Set_Barrier_Function (Comp_Id, Bdef);
5468             Set_Scope (Bdef, Scope (Comp_Id));
5469             Current_Node := Sub;
5470
5471             --  Collect pointers to the protected subprogram and the barrier
5472             --  of the current entry, for insertion into Entry_Bodies_Array.
5473
5474             Append (
5475               Make_Aggregate (Loc,
5476                 Expressions => New_List (
5477                   Make_Attribute_Reference (Loc,
5478                     Prefix => New_Reference_To (Bdef, Loc),
5479                     Attribute_Name => Name_Unrestricted_Access),
5480                   Make_Attribute_Reference (Loc,
5481                     Prefix => New_Reference_To (Edef, Loc),
5482                     Attribute_Name => Name_Unrestricted_Access))),
5483               Expressions (Entries_Aggr));
5484
5485          end if;
5486
5487          Next (Comp);
5488       end loop;
5489
5490       --  If there are some private entry declarations, expand it as if they
5491       --  were visible entries.
5492
5493       if Present (Private_Declarations (Pdef)) then
5494          Comp := First (Private_Declarations (Pdef));
5495
5496          while Present (Comp) loop
5497             if Nkind (Comp) = N_Entry_Declaration then
5498                E_Count := E_Count + 1;
5499                Comp_Id := Defining_Identifier (Comp);
5500                Set_Privals_Chain (Comp_Id, New_Elmt_List);
5501                Edef :=
5502                  Make_Defining_Identifier (Loc,
5503                   Build_Selected_Name
5504                    (Protnm,
5505                     New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
5506                     'E'));
5507
5508                Sub :=
5509                  Make_Subprogram_Declaration (Loc,
5510                    Specification =>
5511                      Build_Protected_Entry_Specification (Edef, Comp_Id, Loc));
5512
5513                Insert_After (Current_Node, Sub);
5514                Analyze (Sub);
5515
5516                Set_Protected_Body_Subprogram (
5517                  Defining_Identifier (Comp),
5518                  Defining_Unit_Name (Specification (Sub)));
5519
5520                Current_Node := Sub;
5521
5522                Bdef :=
5523                  Make_Defining_Identifier (Loc,
5524                   Build_Selected_Name
5525                    (Protnm,
5526                     New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
5527                     'B'));
5528                Sub :=
5529                  Make_Subprogram_Declaration (Loc,
5530                    Specification =>
5531                      Build_Barrier_Function_Specification (Bdef, Loc));
5532
5533                Insert_After (Current_Node, Sub);
5534                Analyze (Sub);
5535                Set_Protected_Body_Subprogram (Bdef, Bdef);
5536                Set_Barrier_Function (Comp_Id, Bdef);
5537                Set_Scope (Bdef, Scope (Comp_Id));
5538                Current_Node := Sub;
5539
5540                --  Collect pointers to the protected subprogram and the
5541                --  barrier of the current entry, for insertion into
5542                --  Entry_Bodies_Array.
5543
5544                Append (
5545                  Make_Aggregate (Loc,
5546                    Expressions => New_List (
5547                      Make_Attribute_Reference (Loc,
5548                        Prefix => New_Reference_To (Bdef, Loc),
5549                        Attribute_Name => Name_Unrestricted_Access),
5550                      Make_Attribute_Reference (Loc,
5551                        Prefix => New_Reference_To (Edef, Loc),
5552                        Attribute_Name => Name_Unrestricted_Access))),
5553                  Expressions (Entries_Aggr));
5554             end if;
5555
5556             Next (Comp);
5557          end loop;
5558       end if;
5559
5560       --  Emit declaration for Entry_Bodies_Array, now that the addresses of
5561       --  all protected subprograms have been collected.
5562
5563       if Has_Entries (Prottyp) then
5564          Body_Id := Make_Defining_Identifier (Sloc (Prottyp),
5565            New_External_Name (Chars (Prottyp), 'A'));
5566
5567          if Abort_Allowed
5568            or else Restriction_Active (No_Entry_Queue) = False
5569            or else E_Count > 1
5570          then
5571             Body_Arr := Make_Object_Declaration (Loc,
5572               Defining_Identifier => Body_Id,
5573               Aliased_Present => True,
5574               Object_Definition =>
5575                 Make_Subtype_Indication (Loc,
5576                   Subtype_Mark => New_Reference_To (
5577                     RTE (RE_Protected_Entry_Body_Array), Loc),
5578                   Constraint =>
5579                     Make_Index_Or_Discriminant_Constraint (Loc,
5580                       Constraints => New_List (
5581                          Make_Range (Loc,
5582                            Make_Integer_Literal (Loc, 1),
5583                            Make_Integer_Literal (Loc, E_Count))))),
5584               Expression => Entries_Aggr);
5585
5586          else
5587             Body_Arr := Make_Object_Declaration (Loc,
5588               Defining_Identifier => Body_Id,
5589               Aliased_Present => True,
5590               Object_Definition => New_Reference_To (RTE (RE_Entry_Body), Loc),
5591               Expression =>
5592                 Make_Aggregate (Loc,
5593                   Expressions => New_List (
5594                     Make_Attribute_Reference (Loc,
5595                       Prefix => New_Reference_To (Bdef, Loc),
5596                       Attribute_Name => Name_Unrestricted_Access),
5597                     Make_Attribute_Reference (Loc,
5598                       Prefix => New_Reference_To (Edef, Loc),
5599                       Attribute_Name => Name_Unrestricted_Access))));
5600          end if;
5601
5602          --  A pointer to this array will be placed in the corresponding
5603          --  record by its initialization procedure, so this needs to be
5604          --  analyzed here.
5605
5606          Insert_After (Current_Node, Body_Arr);
5607          Current_Node := Body_Arr;
5608          Analyze (Body_Arr);
5609
5610          Set_Entry_Bodies_Array (Prottyp, Body_Id);
5611
5612          --  Finally, build the function that maps an entry index into the
5613          --  corresponding body. A pointer to this function is placed in each
5614          --  object of the type. Except for a ravenscar-like profile (no abort,
5615          --  no entry queue, 1 entry)
5616
5617          if Abort_Allowed
5618            or else Restriction_Active (No_Entry_Queue) = False
5619            or else E_Count > 1
5620          then
5621             Sub :=
5622               Make_Subprogram_Declaration (Loc,
5623                 Specification => Build_Find_Body_Index_Spec (Prottyp));
5624             Insert_After (Current_Node, Sub);
5625             Analyze (Sub);
5626          end if;
5627       end if;
5628    end Expand_N_Protected_Type_Declaration;
5629
5630    --------------------------------
5631    -- Expand_N_Requeue_Statement --
5632    --------------------------------
5633
5634    --  A requeue statement is expanded into one of four GNARLI operations,
5635    --  depending on the source and destination (task or protected object).
5636    --  In addition, code must be generated to jump around the remainder of
5637    --  processing for the original entry and, if the destination is a
5638    --  (different) protected object, to attempt to service it.
5639    --  The following illustrates the various cases:
5640
5641    --  procedure entE
5642    --    (O : System.Address;
5643    --     P : System.Address;
5644    --     E : Protected_Entry_Index)
5645    --  is
5646    --     <discriminant renamings>
5647    --     <private object renamings>
5648    --     type poVP is access poV;
5649    --     _Object : ptVP := ptVP!(O);
5650
5651    --  begin
5652    --     begin
5653    --        <start of statement sequence for entry>
5654
5655    --        -- Requeue from one protected entry body to another protected
5656    --        -- entry.
5657
5658    --        Requeue_Protected_Entry (
5659    --          _object._object'Access,
5660    --          new._object'Access,
5661    --          E,
5662    --          Abort_Present);
5663    --        return;
5664
5665    --        <some more of the statement sequence for entry>
5666
5667    --        --  Requeue from an entry body to a task entry.
5668
5669    --        Requeue_Protected_To_Task_Entry (
5670    --          New._task_id,
5671    --          E,
5672    --          Abort_Present);
5673    --        return;
5674
5675    --        <rest of statement sequence for entry>
5676    --        Complete_Entry_Body (_Object._Object);
5677
5678    --     exception
5679    --        when all others =>
5680    --           Exceptional_Complete_Entry_Body (
5681    --             _Object._Object, Get_GNAT_Exception);
5682    --     end;
5683    --  end entE;
5684
5685    --  Requeue of a task entry call to a task entry.
5686
5687    --  Accept_Call (E, Ann);
5688    --     <start of statement sequence for accept statement>
5689    --     Requeue_Task_Entry (New._task_id, E, Abort_Present);
5690    --     goto Lnn;
5691    --     <rest of statement sequence for accept statement>
5692    --     <<Lnn>>
5693    --     Complete_Rendezvous;
5694
5695    --  exception
5696    --     when all others =>
5697    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
5698
5699    --  Requeue of a task entry call to a protected entry.
5700
5701    --  Accept_Call (E, Ann);
5702    --     <start of statement sequence for accept statement>
5703    --     Requeue_Task_To_Protected_Entry (
5704    --       new._object'Access,
5705    --       E,
5706    --       Abort_Present);
5707    --     newS (new, Pnn);
5708    --     goto Lnn;
5709    --     <rest of statement sequence for accept statement>
5710    --     <<Lnn>>
5711    --     Complete_Rendezvous;
5712
5713    --  exception
5714    --     when all others =>
5715    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
5716
5717    --  Further details on these expansions can be found in
5718    --  Expand_N_Protected_Body and Expand_N_Accept_Statement.
5719
5720    procedure Expand_N_Requeue_Statement (N : Node_Id) is
5721       Loc        : constant Source_Ptr := Sloc (N);
5722       Acc_Stat   : Node_Id;
5723       Concval    : Node_Id;
5724       Ename      : Node_Id;
5725       Index      : Node_Id;
5726       Conctyp    : Entity_Id;
5727       Oldtyp     : Entity_Id;
5728       Lab_Node   : Node_Id;
5729       Rcall      : Node_Id;
5730       Abortable  : Node_Id;
5731       Skip_Stat  : Node_Id;
5732       Self_Param : Node_Id;
5733       New_Param  : Node_Id;
5734       Params     : List_Id;
5735       RTS_Call   : Entity_Id;
5736
5737    begin
5738       Abortable :=
5739         New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc);
5740
5741       --  Set up the target object
5742
5743       Extract_Entry (N, Concval, Ename, Index);
5744       Conctyp := Etype (Concval);
5745       New_Param := Concurrent_Ref (Concval);
5746
5747       --  The target entry index and abortable flag are the same for all cases
5748
5749       Params := New_List (
5750         Entry_Index_Expression (Loc, Entity (Ename), Index, Conctyp),
5751         Abortable);
5752
5753       --  Determine proper GNARLI call and required additional parameters
5754       --  Loop to find nearest enclosing task type or protected type
5755
5756       Oldtyp := Current_Scope;
5757       loop
5758          if Is_Task_Type (Oldtyp) then
5759             if Is_Task_Type (Conctyp) then
5760                RTS_Call := RTE (RE_Requeue_Task_Entry);
5761
5762             else
5763                pragma Assert (Is_Protected_Type (Conctyp));
5764                RTS_Call := RTE (RE_Requeue_Task_To_Protected_Entry);
5765                New_Param :=
5766                  Make_Attribute_Reference (Loc,
5767                    Prefix => New_Param,
5768                    Attribute_Name => Name_Unchecked_Access);
5769             end if;
5770
5771             Prepend (New_Param, Params);
5772             exit;
5773
5774          elsif Is_Protected_Type (Oldtyp) then
5775             Self_Param :=
5776               Make_Attribute_Reference (Loc,
5777                 Prefix => Concurrent_Ref (New_Occurrence_Of (Oldtyp, Loc)),
5778                 Attribute_Name => Name_Unchecked_Access);
5779
5780             if Is_Task_Type (Conctyp) then
5781                RTS_Call := RTE (RE_Requeue_Protected_To_Task_Entry);
5782
5783             else
5784                pragma Assert (Is_Protected_Type (Conctyp));
5785                RTS_Call := RTE (RE_Requeue_Protected_Entry);
5786                New_Param :=
5787                  Make_Attribute_Reference (Loc,
5788                    Prefix => New_Param,
5789                    Attribute_Name => Name_Unchecked_Access);
5790             end if;
5791
5792             Prepend (New_Param, Params);
5793             Prepend (Self_Param, Params);
5794             exit;
5795
5796          --  If neither task type or protected type, must be in some
5797          --  inner enclosing block, so move on out
5798
5799          else
5800             Oldtyp := Scope (Oldtyp);
5801          end if;
5802       end loop;
5803
5804       --  Create the GNARLI call
5805
5806       Rcall := Make_Procedure_Call_Statement (Loc,
5807         Name =>
5808           New_Occurrence_Of (RTS_Call, Loc),
5809         Parameter_Associations => Params);
5810
5811       Rewrite (N, Rcall);
5812       Analyze (N);
5813
5814       if Is_Protected_Type (Oldtyp) then
5815
5816          --  Build the return statement to skip the rest of the entry body
5817
5818          Skip_Stat := Make_Return_Statement (Loc);
5819
5820       else
5821          --  If the requeue is within a task, find the end label of the
5822          --  enclosing accept statement.
5823
5824          Acc_Stat := Parent (N);
5825          while Nkind (Acc_Stat) /= N_Accept_Statement loop
5826             Acc_Stat := Parent (Acc_Stat);
5827          end loop;
5828
5829          --  The last statement is the second label, used for completing the
5830          --  rendezvous the usual way.
5831          --  The label we are looking for is right before it.
5832
5833          Lab_Node :=
5834            Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat))));
5835
5836          pragma Assert (Nkind (Lab_Node) = N_Label);
5837
5838          --  Build the goto statement to skip the rest of the accept
5839          --  statement.
5840
5841          Skip_Stat :=
5842            Make_Goto_Statement (Loc,
5843              Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc));
5844       end if;
5845
5846       Set_Analyzed (Skip_Stat);
5847
5848       Insert_After (N, Skip_Stat);
5849    end Expand_N_Requeue_Statement;
5850
5851    -------------------------------
5852    -- Expand_N_Selective_Accept --
5853    -------------------------------
5854
5855    procedure Expand_N_Selective_Accept (N : Node_Id) is
5856       Loc            : constant Source_Ptr := Sloc (N);
5857       Alts           : constant List_Id    := Select_Alternatives (N);
5858
5859       --  Note: in the below declarations a lot of new lists are allocated
5860       --  unconditionally which may well not end up being used. That's
5861       --  not a good idea since it wastes space gratuitously ???
5862
5863       Accept_Case    : List_Id;
5864       Accept_List    : constant List_Id := New_List;
5865
5866       Alt            : Node_Id;
5867       Alt_List       : constant List_Id := New_List;
5868       Alt_Stats      : List_Id;
5869       Ann            : Entity_Id := Empty;
5870
5871       Block          : Node_Id;
5872       Check_Guard    : Boolean := True;
5873
5874       Decls          : constant List_Id := New_List;
5875       Stats          : constant List_Id := New_List;
5876       Body_List      : constant List_Id := New_List;
5877       Trailing_List  : constant List_Id := New_List;
5878
5879       Choices        : List_Id;
5880       Else_Present   : Boolean := False;
5881       Terminate_Alt  : Node_Id := Empty;
5882       Select_Mode    : Node_Id;
5883
5884       Delay_Case     : List_Id;
5885       Delay_Count    : Integer := 0;
5886       Delay_Val      : Entity_Id;
5887       Delay_Index    : Entity_Id;
5888       Delay_Min      : Entity_Id;
5889       Delay_Num      : Int := 1;
5890       Delay_Alt_List : List_Id := New_List;
5891       Delay_List     : constant List_Id := New_List;
5892       D              : Entity_Id;
5893       M              : Entity_Id;
5894
5895       First_Delay    : Boolean := True;
5896       Guard_Open     : Entity_Id;
5897
5898       End_Lab        : Node_Id;
5899       Index          : Int := 1;
5900       Lab            : Node_Id;
5901       Num_Alts       : Int;
5902       Num_Accept     : Nat := 0;
5903       Proc           : Node_Id;
5904       Q              : Node_Id;
5905       Time_Type      : Entity_Id;
5906       X              : Node_Id;
5907       Select_Call    : Node_Id;
5908
5909       Qnam : constant Entity_Id :=
5910                Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
5911
5912       Xnam : constant Entity_Id :=
5913                Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
5914
5915       -----------------------
5916       -- Local subprograms --
5917       -----------------------
5918
5919       function Accept_Or_Raise return List_Id;
5920       --  For the rare case where delay alternatives all have guards, and
5921       --  all of them are closed, it is still possible that there were open
5922       --  accept alternatives with no callers. We must reexamine the
5923       --  Accept_List, and execute a selective wait with no else if some
5924       --  accept is open. If none, we raise program_error.
5925
5926       procedure Add_Accept (Alt : Node_Id);
5927       --  Process a single accept statement in a select alternative. Build
5928       --  procedure for body of accept, and add entry to dispatch table with
5929       --  expression for guard, in preparation for call to run time select.
5930
5931       function Make_And_Declare_Label (Num : Int) return Node_Id;
5932       --  Manufacture a label using Num as a serial number and declare it.
5933       --  The declaration is appended to Decls. The label marks the trailing
5934       --  statements of an accept or delay alternative.
5935
5936       function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
5937       --  Build call to Selective_Wait runtime routine.
5938
5939       procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
5940       --  Add code to compare value of delay with previous values, and
5941       --  generate case entry for trailing statements.
5942
5943       procedure Process_Accept_Alternative
5944         (Alt   : Node_Id;
5945          Index : Int;
5946          Proc  : Node_Id);
5947       --  Add code to call corresponding procedure, and branch to
5948       --  trailing statements, if any.
5949
5950       ---------------------
5951       -- Accept_Or_Raise --
5952       ---------------------
5953
5954       function Accept_Or_Raise return List_Id is
5955          Cond  : Node_Id;
5956          Stats : List_Id;
5957          J     : constant Entity_Id := Make_Defining_Identifier (Loc,
5958                                                   New_Internal_Name ('J'));
5959
5960       begin
5961          --  We generate the following:
5962
5963          --    for J in q'range loop
5964          --       if q(J).S /=null_task_entry then
5965          --          selective_wait (simple_mode,...);
5966          --          done := True;
5967          --          exit;
5968          --       end if;
5969          --    end loop;
5970          --
5971          --    if no rendez_vous then
5972          --       raise program_error;
5973          --    end if;
5974
5975          --    Note that the code needs to know that the selector name
5976          --    in an Accept_Alternative is named S.
5977
5978          Cond := Make_Op_Ne (Loc,
5979            Left_Opnd =>
5980              Make_Selected_Component (Loc,
5981                Prefix => Make_Indexed_Component (Loc,
5982                  Prefix => New_Reference_To (Qnam, Loc),
5983                    Expressions => New_List (New_Reference_To (J, Loc))),
5984              Selector_Name => Make_Identifier (Loc, Name_S)),
5985            Right_Opnd =>
5986              New_Reference_To (RTE (RE_Null_Task_Entry), Loc));
5987
5988          Stats := New_List (
5989            Make_Implicit_Loop_Statement (N,
5990              Identifier => Empty,
5991              Iteration_Scheme =>
5992                Make_Iteration_Scheme (Loc,
5993                  Loop_Parameter_Specification =>
5994                    Make_Loop_Parameter_Specification (Loc,
5995                      Defining_Identifier => J,
5996                      Discrete_Subtype_Definition =>
5997                        Make_Attribute_Reference (Loc,
5998                          Prefix => New_Reference_To (Qnam, Loc),
5999                          Attribute_Name => Name_Range,
6000                          Expressions => New_List (
6001                            Make_Integer_Literal (Loc, 1))))),
6002
6003              Statements => New_List (
6004                Make_Implicit_If_Statement (N,
6005                  Condition =>  Cond,
6006                  Then_Statements => New_List (
6007                    Make_Select_Call (
6008                     New_Reference_To (RTE (RE_Simple_Mode), Loc)),
6009                    Make_Exit_Statement (Loc))))));
6010
6011          Append_To (Stats,
6012            Make_Raise_Program_Error (Loc,
6013              Condition => Make_Op_Eq (Loc,
6014                Left_Opnd  => New_Reference_To (Xnam, Loc),
6015                Right_Opnd =>
6016                  New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
6017              Reason => PE_All_Guards_Closed));
6018
6019          return Stats;
6020       end Accept_Or_Raise;
6021
6022       ----------------
6023       -- Add_Accept --
6024       ----------------
6025
6026       procedure Add_Accept (Alt : Node_Id) is
6027          Acc_Stm   : constant Node_Id    := Accept_Statement (Alt);
6028          Ename     : constant Node_Id    := Entry_Direct_Name (Acc_Stm);
6029          Eent      : constant Entity_Id  := Entity (Ename);
6030          Index     : constant Node_Id    := Entry_Index (Acc_Stm);
6031          Null_Body : Node_Id;
6032          Proc_Body : Node_Id;
6033          PB_Ent    : Entity_Id;
6034          Expr      : Node_Id;
6035          Call      : Node_Id;
6036
6037       begin
6038          if No (Ann) then
6039             Ann := Node (Last_Elmt (Accept_Address (Eent)));
6040          end if;
6041
6042          if Present (Condition (Alt)) then
6043             Expr :=
6044               Make_Conditional_Expression (Loc, New_List (
6045                 Condition (Alt),
6046                 Entry_Index_Expression (Loc, Eent, Index, Scope (Eent)),
6047                 New_Reference_To (RTE (RE_Null_Task_Entry), Loc)));
6048          else
6049             Expr :=
6050               Entry_Index_Expression
6051                 (Loc, Eent, Index, Scope (Eent));
6052          end if;
6053
6054          if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
6055             Null_Body := New_Reference_To (Standard_False, Loc);
6056
6057             if Abort_Allowed then
6058                Call := Make_Procedure_Call_Statement (Loc,
6059                  Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc));
6060                Insert_Before (First (Statements (Handled_Statement_Sequence (
6061                  Accept_Statement (Alt)))), Call);
6062                Analyze (Call);
6063             end if;
6064
6065             PB_Ent :=
6066               Make_Defining_Identifier (Sloc (Ename),
6067                 New_External_Name (Chars (Ename), 'A', Num_Accept));
6068
6069             Set_Needs_Debug_Info (PB_Ent, Comes_From_Source (Alt));
6070
6071             Proc_Body :=
6072               Make_Subprogram_Body (Loc,
6073                 Specification =>
6074                   Make_Procedure_Specification (Loc,
6075                     Defining_Unit_Name => PB_Ent),
6076                Declarations => Declarations (Acc_Stm),
6077                Handled_Statement_Sequence =>
6078                  Build_Accept_Body (Accept_Statement (Alt)));
6079
6080             --  During the analysis of the body of the accept statement, any
6081             --  zero cost exception handler records were collected in the
6082             --  Accept_Handler_Records field of the N_Accept_Alternative
6083             --  node. This is where we move them to where they belong,
6084             --  namely the newly created procedure.
6085
6086             Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
6087             Append (Proc_Body, Body_List);
6088
6089          else
6090             Null_Body := New_Reference_To (Standard_True,  Loc);
6091
6092             --  if accept statement has declarations, insert above, given
6093             --  that we are not creating a body for the accept.
6094
6095             if Present (Declarations (Acc_Stm)) then
6096                Insert_Actions (N, Declarations (Acc_Stm));
6097             end if;
6098          end if;
6099
6100          Append_To (Accept_List,
6101            Make_Aggregate (Loc, Expressions => New_List (Null_Body, Expr)));
6102
6103          Num_Accept := Num_Accept + 1;
6104       end Add_Accept;
6105
6106       ----------------------------
6107       -- Make_And_Declare_Label --
6108       ----------------------------
6109
6110       function Make_And_Declare_Label (Num : Int) return Node_Id is
6111          Lab_Id : Node_Id;
6112
6113       begin
6114          Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
6115          Lab :=
6116            Make_Label (Loc, Lab_Id);
6117
6118          Append_To (Decls,
6119            Make_Implicit_Label_Declaration (Loc,
6120              Defining_Identifier  =>
6121                Make_Defining_Identifier (Loc, Chars (Lab_Id)),
6122              Label_Construct => Lab));
6123
6124          return Lab;
6125       end Make_And_Declare_Label;
6126
6127       ----------------------
6128       -- Make_Select_Call --
6129       ----------------------
6130
6131       function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
6132          Params : constant List_Id := New_List;
6133
6134       begin
6135          Append (
6136            Make_Attribute_Reference (Loc,
6137              Prefix => New_Reference_To (Qnam, Loc),
6138              Attribute_Name => Name_Unchecked_Access),
6139            Params);
6140          Append (Select_Mode, Params);
6141          Append (New_Reference_To (Ann, Loc), Params);
6142          Append (New_Reference_To (Xnam, Loc), Params);
6143
6144          return
6145            Make_Procedure_Call_Statement (Loc,
6146              Name => New_Reference_To (RTE (RE_Selective_Wait), Loc),
6147              Parameter_Associations => Params);
6148       end Make_Select_Call;
6149
6150       --------------------------------
6151       -- Process_Accept_Alternative --
6152       --------------------------------
6153
6154       procedure Process_Accept_Alternative
6155         (Alt   : Node_Id;
6156          Index : Int;
6157          Proc  : Node_Id)
6158       is
6159          Choices   : List_Id := No_List;
6160          Alt_Stats : List_Id;
6161
6162       begin
6163          Adjust_Condition (Condition (Alt));
6164          Alt_Stats := No_List;
6165
6166          if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
6167             Choices := New_List (
6168               Make_Integer_Literal (Loc, Index));
6169
6170             Alt_Stats := New_List (
6171               Make_Procedure_Call_Statement (Loc,
6172                 Name => New_Reference_To (
6173                   Defining_Unit_Name (Specification (Proc)), Loc)));
6174          end if;
6175
6176          if Statements (Alt) /= Empty_List then
6177
6178             if No (Alt_Stats) then
6179
6180                --  Accept with no body, followed by trailing statements.
6181
6182                Choices := New_List (
6183                  Make_Integer_Literal (Loc, Index));
6184
6185                Alt_Stats := New_List;
6186             end if;
6187
6188             --  After the call, if any, branch to to trailing statements.
6189             --  We create a label for each, as well as the corresponding
6190             --  label declaration.
6191
6192             Lab := Make_And_Declare_Label (Index);
6193             Append_To (Alt_Stats,
6194               Make_Goto_Statement (Loc,
6195                 Name => New_Copy (Identifier (Lab))));
6196
6197             Append (Lab, Trailing_List);
6198             Append_List (Statements (Alt), Trailing_List);
6199             Append_To (Trailing_List,
6200               Make_Goto_Statement (Loc,
6201                 Name => New_Copy (Identifier (End_Lab))));
6202          end if;
6203
6204          if Present (Alt_Stats) then
6205
6206             --  Procedure call. and/or trailing statements
6207
6208             Append_To (Alt_List,
6209               Make_Case_Statement_Alternative (Loc,
6210                 Discrete_Choices => Choices,
6211                 Statements => Alt_Stats));
6212          end if;
6213       end Process_Accept_Alternative;
6214
6215       -------------------------------
6216       -- Process_Delay_Alternative --
6217       -------------------------------
6218
6219       procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
6220          Choices   : List_Id;
6221          Cond      : Node_Id;
6222          Delay_Alt : List_Id;
6223
6224       begin
6225          --  Deal with C/Fortran boolean as delay condition
6226
6227          Adjust_Condition (Condition (Alt));
6228
6229          --  Determine the smallest specified delay.
6230          --  for each delay alternative generate:
6231
6232          --    if guard-expression then
6233          --       Delay_Val  := delay-expression;
6234          --       Guard_Open := True;
6235          --       if Delay_Val < Delay_Min then
6236          --          Delay_Min   := Delay_Val;
6237          --          Delay_Index := Index;
6238          --       end if;
6239          --    end if;
6240
6241          --  The enclosing if-statement is omitted if there is no guard.
6242
6243          if Delay_Count = 1
6244            or else First_Delay
6245          then
6246             First_Delay := False;
6247
6248             Delay_Alt := New_List (
6249               Make_Assignment_Statement (Loc,
6250                 Name => New_Reference_To (Delay_Min, Loc),
6251                 Expression => Expression (Delay_Statement (Alt))));
6252
6253             if Delay_Count > 1 then
6254                Append_To (Delay_Alt,
6255                  Make_Assignment_Statement (Loc,
6256                    Name       => New_Reference_To (Delay_Index, Loc),
6257                    Expression => Make_Integer_Literal (Loc, Index)));
6258             end if;
6259
6260          else
6261             Delay_Alt := New_List (
6262               Make_Assignment_Statement (Loc,
6263                 Name => New_Reference_To (Delay_Val, Loc),
6264                 Expression => Expression (Delay_Statement (Alt))));
6265
6266             if Time_Type = Standard_Duration then
6267                Cond :=
6268                   Make_Op_Lt (Loc,
6269                     Left_Opnd  => New_Reference_To (Delay_Val, Loc),
6270                     Right_Opnd => New_Reference_To (Delay_Min, Loc));
6271
6272             else
6273                --  The scope of the time type must define a comparison
6274                --  operator. The scope itself may not be visible, so we
6275                --  construct a node with entity information to insure that
6276                --  semantic analysis can find the proper operator.
6277
6278                Cond :=
6279                  Make_Function_Call (Loc,
6280                    Name => Make_Selected_Component (Loc,
6281                      Prefix => New_Reference_To (Scope (Time_Type), Loc),
6282                      Selector_Name =>
6283                        Make_Operator_Symbol (Loc,
6284                          Chars => Name_Op_Lt,
6285                          Strval => No_String)),
6286                     Parameter_Associations =>
6287                       New_List (
6288                         New_Reference_To (Delay_Val, Loc),
6289                         New_Reference_To (Delay_Min, Loc)));
6290
6291                Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
6292             end if;
6293
6294             Append_To (Delay_Alt,
6295               Make_Implicit_If_Statement (N,
6296                 Condition => Cond,
6297                 Then_Statements => New_List (
6298                   Make_Assignment_Statement (Loc,
6299                     Name       => New_Reference_To (Delay_Min, Loc),
6300                     Expression => New_Reference_To (Delay_Val, Loc)),
6301
6302                   Make_Assignment_Statement (Loc,
6303                     Name       => New_Reference_To (Delay_Index, Loc),
6304                     Expression => Make_Integer_Literal (Loc, Index)))));
6305          end if;
6306
6307          if Check_Guard then
6308             Append_To (Delay_Alt,
6309               Make_Assignment_Statement (Loc,
6310                 Name => New_Reference_To (Guard_Open, Loc),
6311                 Expression => New_Reference_To (Standard_True, Loc)));
6312          end if;
6313
6314          if Present (Condition (Alt)) then
6315             Delay_Alt := New_List (
6316               Make_Implicit_If_Statement (N,
6317                 Condition => Condition (Alt),
6318                 Then_Statements => Delay_Alt));
6319          end if;
6320
6321          Append_List (Delay_Alt, Delay_List);
6322
6323          --  If the delay alternative has a statement part, add a
6324          --  choice to the case statements for delays.
6325
6326          if Present (Statements (Alt)) then
6327
6328             if Delay_Count = 1 then
6329                Append_List (Statements (Alt), Delay_Alt_List);
6330
6331             else
6332                Choices := New_List (
6333                  Make_Integer_Literal (Loc, Index));
6334
6335                Append_To (Delay_Alt_List,
6336                  Make_Case_Statement_Alternative (Loc,
6337                    Discrete_Choices => Choices,
6338                    Statements => Statements (Alt)));
6339             end if;
6340
6341          elsif Delay_Count = 1 then
6342
6343             --  If the single delay has no trailing statements, add a branch
6344             --  to the exit label to the selective wait.
6345
6346             Delay_Alt_List := New_List (
6347               Make_Goto_Statement (Loc,
6348                 Name => New_Copy (Identifier (End_Lab))));
6349
6350          end if;
6351       end Process_Delay_Alternative;
6352
6353    --  Start of processing for Expand_N_Selective_Accept
6354
6355    begin
6356       --  First insert some declarations before the select. The first is:
6357
6358       --    Ann : Address
6359
6360       --  This variable holds the parameters passed to the accept body. This
6361       --  declaration has already been inserted by the time we get here by
6362       --  a call to Expand_Accept_Declarations made from the semantics when
6363       --  processing the first accept statement contained in the select. We
6364       --  can find this entity as Accept_Address (E), where E is any of the
6365       --  entries references by contained accept statements.
6366
6367       --  The first step is to scan the list of Selective_Accept_Statements
6368       --  to find this entity, and also count the number of accepts, and
6369       --  determine if terminated, delay or else is present:
6370
6371       Num_Alts := 0;
6372
6373       Alt := First (Alts);
6374       while Present (Alt) loop
6375
6376          if Nkind (Alt) = N_Accept_Alternative then
6377             Add_Accept (Alt);
6378
6379          elsif Nkind (Alt) = N_Delay_Alternative then
6380             Delay_Count   := Delay_Count + 1;
6381
6382             --  If the delays are relative delays, the delay expressions have
6383             --  type Standard_Duration. Otherwise they must have some time type
6384             --  recognized by GNAT.
6385
6386             if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
6387                Time_Type := Standard_Duration;
6388             else
6389                Time_Type := Etype (Expression (Delay_Statement (Alt)));
6390
6391                if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
6392                  or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
6393                then
6394                   null;
6395                else
6396                   Error_Msg_NE (
6397                     "& is not a time type ('R'M 9.6(6))",
6398                        Expression (Delay_Statement (Alt)), Time_Type);
6399                   Time_Type := Standard_Duration;
6400                   Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
6401                end if;
6402             end if;
6403
6404             if No (Condition (Alt)) then
6405
6406                --  This guard will always be open.
6407
6408                Check_Guard := False;
6409             end if;
6410
6411          elsif Nkind (Alt) = N_Terminate_Alternative then
6412             Adjust_Condition (Condition (Alt));
6413             Terminate_Alt := Alt;
6414          end if;
6415
6416          Num_Alts := Num_Alts + 1;
6417          Next (Alt);
6418       end loop;
6419
6420       Else_Present := Present (Else_Statements (N));
6421
6422       --  At the same time (see procedure Add_Accept) we build the accept list:
6423
6424       --    Qnn : Accept_List (1 .. num-select) := (
6425       --          (null-body, entry-index),
6426       --          (null-body, entry-index),
6427       --          ..
6428       --          (null_body, entry-index));
6429
6430       --  In the above declaration, null-body is True if the corresponding
6431       --  accept has no body, and false otherwise. The entry is either the
6432       --  entry index expression if there is no guard, or if a guard is
6433       --  present, then a conditional expression of the form:
6434
6435       --    (if guard then entry-index else Null_Task_Entry)
6436
6437       --  If a guard is statically known to be false, the entry can simply
6438       --  be omitted from the accept list.
6439
6440       Q :=
6441         Make_Object_Declaration (Loc,
6442           Defining_Identifier => Qnam,
6443           Object_Definition =>
6444             New_Reference_To (RTE (RE_Accept_List), Loc),
6445           Aliased_Present => True,
6446
6447           Expression =>
6448              Make_Qualified_Expression (Loc,
6449                Subtype_Mark =>
6450                  New_Reference_To (RTE (RE_Accept_List), Loc),
6451                Expression =>
6452                  Make_Aggregate (Loc, Expressions => Accept_List)));
6453
6454       Append (Q, Decls);
6455
6456       --  Then we declare the variable that holds the index for the accept
6457       --  that will be selected for service:
6458
6459       --    Xnn : Select_Index;
6460
6461       X :=
6462         Make_Object_Declaration (Loc,
6463           Defining_Identifier => Xnam,
6464           Object_Definition =>
6465             New_Reference_To (RTE (RE_Select_Index), Loc),
6466           Expression =>
6467             New_Reference_To (RTE (RE_No_Rendezvous), Loc));
6468
6469       Append (X, Decls);
6470
6471       --  After this follow procedure declarations for each accept body.
6472
6473       --    procedure Pnn is
6474       --    begin
6475       --       ...
6476       --    end;
6477
6478       --  where the ... are statements from the corresponding procedure body.
6479       --  No parameters are involved, since the parameters are passed via Ann
6480       --  and the parameter references have already been expanded to be direct
6481       --  references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
6482       --  any embedded tasking statements (which would normally be illegal in
6483       --  procedures, have been converted to calls to the tasking runtime so
6484       --  there is no problem in putting them into procedures.
6485
6486       --  The original accept statement has been expanded into a block in
6487       --  the same fashion as for simple accepts (see Build_Accept_Body).
6488
6489       --  Note: we don't really need to build these procedures for the case
6490       --  where no delay statement is present, but it is just as easy to
6491       --  build them unconditionally, and not significantly inefficient,
6492       --  since if they are short they will be inlined anyway.
6493
6494       --  The procedure declarations have been assembled in Body_List.
6495
6496       --  If delays are present, we must compute the required delay.
6497       --  We first generate the declarations:
6498
6499       --    Delay_Index : Boolean := 0;
6500       --    Delay_Min   : Some_Time_Type.Time;
6501       --    Delay_Val   : Some_Time_Type.Time;
6502
6503       --  Delay_Index will be set to the index of the minimum delay, i.e. the
6504       --   active delay that is actually chosen as the basis for the possible
6505       --   delay if an immediate rendez-vous is not possible.
6506       --   In the most common case there is a single delay statement, and this
6507       --   is handled specially.
6508
6509       if Delay_Count > 0 then
6510
6511          --  Generate the required declarations
6512
6513          Delay_Val :=
6514            Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
6515          Delay_Index :=
6516            Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
6517          Delay_Min :=
6518            Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
6519
6520          Append_To (Decls,
6521            Make_Object_Declaration (Loc,
6522              Defining_Identifier => Delay_Val,
6523              Object_Definition   => New_Reference_To (Time_Type, Loc)));
6524
6525          Append_To (Decls,
6526            Make_Object_Declaration (Loc,
6527              Defining_Identifier => Delay_Index,
6528              Object_Definition   => New_Reference_To (Standard_Integer, Loc),
6529              Expression          => Make_Integer_Literal (Loc, 0)));
6530
6531          Append_To (Decls,
6532            Make_Object_Declaration (Loc,
6533              Defining_Identifier => Delay_Min,
6534              Object_Definition   => New_Reference_To (Time_Type, Loc),
6535              Expression          =>
6536                Unchecked_Convert_To (Time_Type,
6537                  Make_Attribute_Reference (Loc,
6538                    Prefix =>
6539                      New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
6540                    Attribute_Name => Name_Last))));
6541
6542          --  Create Duration and Delay_Mode objects used for passing a delay
6543          --  value to RTS
6544
6545          D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
6546          M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
6547
6548          declare
6549             Discr : Entity_Id;
6550
6551          begin
6552             --  Note that these values are defined in s-osprim.ads and must
6553             --  be kept in sync:
6554             --
6555             --     Relative          : constant := 0;
6556             --     Absolute_Calendar : constant := 1;
6557             --     Absolute_RT       : constant := 2;
6558
6559             if Time_Type = Standard_Duration then
6560                Discr := Make_Integer_Literal (Loc, 0);
6561
6562             elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
6563                Discr := Make_Integer_Literal (Loc, 1);
6564
6565             else
6566                pragma Assert
6567                  (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
6568                Discr := Make_Integer_Literal (Loc, 2);
6569             end if;
6570
6571             Append_To (Decls,
6572               Make_Object_Declaration (Loc,
6573                 Defining_Identifier => D,
6574                 Object_Definition =>
6575                   New_Reference_To (Standard_Duration, Loc)));
6576
6577             Append_To (Decls,
6578               Make_Object_Declaration (Loc,
6579                 Defining_Identifier => M,
6580                 Object_Definition   =>
6581                   New_Reference_To (Standard_Integer, Loc),
6582                 Expression          => Discr));
6583          end;
6584
6585          if Check_Guard then
6586             Guard_Open :=
6587               Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
6588
6589             Append_To (Decls,
6590               Make_Object_Declaration (Loc,
6591                  Defining_Identifier => Guard_Open,
6592                  Object_Definition => New_Reference_To (Standard_Boolean, Loc),
6593                  Expression        => New_Reference_To (Standard_False, Loc)));
6594          end if;
6595
6596       --  Delay_Count is zero, don't need M and D set (suppress warning)
6597
6598       else
6599          M := Empty;
6600          D := Empty;
6601       end if;
6602
6603       if Present (Terminate_Alt) then
6604
6605          --  If the terminate alternative guard is False, use
6606          --  Simple_Mode; otherwise use Terminate_Mode.
6607
6608          if Present (Condition (Terminate_Alt)) then
6609             Select_Mode := Make_Conditional_Expression (Loc,
6610               New_List (Condition (Terminate_Alt),
6611                         New_Reference_To (RTE (RE_Terminate_Mode), Loc),
6612                         New_Reference_To (RTE (RE_Simple_Mode), Loc)));
6613          else
6614             Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc);
6615          end if;
6616
6617       elsif Else_Present or Delay_Count > 0 then
6618          Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc);
6619
6620       else
6621          Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc);
6622       end if;
6623
6624       Select_Call := Make_Select_Call (Select_Mode);
6625       Append (Select_Call, Stats);
6626
6627       --  Now generate code to act on the result. There is an entry
6628       --  in this case for each accept statement with a non-null body,
6629       --  followed by a branch to the statements that follow the Accept.
6630       --  In the absence of delay alternatives, we generate:
6631
6632       --    case X is
6633       --      when No_Rendezvous =>  --  omitted if simple mode
6634       --         goto Lab0;
6635
6636       --      when 1 =>
6637       --         P1n;
6638       --         goto Lab1;
6639
6640       --      when 2 =>
6641       --         P2n;
6642       --         goto Lab2;
6643
6644       --      when others =>
6645       --         goto Exit;
6646       --    end case;
6647       --
6648       --    Lab0: Else_Statements;
6649       --    goto exit;
6650
6651       --    Lab1:  Trailing_Statements1;
6652       --    goto Exit;
6653       --
6654       --    Lab2:  Trailing_Statements2;
6655       --    goto Exit;
6656       --    ...
6657       --    Exit:
6658
6659       --  Generate label for common exit.
6660
6661       End_Lab := Make_And_Declare_Label (Num_Alts + 1);
6662
6663       --  First entry is the default case, when no rendezvous is possible.
6664
6665       Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc));
6666
6667       if Else_Present then
6668
6669          --  If no rendezvous is possible, the else part is executed.
6670
6671          Lab := Make_And_Declare_Label (0);
6672          Alt_Stats := New_List (
6673            Make_Goto_Statement (Loc,
6674              Name => New_Copy (Identifier (Lab))));
6675
6676          Append (Lab, Trailing_List);
6677          Append_List (Else_Statements (N), Trailing_List);
6678          Append_To (Trailing_List,
6679            Make_Goto_Statement (Loc,
6680              Name => New_Copy (Identifier (End_Lab))));
6681       else
6682          Alt_Stats := New_List (
6683            Make_Goto_Statement (Loc,
6684              Name => New_Copy (Identifier (End_Lab))));
6685       end if;
6686
6687       Append_To (Alt_List,
6688         Make_Case_Statement_Alternative (Loc,
6689           Discrete_Choices => Choices,
6690           Statements => Alt_Stats));
6691
6692       --  We make use of the fact that Accept_Index is an integer type,
6693       --  and generate successive literals for entries for each accept.
6694       --  Only those for which there is a body or trailing statements are
6695       --  given a case entry.
6696
6697       Alt := First (Select_Alternatives (N));
6698       Proc := First (Body_List);
6699
6700       while Present (Alt) loop
6701
6702          if Nkind (Alt) = N_Accept_Alternative then
6703             Process_Accept_Alternative (Alt, Index, Proc);
6704             Index := Index + 1;
6705
6706             if Present
6707               (Handled_Statement_Sequence (Accept_Statement (Alt)))
6708             then
6709                Next (Proc);
6710             end if;
6711
6712          elsif Nkind (Alt) = N_Delay_Alternative then
6713             Process_Delay_Alternative (Alt, Delay_Num);
6714             Delay_Num := Delay_Num + 1;
6715          end if;
6716
6717          Next (Alt);
6718       end loop;
6719
6720       --  An others choice is always added to the main case, as well
6721       --  as the delay case (to satisfy the compiler).
6722
6723       Append_To (Alt_List,
6724         Make_Case_Statement_Alternative (Loc,
6725           Discrete_Choices =>
6726             New_List (Make_Others_Choice (Loc)),
6727           Statements       =>
6728             New_List (Make_Goto_Statement (Loc,
6729               Name => New_Copy (Identifier (End_Lab))))));
6730
6731       Accept_Case := New_List (
6732         Make_Case_Statement (Loc,
6733           Expression   => New_Reference_To (Xnam, Loc),
6734           Alternatives => Alt_List));
6735
6736       Append_List (Trailing_List, Accept_Case);
6737       Append (End_Lab, Accept_Case);
6738       Append_List (Body_List, Decls);
6739
6740       --  Construct case statement for trailing statements of delay
6741       --  alternatives, if there are several of them.
6742
6743       if Delay_Count > 1 then
6744          Append_To (Delay_Alt_List,
6745            Make_Case_Statement_Alternative (Loc,
6746              Discrete_Choices =>
6747                New_List (Make_Others_Choice (Loc)),
6748              Statements       =>
6749                New_List (Make_Null_Statement (Loc))));
6750
6751          Delay_Case := New_List (
6752            Make_Case_Statement (Loc,
6753              Expression   => New_Reference_To (Delay_Index, Loc),
6754              Alternatives => Delay_Alt_List));
6755       else
6756          Delay_Case := Delay_Alt_List;
6757       end if;
6758
6759       --  If there are no delay alternatives, we append the case statement
6760       --  to the statement list.
6761
6762       if Delay_Count = 0 then
6763          Append_List (Accept_Case, Stats);
6764
6765       --  Delay alternatives present
6766
6767       else
6768          --  If delay alternatives are present we generate:
6769
6770          --    find minimum delay.
6771          --    DX := minimum delay;
6772          --    M := <delay mode>;
6773          --    Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
6774          --      DX, MX, X);
6775          --
6776          --    if X = No_Rendezvous then
6777          --      case statement for delay statements.
6778          --    else
6779          --      case statement for accept alternatives.
6780          --    end if;
6781
6782          declare
6783             Cases : Node_Id;
6784             Stmt  : Node_Id;
6785             Parms : List_Id;
6786             Parm  : Node_Id;
6787             Conv  : Node_Id;
6788
6789          begin
6790             --  The type of the delay expression is known to be legal
6791
6792             if Time_Type = Standard_Duration then
6793                Conv := New_Reference_To (Delay_Min, Loc);
6794
6795             elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
6796                Conv := Make_Function_Call (Loc,
6797                  New_Reference_To (RTE (RO_CA_To_Duration), Loc),
6798                  New_List (New_Reference_To (Delay_Min, Loc)));
6799
6800             else
6801                pragma Assert
6802                  (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
6803
6804                Conv := Make_Function_Call (Loc,
6805                  New_Reference_To (RTE (RO_RT_To_Duration), Loc),
6806                  New_List (New_Reference_To (Delay_Min, Loc)));
6807             end if;
6808
6809             Stmt := Make_Assignment_Statement (Loc,
6810               Name => New_Reference_To (D, Loc),
6811               Expression => Conv);
6812
6813             --  Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
6814
6815             Parms := Parameter_Associations (Select_Call);
6816             Parm := First (Parms);
6817
6818             while Present (Parm)
6819               and then Parm /= Select_Mode
6820             loop
6821                Next (Parm);
6822             end loop;
6823
6824             pragma Assert (Present (Parm));
6825             Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc));
6826             Analyze (Parm);
6827
6828             --  Prepare two new parameters of Duration and Delay_Mode type
6829             --  which represent the value and the mode of the minimum delay.
6830
6831             Next (Parm);
6832             Insert_After (Parm, New_Reference_To (M, Loc));
6833             Insert_After (Parm, New_Reference_To (D, Loc));
6834
6835             --  Create a call to RTS.
6836
6837             Rewrite (Select_Call,
6838               Make_Procedure_Call_Statement (Loc,
6839                 Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc),
6840                 Parameter_Associations => Parms));
6841
6842             --  This new call should follow the calculation of the
6843             --  minimum delay.
6844
6845             Insert_List_Before (Select_Call, Delay_List);
6846
6847             if Check_Guard then
6848                Stmt :=
6849                  Make_Implicit_If_Statement (N,
6850                    Condition => New_Reference_To (Guard_Open, Loc),
6851                    Then_Statements =>
6852                      New_List (New_Copy_Tree (Stmt),
6853                        New_Copy_Tree (Select_Call)),
6854                    Else_Statements => Accept_Or_Raise);
6855                Rewrite (Select_Call, Stmt);
6856             else
6857                Insert_Before (Select_Call, Stmt);
6858             end if;
6859
6860             Cases :=
6861               Make_Implicit_If_Statement (N,
6862                 Condition => Make_Op_Eq (Loc,
6863                   Left_Opnd  => New_Reference_To (Xnam, Loc),
6864                   Right_Opnd =>
6865                     New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
6866
6867                 Then_Statements => Delay_Case,
6868                 Else_Statements => Accept_Case);
6869
6870             Append (Cases, Stats);
6871          end;
6872       end if;
6873
6874       --  Replace accept statement with appropriate block
6875
6876       Block :=
6877         Make_Block_Statement (Loc,
6878           Declarations => Decls,
6879           Handled_Statement_Sequence =>
6880             Make_Handled_Sequence_Of_Statements (Loc,
6881               Statements => Stats));
6882
6883       Rewrite (N, Block);
6884       Analyze (N);
6885
6886       --  Note: have to worry more about abort deferral in above code ???
6887
6888       --  Final step is to unstack the Accept_Address entries for all accept
6889       --  statements appearing in accept alternatives in the select statement
6890
6891       Alt := First (Alts);
6892       while Present (Alt) loop
6893          if Nkind (Alt) = N_Accept_Alternative then
6894             Remove_Last_Elmt (Accept_Address
6895               (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
6896          end if;
6897
6898          Next (Alt);
6899       end loop;
6900    end Expand_N_Selective_Accept;
6901
6902    --------------------------------------
6903    -- Expand_N_Single_Task_Declaration --
6904    --------------------------------------
6905
6906    --  Single task declarations should never be present after semantic
6907    --  analysis, since we expect them to be replaced by a declaration of
6908    --  an anonymous task type, followed by a declaration of the task
6909    --  object. We include this routine to make sure that is happening!
6910
6911    procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
6912    begin
6913       raise Program_Error;
6914    end Expand_N_Single_Task_Declaration;
6915
6916    ------------------------
6917    -- Expand_N_Task_Body --
6918    ------------------------
6919
6920    --  Given a task body
6921
6922    --    task body tname is
6923    --       <declarations>
6924    --    begin
6925    --       <statements>
6926    --    end x;
6927
6928    --  This expansion routine converts it into a procedure and sets the
6929    --  elaboration flag for the procedure to true, to represent the fact
6930    --  that the task body is now elaborated:
6931
6932    --    procedure tnameB (_Task : access tnameV) is
6933    --       discriminal : dtype renames _Task.discriminant;
6934
6935    --       procedure _clean is
6936    --       begin
6937    --          Abort_Defer.all;
6938    --          Complete_Task;
6939    --          Abort_Undefer.all;
6940    --          return;
6941    --       end _clean;
6942
6943    --    begin
6944    --       Abort_Undefer.all;
6945    --       <declarations>
6946    --       System.Task_Stages.Complete_Activation;
6947    --       <statements>
6948    --    at end
6949    --       _clean;
6950    --    end tnameB;
6951
6952    --    tnameE := True;
6953
6954    --  In addition, if the task body is an activator, then a call to
6955    --  activate tasks is added at the start of the statements, before
6956    --  the call to Complete_Activation, and if in addition the task is
6957    --  a master then it must be established as a master. These calls are
6958    --  inserted and analyzed in Expand_Cleanup_Actions, when the
6959    --  Handled_Sequence_Of_Statements is expanded.
6960
6961    --  There is one discriminal declaration line generated for each
6962    --  discriminant that is present to provide an easy reference point
6963    --  for discriminant references inside the body (see Exp_Ch2.Expand_Name).
6964
6965    --  Note on relationship to GNARLI definition. In the GNARLI definition,
6966    --  task body procedures have a profile (Arg : System.Address). That is
6967    --  needed because GNARLI has to use the same access-to-subprogram type
6968    --  for all task types. We depend here on knowing that in GNAT, passing
6969    --  an address argument by value is identical to passing a record value
6970    --  by access (in either case a single pointer is passed), so even though
6971    --  this procedure has the wrong profile. In fact it's all OK, since the
6972    --  callings sequence is identical.
6973
6974    procedure Expand_N_Task_Body (N : Node_Id) is
6975       Loc   : constant Source_Ptr := Sloc (N);
6976       Ttyp  : constant Entity_Id  := Corresponding_Spec (N);
6977       Call  : Node_Id;
6978       New_N : Node_Id;
6979
6980    begin
6981       --  Here we start the expansion by generating discriminal declarations
6982
6983       Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc);
6984
6985       --  Add a call to Abort_Undefer at the very beginning of the task
6986       --  body since this body is called with abort still deferred.
6987
6988       if Abort_Allowed then
6989          Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
6990          Insert_Before
6991            (First (Statements (Handled_Statement_Sequence (N))), Call);
6992          Analyze (Call);
6993       end if;
6994
6995       --  The statement part has already been protected with an at_end and
6996       --  cleanup actions. The call to Complete_Activation must be placed
6997       --  at the head of the sequence of statements of that block. The
6998       --  declarations have been merged in this sequence of statements but
6999       --  the first real statement is accessible from the First_Real_Statement
7000       --  field (which was set for exactly this purpose).
7001
7002       if Restricted_Profile then
7003          Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
7004       else
7005          Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
7006       end if;
7007
7008       Insert_Before
7009         (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
7010       Analyze (Call);
7011
7012       New_N :=
7013         Make_Subprogram_Body (Loc,
7014           Specification => Build_Task_Proc_Specification (Ttyp),
7015           Declarations  => Declarations (N),
7016           Handled_Statement_Sequence => Handled_Statement_Sequence (N));
7017
7018       --  If the task contains generic instantiations, cleanup actions
7019       --  are delayed until after instantiation. Transfer the activation
7020       --  chain to the subprogram, to insure that the activation call is
7021       --  properly generated. It the task body contains inner tasks, indicate
7022       --  that the subprogram is a task master.
7023
7024       if Delay_Cleanups (Ttyp) then
7025          Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
7026          Set_Is_Task_Master  (New_N, Is_Task_Master (N));
7027       end if;
7028
7029       Rewrite (N, New_N);
7030       Analyze (N);
7031
7032       --  Set elaboration flag immediately after task body. If the body
7033       --  is a subunit, the flag is set in  the declarative part that
7034       --  contains the stub.
7035
7036       if Nkind (Parent (N)) /= N_Subunit then
7037          Insert_After (N,
7038            Make_Assignment_Statement (Loc,
7039              Name =>
7040                Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
7041              Expression => New_Reference_To (Standard_True, Loc)));
7042       end if;
7043    end Expand_N_Task_Body;
7044
7045    ------------------------------------
7046    -- Expand_N_Task_Type_Declaration --
7047    ------------------------------------
7048
7049    --  We have several things to do. First we must create a Boolean flag used
7050    --  to mark if the body is elaborated yet. This variable gets set to True
7051    --  when the body of the task is elaborated (we can't rely on the normal
7052    --  ABE mechanism for the task body, since we need to pass an access to
7053    --  this elaboration boolean to the runtime routines).
7054
7055    --    taskE : aliased Boolean := False;
7056
7057    --  Next a variable is declared to hold the task stack size (either
7058    --  the default : Unspecified_Size, or a value that is set by a pragma
7059    --  Storage_Size). If the value of the pragma Storage_Size is static, then
7060    --  the variable is initialized with this value:
7061
7062    --    taskZ : Size_Type := Unspecified_Size;
7063    --  or
7064    --    taskZ : Size_Type := Size_Type (size_expression);
7065
7066    --  Next we create a corresponding record type declaration used to represent
7067    --  values of this task. The general form of this type declaration is
7068
7069    --    type taskV (discriminants) is record
7070    --      _Task_Id     : Task_Id;
7071    --      entry_family : array (bounds) of Void;
7072    --      _Priority    : Integer         := priority_expression;
7073    --      _Size        : Size_Type       := Size_Type (size_expression);
7074    --      _Task_Info   : Task_Info_Type  := task_info_expression;
7075    --    end record;
7076
7077    --  The discriminants are present only if the corresponding task type has
7078    --  discriminants, and they exactly mirror the task type discriminants.
7079
7080    --  The Id field is always present. It contains the Task_Id value, as
7081    --  set by the call to Create_Task. Note that although the task is
7082    --  limited, the task value record type is not limited, so there is no
7083    --  problem in passing this field as an out parameter to Create_Task.
7084
7085    --  One entry_family component is present for each entry family in the
7086    --  task definition. The bounds correspond to the bounds of the entry
7087    --  family (which may depend on discriminants). The element type is
7088    --  void, since we only need the bounds information for determining
7089    --  the entry index. Note that the use of an anonymous array would
7090    --  normally be illegal in this context, but this is a parser check,
7091    --  and the semantics is quite prepared to handle such a case.
7092
7093    --  The _Size field is present only if a Storage_Size pragma appears in
7094    --  the task definition. The expression captures the argument that was
7095    --  present in the pragma, and is used to override the task stack size
7096    --  otherwise associated with the task type.
7097
7098    --  The _Priority field is present only if a Priority or Interrupt_Priority
7099    --  pragma appears in the task definition. The expression captures the
7100    --  argument that was present in the pragma, and is used to provide
7101    --  the Size parameter to the call to Create_Task.
7102
7103    --  The _Task_Info field is present only if a Task_Info pragma appears in
7104    --  the task definition. The expression captures the argument that was
7105    --  present in the pragma, and is used to provide the Task_Image parameter
7106    --  to the call to Create_Task.
7107
7108    --  When a task is declared, an instance of the task value record is
7109    --  created. The elaboration of this declaration creates the correct
7110    --  bounds for the entry families, and also evaluates the size, priority,
7111    --  and task_Info expressions if needed. The initialization routine for
7112    --  the task type itself then calls Create_Task with appropriate
7113    --  parameters to initialize the value of the Task_Id field.
7114
7115    --  Note: the address of this record is passed as the "Discriminants"
7116    --  parameter for Create_Task. Since Create_Task merely passes this onto
7117    --  the body procedure, it does not matter that it does not quite match
7118    --  the GNARLI model of what is being passed (the record contains more
7119    --  than just the discriminants, but the discriminants can be found from
7120    --  the record value).
7121
7122    --  The Entity_Id for this created record type is placed in the
7123    --  Corresponding_Record_Type field of the associated task type entity.
7124
7125    --  Next we create a procedure specification for the task body procedure:
7126
7127    --    procedure taskB (_Task : access taskV);
7128
7129    --  Note that this must come after the record type declaration, since
7130    --  the spec refers to this type. It turns out that the initialization
7131    --  procedure for the value type references the task body spec, but that's
7132    --  fine, since it won't be generated till the freeze point for the type,
7133    --  which is certainly after the task body spec declaration.
7134
7135    --  Finally, we set the task index value field of the entry attribute in
7136    --  the case of a simple entry.
7137
7138    procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
7139       Loc       : constant Source_Ptr := Sloc (N);
7140       Tasktyp   : constant Entity_Id  := Etype (Defining_Identifier (N));
7141       Tasknm    : constant Name_Id    := Chars (Tasktyp);
7142       Taskdef   : constant Node_Id    := Task_Definition (N);
7143
7144       Proc_Spec : Node_Id;
7145       Rec_Decl  : Node_Id;
7146       Rec_Ent   : Entity_Id;
7147       Cdecls    : List_Id;
7148       Elab_Decl : Node_Id;
7149       Size_Decl : Node_Id;
7150       Body_Decl : Node_Id;
7151
7152    begin
7153       --  If already expanded, nothing to do
7154
7155       if Present (Corresponding_Record_Type (Tasktyp)) then
7156          return;
7157       end if;
7158
7159       --  Here we will do the expansion
7160
7161       Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
7162       Rec_Ent  := Defining_Identifier (Rec_Decl);
7163       Cdecls   := Component_Items (Component_List
7164                                      (Type_Definition (Rec_Decl)));
7165
7166       Qualify_Entity_Names (N);
7167
7168       --  First create the elaboration variable
7169
7170       Elab_Decl :=
7171         Make_Object_Declaration (Loc,
7172           Defining_Identifier =>
7173             Make_Defining_Identifier (Sloc (Tasktyp),
7174               Chars => New_External_Name (Tasknm, 'E')),
7175           Aliased_Present      => True,
7176           Object_Definition    => New_Reference_To (Standard_Boolean, Loc),
7177           Expression           => New_Reference_To (Standard_False, Loc));
7178       Insert_After (N, Elab_Decl);
7179
7180       --  Next create the declaration of the size variable (tasknmZ)
7181
7182       Set_Storage_Size_Variable (Tasktyp,
7183         Make_Defining_Identifier (Sloc (Tasktyp),
7184           Chars => New_External_Name (Tasknm, 'Z')));
7185
7186       if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then
7187         Is_Static_Expression (Expression (First (
7188           Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma (
7189             Taskdef, Name_Storage_Size)))))
7190       then
7191          Size_Decl :=
7192            Make_Object_Declaration (Loc,
7193              Defining_Identifier => Storage_Size_Variable (Tasktyp),
7194              Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
7195              Expression =>
7196                Convert_To (RTE (RE_Size_Type),
7197                  Relocate_Node (
7198                    Expression (First (
7199                      Pragma_Argument_Associations (
7200                        Find_Task_Or_Protected_Pragma
7201                          (Taskdef, Name_Storage_Size)))))));
7202
7203       else
7204          Size_Decl :=
7205            Make_Object_Declaration (Loc,
7206              Defining_Identifier => Storage_Size_Variable (Tasktyp),
7207              Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
7208              Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc));
7209       end if;
7210
7211       Insert_After (Elab_Decl, Size_Decl);
7212
7213       --  Next build the rest of the corresponding record declaration.
7214       --  This is done last, since the corresponding record initialization
7215       --  procedure will reference the previously created entities.
7216
7217       --  Fill in the component declarations. First the _Task_Id field.
7218
7219       Append_To (Cdecls,
7220         Make_Component_Declaration (Loc,
7221           Defining_Identifier =>
7222             Make_Defining_Identifier (Loc, Name_uTask_Id),
7223           Component_Definition =>
7224             Make_Component_Definition (Loc,
7225               Aliased_Present    => False,
7226               Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id),
7227                                     Loc))));
7228
7229       --  Add components for entry families
7230
7231       Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
7232
7233       --  Add the _Priority component if a Priority pragma is present
7234
7235       if Present (Taskdef) and then Has_Priority_Pragma (Taskdef) then
7236          declare
7237             Prag : constant Node_Id :=
7238                      Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
7239             Expr : Node_Id;
7240
7241          begin
7242             Expr := First (Pragma_Argument_Associations (Prag));
7243
7244             if Nkind (Expr) = N_Pragma_Argument_Association then
7245                Expr := Expression (Expr);
7246             end if;
7247
7248             Expr := New_Copy_Tree (Expr);
7249
7250             --  Add conversion to proper type to do range check if required
7251             --  Note that for runtime units, we allow out of range interrupt
7252             --  priority values to be used in a priority pragma. This is for
7253             --  the benefit of some versions of System.Interrupts which use
7254             --  a special server task with maximum interrupt priority.
7255
7256             if Chars (Prag) = Name_Priority
7257               and then not GNAT_Mode
7258             then
7259                Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
7260             else
7261                Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
7262             end if;
7263
7264             Append_To (Cdecls,
7265               Make_Component_Declaration (Loc,
7266                 Defining_Identifier =>
7267                   Make_Defining_Identifier (Loc, Name_uPriority),
7268                 Component_Definition =>
7269                   Make_Component_Definition (Loc,
7270                     Aliased_Present    => False,
7271                     Subtype_Indication => New_Reference_To (Standard_Integer,
7272                                                             Loc)),
7273                 Expression => Expr));
7274          end;
7275       end if;
7276
7277       --  Add the _Task_Size component if a Storage_Size pragma is present
7278
7279       if Present (Taskdef)
7280         and then Has_Storage_Size_Pragma (Taskdef)
7281       then
7282          Append_To (Cdecls,
7283            Make_Component_Declaration (Loc,
7284              Defining_Identifier =>
7285                Make_Defining_Identifier (Loc, Name_uSize),
7286
7287              Component_Definition =>
7288                Make_Component_Definition (Loc,
7289                  Aliased_Present    => False,
7290                  Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
7291                                                          Loc)),
7292
7293              Expression =>
7294                Convert_To (RTE (RE_Size_Type),
7295                  Relocate_Node (
7296                    Expression (First (
7297                      Pragma_Argument_Associations (
7298                        Find_Task_Or_Protected_Pragma
7299                          (Taskdef, Name_Storage_Size))))))));
7300       end if;
7301
7302       --  Add the _Task_Info component if a Task_Info pragma is present
7303
7304       if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then
7305          Append_To (Cdecls,
7306            Make_Component_Declaration (Loc,
7307              Defining_Identifier =>
7308                Make_Defining_Identifier (Loc, Name_uTask_Info),
7309
7310              Component_Definition =>
7311                Make_Component_Definition (Loc,
7312                  Aliased_Present    => False,
7313                  Subtype_Indication =>
7314                    New_Reference_To (RTE (RE_Task_Info_Type), Loc)),
7315
7316              Expression => New_Copy (
7317                Expression (First (
7318                  Pragma_Argument_Associations (
7319                    Find_Task_Or_Protected_Pragma
7320                      (Taskdef, Name_Task_Info)))))));
7321       end if;
7322
7323       Insert_After (Size_Decl, Rec_Decl);
7324
7325       --  Analyze the record declaration immediately after construction,
7326       --  because the initialization procedure is needed for single task
7327       --  declarations before the next entity is analyzed.
7328
7329       Analyze (Rec_Decl);
7330
7331       --  Create the declaration of the task body procedure
7332
7333       Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
7334       Body_Decl :=
7335         Make_Subprogram_Declaration (Loc,
7336           Specification => Proc_Spec);
7337
7338       Insert_After (Rec_Decl, Body_Decl);
7339
7340       --  The subprogram does not comes from source, so we have to indicate
7341       --  the need for debugging information explicitly.
7342
7343       Set_Needs_Debug_Info
7344         (Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N)));
7345
7346       --  Now we can freeze the corresponding record. This needs manually
7347       --  freezing, since it is really part of the task type, and the task
7348       --  type is frozen at this stage. We of course need the initialization
7349       --  procedure for this corresponding record type and we won't get it
7350       --  in time if we don't freeze now.
7351
7352       declare
7353          L : constant List_Id := Freeze_Entity (Rec_Ent, Loc);
7354
7355       begin
7356          if Is_Non_Empty_List (L) then
7357             Insert_List_After (Body_Decl, L);
7358          end if;
7359       end;
7360
7361       --  Complete the expansion of access types to the current task
7362       --  type, if any were declared.
7363
7364       Expand_Previous_Access_Type (Tasktyp);
7365    end Expand_N_Task_Type_Declaration;
7366
7367    -------------------------------
7368    -- Expand_N_Timed_Entry_Call --
7369    -------------------------------
7370
7371    --  A timed entry call in normal case is not implemented using ATC
7372    --  mechanism anymore for efficiency reason.
7373
7374    --     select
7375    --        T.E;
7376    --        S1;
7377    --     or
7378    --        Delay D;
7379    --        S2;
7380    --     end select;
7381
7382    --  is expanded as follow:
7383
7384    --  1) When T.E is a task entry_call;
7385
7386    --    declare
7387    --       B : Boolean;
7388    --       X : Task_Entry_Index := <entry index>;
7389    --       DX : Duration := To_Duration (D);
7390    --       M : Delay_Mode := <discriminant>;
7391    --       P : parms := (parm, parm, parm);
7392
7393    --    begin
7394    --       Timed_Protected_Entry_Call (<acceptor-task>, X, P'Address,
7395    --         DX, M, B);
7396    --       if B then
7397    --          S1;
7398    --       else
7399    --          S2;
7400    --       end if;
7401    --    end;
7402
7403    --  2) When T.E is a protected entry_call;
7404
7405    --    declare
7406    --       B  : Boolean;
7407    --       X  : Protected_Entry_Index := <entry index>;
7408    --       DX : Duration := To_Duration (D);
7409    --       M : Delay_Mode := <discriminant>;
7410    --       P  : parms := (parm, parm, parm);
7411
7412    --    begin
7413    --       Timed_Protected_Entry_Call (<object>'unchecked_access, X,
7414    --         P'Address, DX, M, B);
7415    --       if B then
7416    --          S1;
7417    --       else
7418    --          S2;
7419    --       end if;
7420    --    end;
7421
7422    procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
7423       Loc : constant Source_Ptr := Sloc (N);
7424
7425       E_Call  : Node_Id :=
7426                   Entry_Call_Statement (Entry_Call_Alternative (N));
7427       E_Stats : constant List_Id :=
7428                   Statements (Entry_Call_Alternative (N));
7429       D_Stat  : constant Node_Id :=
7430                   Delay_Statement (Delay_Alternative (N));
7431       D_Stats : constant List_Id :=
7432                   Statements (Delay_Alternative (N));
7433
7434       Stmts : List_Id;
7435       Stmt  : Node_Id;
7436       Parms : List_Id;
7437       Parm  : Node_Id;
7438
7439       Concval : Node_Id;
7440       Ename   : Node_Id;
7441       Index   : Node_Id;
7442
7443       Decls : List_Id;
7444       Disc  : Node_Id;
7445       Conv  : Node_Id;
7446       B     : Entity_Id;
7447       D     : Entity_Id;
7448       Dtyp  : Entity_Id;
7449       M     : Entity_Id;
7450
7451       Call  : Node_Id;
7452       Dummy : Node_Id;
7453
7454    begin
7455       --  The arguments in the call may require dynamic allocation, and the
7456       --  call statement may have been transformed into a block. The block
7457       --  may contain additional declarations for internal entities, and the
7458       --  original call is found by sequential search.
7459
7460       if Nkind (E_Call) = N_Block_Statement then
7461          E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
7462
7463          while Nkind (E_Call) /= N_Procedure_Call_Statement
7464            and then Nkind (E_Call) /= N_Entry_Call_Statement
7465          loop
7466             Next (E_Call);
7467          end loop;
7468       end if;
7469
7470       --  Build an entry call using Simple_Entry_Call. We will use this as the
7471       --  base for creating appropriate calls.
7472
7473       Extract_Entry (E_Call, Concval, Ename, Index);
7474       Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
7475
7476       Stmts := Statements (Handled_Statement_Sequence (E_Call));
7477       Decls := Declarations (E_Call);
7478
7479       if No (Decls) then
7480          Decls := New_List;
7481       end if;
7482
7483       Dtyp := Base_Type (Etype (Expression (D_Stat)));
7484
7485       --  Use the type of the delay expression (Calendar or Real_Time)
7486       --  to generate the appropriate conversion.
7487
7488       if Nkind (D_Stat) = N_Delay_Relative_Statement then
7489          Disc := Make_Integer_Literal (Loc, 0);
7490          Conv := Relocate_Node (Expression (D_Stat));
7491
7492       elsif Is_RTE (Dtyp, RO_CA_Time) then
7493          Disc := Make_Integer_Literal (Loc, 1);
7494          Conv := Make_Function_Call (Loc,
7495            New_Reference_To (RTE (RO_CA_To_Duration), Loc),
7496            New_List (New_Copy (Expression (D_Stat))));
7497
7498       else pragma Assert (Is_RTE (Dtyp, RO_RT_Time));
7499          Disc := Make_Integer_Literal (Loc, 2);
7500          Conv := Make_Function_Call (Loc,
7501            New_Reference_To (RTE (RO_RT_To_Duration), Loc),
7502            New_List (New_Copy (Expression (D_Stat))));
7503       end if;
7504
7505       --  Create Duration and Delay_Mode objects for passing a delay value
7506
7507       D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
7508       M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
7509
7510       Append_To (Decls,
7511         Make_Object_Declaration (Loc,
7512           Defining_Identifier => D,
7513           Object_Definition => New_Reference_To (Standard_Duration, Loc)));
7514
7515       Append_To (Decls,
7516         Make_Object_Declaration (Loc,
7517           Defining_Identifier => M,
7518           Object_Definition => New_Reference_To (Standard_Integer, Loc),
7519           Expression        => Disc));
7520
7521       B := Make_Defining_Identifier (Loc, Name_uB);
7522
7523       --  Create a boolean object used for a return parameter.
7524
7525       Prepend_To (Decls,
7526         Make_Object_Declaration (Loc,
7527           Defining_Identifier => B,
7528           Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
7529
7530       Stmt := First (Stmts);
7531
7532       --  Skip assignments to temporaries created for in-out parameters.
7533       --  This makes unwarranted assumptions about the shape of the expanded
7534       --  tree for the call, and should be cleaned up ???
7535
7536       while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7537          Next (Stmt);
7538       end loop;
7539
7540       --  Do the assignement at this stage only because the evaluation of the
7541       --  expression must not occur before (see ACVC C97302A).
7542
7543       Insert_Before (Stmt,
7544         Make_Assignment_Statement (Loc,
7545           Name => New_Reference_To (D, Loc),
7546           Expression => Conv));
7547
7548       Call := Stmt;
7549
7550       Parms := Parameter_Associations (Call);
7551
7552       --  For a protected type, we build a Timed_Protected_Entry_Call
7553
7554       if Is_Protected_Type (Etype (Concval)) then
7555
7556          --  Create a new call statement
7557
7558          Parm := First (Parms);
7559
7560          while Present (Parm)
7561            and then not Is_RTE (Etype (Parm), RE_Call_Modes)
7562          loop
7563             Next (Parm);
7564          end loop;
7565
7566          Dummy := Remove_Next (Next (Parm));
7567
7568          --  In case some garbage is following the Cancel_Param, remove.
7569
7570          Dummy := Next (Parm);
7571
7572          --  Remove the mode of the Protected_Entry_Call call, the
7573          --  Communication_Block of the Protected_Entry_Call call, and add a
7574          --  Duration and a Delay_Mode parameter
7575
7576          pragma Assert (Present (Parm));
7577          Rewrite (Parm, New_Reference_To (D, Loc));
7578
7579          Rewrite (Dummy, New_Reference_To (M, Loc));
7580
7581          --  Add a Boolean flag for successful entry call.
7582
7583          Append_To (Parms, New_Reference_To (B, Loc));
7584
7585          if Abort_Allowed
7586            or else Restriction_Active (No_Entry_Queue) = False
7587            or else Number_Entries (Etype (Concval)) > 1
7588          then
7589             Rewrite (Call,
7590               Make_Procedure_Call_Statement (Loc,
7591                 Name =>
7592                   New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
7593                 Parameter_Associations => Parms));
7594
7595          else
7596             Parm := First (Parms);
7597
7598             while Present (Parm)
7599               and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index)
7600             loop
7601                Next (Parm);
7602             end loop;
7603
7604             Remove (Parm);
7605
7606             Rewrite (Call,
7607               Make_Procedure_Call_Statement (Loc,
7608                 Name => New_Reference_To (
7609                   RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
7610                 Parameter_Associations => Parms));
7611          end if;
7612
7613       --  For the task case, build a Timed_Task_Entry_Call
7614
7615       else
7616          --  Create a new call statement
7617
7618          Append_To (Parms, New_Reference_To (D, Loc));
7619          Append_To (Parms, New_Reference_To (M, Loc));
7620          Append_To (Parms, New_Reference_To (B, Loc));
7621
7622          Rewrite (Call,
7623            Make_Procedure_Call_Statement (Loc,
7624              Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
7625              Parameter_Associations => Parms));
7626
7627       end if;
7628
7629       Append_To (Stmts,
7630         Make_Implicit_If_Statement (N,
7631           Condition => New_Reference_To (B, Loc),
7632           Then_Statements => E_Stats,
7633           Else_Statements => D_Stats));
7634
7635       Rewrite (N,
7636         Make_Block_Statement (Loc,
7637           Declarations => Decls,
7638           Handled_Statement_Sequence =>
7639             Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7640
7641       Analyze (N);
7642    end Expand_N_Timed_Entry_Call;
7643
7644    ----------------------------------------
7645    -- Expand_Protected_Body_Declarations --
7646    ----------------------------------------
7647
7648    --  Part of the expansion of a protected body involves the creation of
7649    --  a declaration that can be referenced from the statement sequences of
7650    --  the entry bodies:
7651
7652    --    A : Address;
7653
7654    --  This declaration is inserted in the declarations of the service
7655    --  entries procedure for the protected body, and it is important that
7656    --  it be inserted before the statements of the entry body statement
7657    --  sequences are analyzed. Thus it would be too late to create this
7658    --  declaration in the Expand_N_Protected_Body routine, which is why
7659    --  there is a separate procedure to be called directly from Sem_Ch9.
7660
7661    --  Ann is used to hold the address of the record containing the parameters
7662    --  (see Expand_N_Entry_Call for more details on how this record is built).
7663    --  References to the parameters do an unchecked conversion of this address
7664    --  to a pointer to the required record type, and then access the field that
7665    --  holds the value of the required parameter. The entity for the address
7666    --  variable is held as the top stack element (i.e. the last element) of the
7667    --  Accept_Address stack in the corresponding entry entity, and this element
7668    --  must be set in place  before the statements are processed.
7669
7670    --  No stack is needed for entry bodies, since they cannot be nested, but
7671    --  it is kept for consistency between protected and task entries. The
7672    --  stack will never contain more than one element. There is also only one
7673    --  such variable for a given protected body, but this is placed on the
7674    --  Accept_Address stack of all of the entries, again for consistency.
7675
7676    --  To expand the requeue statement, a label is provided at the end of
7677    --  the loop in the entry service routine created by the expander (see
7678    --  Expand_N_Protected_Body for details), so that the statement can be
7679    --  skipped after the requeue is complete. This label is created during the
7680    --  expansion of the entry body, which will take place after the expansion
7681    --  of the requeue statements that it contains, so a placeholder defining
7682    --  identifier is associated with the task type here.
7683
7684    --  Another label is provided following case statement created by the
7685    --  expander. This label is need for implementing return statement from
7686    --  entry body so that a return can be expanded as a goto to this label.
7687    --  This label is created during the expansion of the entry body, which
7688    --  will take place after the expansion of the return statements that it
7689    --  contains. Therefore, just like the label for expanding requeues, we
7690    --  need another placeholder for the label.
7691
7692    procedure Expand_Protected_Body_Declarations
7693      (N       : Node_Id;
7694       Spec_Id : Entity_Id)
7695    is
7696       Op : Node_Id;
7697
7698    begin
7699       if No_Run_Time_Mode then
7700          Error_Msg_CRT ("protected body", N);
7701          return;
7702
7703       elsif Expander_Active then
7704
7705          --  Associate privals with the first subprogram or entry
7706          --  body to be expanded. These are used to expand references
7707          --  to private data objects.
7708
7709          Op := First_Protected_Operation (Declarations (N));
7710
7711          if Present (Op) then
7712             Set_Discriminals (Parent (Spec_Id));
7713             Set_Privals (Parent (Spec_Id), Op, Sloc (N));
7714          end if;
7715       end if;
7716    end Expand_Protected_Body_Declarations;
7717
7718    -------------------------
7719    -- External_Subprogram --
7720    -------------------------
7721
7722    function External_Subprogram (E : Entity_Id) return Entity_Id is
7723       Subp : constant Entity_Id := Protected_Body_Subprogram (E);
7724       Decl : constant Node_Id   := Unit_Declaration_Node (E);
7725
7726    begin
7727       --  If the protected operation is defined in the visible part of the
7728       --  protected type, or if it is an interrupt handler, the internal and
7729       --  external subprograms follow each other on the entity chain. If the
7730       --  operation is defined in the private part of the type, there is no
7731       --  need for a separate locking version of the operation, and internal
7732       --  calls use the protected_body_subprogram directly.
7733
7734       if List_Containing (Decl) = Visible_Declarations (Parent (Decl))
7735         or else Is_Interrupt_Handler (E)
7736       then
7737          return Next_Entity (Subp);
7738       else
7739          return (Subp);
7740       end if;
7741    end External_Subprogram;
7742
7743    -------------------
7744    -- Extract_Entry --
7745    -------------------
7746
7747    procedure Extract_Entry
7748      (N       : Node_Id;
7749       Concval : out Node_Id;
7750       Ename   : out Node_Id;
7751       Index   : out Node_Id)
7752    is
7753       Nam : constant Node_Id := Name (N);
7754
7755    begin
7756       --  For a simple entry, the name is a selected component, with the
7757       --  prefix being the task value, and the selector being the entry.
7758
7759       if Nkind (Nam) = N_Selected_Component then
7760          Concval := Prefix (Nam);
7761          Ename   := Selector_Name (Nam);
7762          Index   := Empty;
7763
7764          --  For a member of an entry family, the name is an indexed
7765          --  component where the prefix is a selected component,
7766          --  whose prefix in turn is the task value, and whose
7767          --  selector is the entry family. The single expression in
7768          --  the expressions list of the indexed component is the
7769          --  subscript for the family.
7770
7771       else
7772          pragma Assert (Nkind (Nam) = N_Indexed_Component);
7773          Concval := Prefix (Prefix (Nam));
7774          Ename   := Selector_Name (Prefix (Nam));
7775          Index   := First (Expressions (Nam));
7776       end if;
7777    end Extract_Entry;
7778
7779    -------------------
7780    -- Family_Offset --
7781    -------------------
7782
7783    function Family_Offset
7784      (Loc  : Source_Ptr;
7785       Hi   : Node_Id;
7786       Lo   : Node_Id;
7787       Ttyp : Entity_Id) return Node_Id
7788    is
7789       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
7790       --  If one of the bounds is a reference to a discriminant, replace
7791       --  with corresponding discriminal of type. Within the body of a task
7792       --  retrieve the renamed discriminant by simple visibility, using its
7793       --  generated name. Within a protected object, find the original dis-
7794       --  criminant and replace it with the discriminal of the current prot-
7795       --  ected operation.
7796
7797       ------------------------------
7798       -- Convert_Discriminant_Ref --
7799       ------------------------------
7800
7801       function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
7802          Loc : constant Source_Ptr := Sloc (Bound);
7803          B   : Node_Id;
7804          D   : Entity_Id;
7805
7806       begin
7807          if Is_Entity_Name (Bound)
7808            and then Ekind (Entity (Bound)) = E_Discriminant
7809          then
7810             if Is_Task_Type (Ttyp)
7811               and then Has_Completion (Ttyp)
7812             then
7813                B := Make_Identifier (Loc, Chars (Entity (Bound)));
7814                Find_Direct_Name (B);
7815
7816             elsif Is_Protected_Type (Ttyp) then
7817                D := First_Discriminant (Ttyp);
7818
7819                while Chars (D) /= Chars (Entity (Bound)) loop
7820                   Next_Discriminant (D);
7821                end loop;
7822
7823                B := New_Reference_To  (Discriminal (D), Loc);
7824
7825             else
7826                B := New_Reference_To (Discriminal (Entity (Bound)), Loc);
7827             end if;
7828
7829          elsif Nkind (Bound) = N_Attribute_Reference then
7830             return Bound;
7831
7832          else
7833             B := New_Copy_Tree (Bound);
7834          end if;
7835
7836          return
7837            Make_Attribute_Reference (Loc,
7838              Attribute_Name => Name_Pos,
7839              Prefix => New_Occurrence_Of (Etype (Bound), Loc),
7840              Expressions    => New_List (B));
7841       end Convert_Discriminant_Ref;
7842
7843    --  Start of processing for Family_Offset
7844
7845    begin
7846       return
7847         Make_Op_Subtract (Loc,
7848           Left_Opnd  => Convert_Discriminant_Ref (Hi),
7849           Right_Opnd => Convert_Discriminant_Ref (Lo));
7850    end Family_Offset;
7851
7852    -----------------
7853    -- Family_Size --
7854    -----------------
7855
7856    function Family_Size
7857      (Loc  : Source_Ptr;
7858       Hi   : Node_Id;
7859       Lo   : Node_Id;
7860       Ttyp : Entity_Id) return Node_Id
7861    is
7862       Ityp : Entity_Id;
7863
7864    begin
7865       if Is_Task_Type (Ttyp) then
7866          Ityp := RTE (RE_Task_Entry_Index);
7867       else
7868          Ityp := RTE (RE_Protected_Entry_Index);
7869       end if;
7870
7871       return
7872         Make_Attribute_Reference (Loc,
7873           Prefix         => New_Reference_To (Ityp, Loc),
7874           Attribute_Name => Name_Max,
7875           Expressions    => New_List (
7876             Make_Op_Add (Loc,
7877               Left_Opnd  =>
7878                 Family_Offset (Loc, Hi, Lo, Ttyp),
7879               Right_Opnd =>
7880                 Make_Integer_Literal (Loc, 1)),
7881             Make_Integer_Literal (Loc, 0)));
7882    end Family_Size;
7883
7884    -----------------------------------
7885    -- Find_Task_Or_Protected_Pragma --
7886    -----------------------------------
7887
7888    function Find_Task_Or_Protected_Pragma
7889      (T : Node_Id;
7890       P : Name_Id) return Node_Id
7891    is
7892       N : Node_Id;
7893
7894    begin
7895       N := First (Visible_Declarations (T));
7896
7897       while Present (N) loop
7898          if Nkind (N) = N_Pragma then
7899             if Chars (N) = P then
7900                return N;
7901
7902             elsif P = Name_Priority
7903               and then Chars (N) = Name_Interrupt_Priority
7904             then
7905                return N;
7906
7907             else
7908                Next (N);
7909             end if;
7910
7911          else
7912             Next (N);
7913          end if;
7914       end loop;
7915
7916       N := First (Private_Declarations (T));
7917
7918       while Present (N) loop
7919          if Nkind (N) = N_Pragma then
7920             if  Chars (N) = P then
7921                return N;
7922
7923             elsif P = Name_Priority
7924               and then Chars (N) = Name_Interrupt_Priority
7925             then
7926                return N;
7927
7928             else
7929                Next (N);
7930             end if;
7931
7932          else
7933             Next (N);
7934          end if;
7935       end loop;
7936
7937       raise Program_Error;
7938    end Find_Task_Or_Protected_Pragma;
7939
7940    -------------------------------
7941    -- First_Protected_Operation --
7942    -------------------------------
7943
7944    function First_Protected_Operation (D : List_Id) return Node_Id is
7945       First_Op : Node_Id;
7946
7947    begin
7948       First_Op := First (D);
7949       while Present (First_Op)
7950         and then Nkind (First_Op) /= N_Subprogram_Body
7951         and then Nkind (First_Op) /= N_Entry_Body
7952       loop
7953          Next (First_Op);
7954       end loop;
7955
7956       return First_Op;
7957    end First_Protected_Operation;
7958
7959    --------------------------------
7960    -- Index_Constant_Declaration --
7961    --------------------------------
7962
7963    function Index_Constant_Declaration
7964      (N        : Node_Id;
7965       Index_Id : Entity_Id;
7966       Prot     : Entity_Id) return List_Id
7967    is
7968       Loc       : constant Source_Ptr := Sloc (N);
7969       Decls     : constant List_Id    := New_List;
7970       Index_Con : constant Entity_Id  := Entry_Index_Constant (Index_Id);
7971       Index_Typ : Entity_Id;
7972
7973       Hi : Node_Id := Type_High_Bound (Etype (Index_Id));
7974       Lo : Node_Id := Type_Low_Bound  (Etype (Index_Id));
7975
7976       function Replace_Discriminant (Bound : Node_Id) return Node_Id;
7977       --  The bounds of the entry index may depend on discriminants, so
7978       --  each declaration of an entry_index_constant must have its own
7979       --  subtype declaration, using the local renaming of the object discri-
7980       --  minant.
7981
7982       --------------------------
7983       -- Replace_Discriminant --
7984       --------------------------
7985
7986       function Replace_Discriminant (Bound : Node_Id) return Node_Id is
7987       begin
7988          if Nkind (Bound) = N_Identifier
7989            and then Ekind (Entity (Bound)) = E_Constant
7990            and then Present (Discriminal_Link (Entity (Bound)))
7991          then
7992             return Make_Identifier (Loc, Chars (Entity (Bound)));
7993          else
7994             return Duplicate_Subexpr (Bound);
7995          end if;
7996       end Replace_Discriminant;
7997
7998    --  Start of processing for Index_Constant_Declaration
7999
8000    begin
8001       Set_Discriminal_Link (Index_Con, Index_Id);
8002
8003       if Is_Entity_Name (
8004         Original_Node (Discrete_Subtype_Definition (Parent (Index_Id))))
8005       then
8006          --  Simple case: entry family is given by a subtype mark, and index
8007          --  constant has the same type, no replacement needed.
8008
8009          Index_Typ := Etype (Index_Id);
8010
8011       else
8012          Hi := Replace_Discriminant (Hi);
8013          Lo := Replace_Discriminant (Lo);
8014
8015          Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
8016
8017          Append (
8018            Make_Subtype_Declaration (Loc,
8019              Defining_Identifier => Index_Typ,
8020              Subtype_Indication =>
8021                Make_Subtype_Indication (Loc,
8022                  Subtype_Mark =>
8023                    New_Occurrence_Of (Base_Type (Etype (Index_Id)), Loc),
8024                  Constraint =>
8025                    Make_Range_Constraint (Loc,
8026                      Range_Expression => Make_Range (Loc, Lo, Hi)))),
8027            Decls);
8028
8029       end if;
8030
8031       Append (
8032         Make_Object_Declaration (Loc,
8033           Defining_Identifier => Index_Con,
8034           Constant_Present => True,
8035           Object_Definition => New_Occurrence_Of (Index_Typ, Loc),
8036
8037           Expression =>
8038             Make_Attribute_Reference (Loc,
8039               Prefix => New_Reference_To (Index_Typ, Loc),
8040               Attribute_Name => Name_Val,
8041
8042               Expressions => New_List (
8043
8044                 Make_Op_Add (Loc,
8045                   Left_Opnd =>
8046                     Make_Op_Subtract (Loc,
8047                       Left_Opnd => Make_Identifier (Loc, Name_uE),
8048                       Right_Opnd =>
8049                         Entry_Index_Expression (Loc,
8050                           Defining_Identifier (N), Empty, Prot)),
8051
8052                   Right_Opnd =>
8053                     Make_Attribute_Reference (Loc,
8054                       Prefix => New_Reference_To (Index_Typ, Loc),
8055                       Attribute_Name => Name_Pos,
8056                       Expressions => New_List (
8057                         Make_Attribute_Reference (Loc,
8058                           Prefix => New_Reference_To (Index_Typ, Loc),
8059                     Attribute_Name => Name_First))))))),
8060       Decls);
8061
8062       return Decls;
8063    end Index_Constant_Declaration;
8064
8065    --------------------------------
8066    -- Make_Initialize_Protection --
8067    --------------------------------
8068
8069    function Make_Initialize_Protection
8070      (Protect_Rec : Entity_Id) return List_Id
8071    is
8072       Loc         : constant Source_Ptr := Sloc (Protect_Rec);
8073       P_Arr       : Entity_Id;
8074       Pdef        : Node_Id;
8075       Pdec        : Node_Id;
8076       Ptyp        : constant Node_Id :=
8077                       Corresponding_Concurrent_Type (Protect_Rec);
8078       Args        : List_Id;
8079       L           : constant List_Id := New_List;
8080       Has_Entry   : constant Boolean := Has_Entries (Ptyp);
8081       Restricted  : constant Boolean := Restricted_Profile;
8082
8083    begin
8084       --  We may need two calls to properly initialize the object, one
8085       --  to Initialize_Protection, and possibly one to Install_Handlers
8086       --  if we have a pragma Attach_Handler.
8087
8088       --  Get protected declaration. In the case of a task type declaration,
8089       --  this is simply the parent of the protected type entity.
8090       --  In the single protected object
8091       --  declaration, this parent will be the implicit type, and we can find
8092       --  the corresponding single protected object declaration by
8093       --  searching forward in the declaration list in the tree.
8094       --  ??? I am not sure that the test for N_Single_Protected_Declaration
8095       --      is needed here. Nodes of this type should have been removed
8096       --      during semantic analysis.
8097
8098       Pdec := Parent (Ptyp);
8099
8100       while Nkind (Pdec) /= N_Protected_Type_Declaration
8101         and then Nkind (Pdec) /= N_Single_Protected_Declaration
8102       loop
8103          Next (Pdec);
8104       end loop;
8105
8106       --  Now we can find the object definition from this declaration
8107
8108       Pdef := Protected_Definition (Pdec);
8109
8110       --  Build the parameter list for the call. Note that _Init is the name
8111       --  of the formal for the object to be initialized, which is the task
8112       --  value record itself.
8113
8114       Args := New_List;
8115
8116       --  Object parameter. This is a pointer to the object of type
8117       --  Protection used by the GNARL to control the protected object.
8118
8119       Append_To (Args,
8120         Make_Attribute_Reference (Loc,
8121           Prefix =>
8122             Make_Selected_Component (Loc,
8123               Prefix => Make_Identifier (Loc, Name_uInit),
8124               Selector_Name => Make_Identifier (Loc, Name_uObject)),
8125           Attribute_Name => Name_Unchecked_Access));
8126
8127       --  Priority parameter. Set to Unspecified_Priority unless there is a
8128       --  priority pragma, in which case we take the value from the pragma,
8129       --  or there is an interrupt pragma and no priority pragma, and we
8130       --  set the ceiling to Interrupt_Priority'Last, an implementation-
8131       --  defined value, see D.3(10).
8132
8133       if Present (Pdef)
8134         and then Has_Priority_Pragma (Pdef)
8135       then
8136          Append_To (Args,
8137            Duplicate_Subexpr_No_Checks
8138              (Expression
8139                (First
8140                  (Pragma_Argument_Associations
8141                    (Find_Task_Or_Protected_Pragma (Pdef, Name_Priority))))));
8142
8143       elsif Has_Interrupt_Handler (Ptyp)
8144         or else Has_Attach_Handler (Ptyp)
8145       then
8146          --  When no priority is specified but an xx_Handler pragma is,
8147          --  we default to System.Interrupts.Default_Interrupt_Priority,
8148          --  see D.3(10).
8149
8150          Append_To (Args,
8151            New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
8152
8153       else
8154          Append_To (Args,
8155            New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
8156       end if;
8157
8158       if Has_Entry
8159         or else Has_Interrupt_Handler (Ptyp)
8160         or else Has_Attach_Handler (Ptyp)
8161       then
8162          --  Compiler_Info parameter. This parameter allows entry body
8163          --  procedures and barrier functions to be called from the runtime.
8164          --  It is a pointer to the record generated by the compiler to
8165          --  represent the protected object.
8166
8167          if Has_Entry or else not Restricted then
8168             Append_To (Args,
8169                Make_Attribute_Reference (Loc,
8170                  Prefix => Make_Identifier (Loc, Name_uInit),
8171                  Attribute_Name => Name_Address));
8172          end if;
8173
8174          if Has_Entry then
8175             --  Entry_Bodies parameter. This is a pointer to an array of
8176             --  pointers to the entry body procedures and barrier functions
8177             --  of the object. If the protected type has no entries this
8178             --  object will not exist; in this case, pass a null.
8179
8180             P_Arr := Entry_Bodies_Array (Ptyp);
8181
8182             Append_To (Args,
8183               Make_Attribute_Reference (Loc,
8184                 Prefix => New_Reference_To (P_Arr, Loc),
8185                 Attribute_Name => Name_Unrestricted_Access));
8186
8187             if Abort_Allowed
8188               or else Restriction_Active (No_Entry_Queue) = False
8189               or else Number_Entries (Ptyp) > 1
8190             then
8191                --  Find index mapping function (clumsy but ok for now).
8192
8193                while Ekind (P_Arr) /= E_Function loop
8194                   Next_Entity (P_Arr);
8195                end loop;
8196
8197                Append_To (Args,
8198                   Make_Attribute_Reference (Loc,
8199                     Prefix =>
8200                       New_Reference_To (P_Arr, Loc),
8201                     Attribute_Name => Name_Unrestricted_Access));
8202             end if;
8203
8204          elsif not Restricted then
8205             Append_To (Args, Make_Null (Loc));
8206             Append_To (Args, Make_Null (Loc));
8207          end if;
8208
8209          if Abort_Allowed
8210            or else Restriction_Active (No_Entry_Queue) = False
8211            or else Number_Entries (Ptyp) > 1
8212          then
8213             Append_To (L,
8214               Make_Procedure_Call_Statement (Loc,
8215                 Name => New_Reference_To (
8216                   RTE (RE_Initialize_Protection_Entries), Loc),
8217                 Parameter_Associations => Args));
8218
8219          elsif not Has_Entry and then Restricted then
8220             Append_To (L,
8221               Make_Procedure_Call_Statement (Loc,
8222                 Name => New_Reference_To (
8223                   RTE (RE_Initialize_Protection), Loc),
8224                 Parameter_Associations => Args));
8225
8226          else
8227             Append_To (L,
8228               Make_Procedure_Call_Statement (Loc,
8229                 Name => New_Reference_To (
8230                   RTE (RE_Initialize_Protection_Entry), Loc),
8231                 Parameter_Associations => Args));
8232          end if;
8233
8234       else
8235          Append_To (L,
8236            Make_Procedure_Call_Statement (Loc,
8237              Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
8238              Parameter_Associations => Args));
8239       end if;
8240
8241       if Has_Attach_Handler (Ptyp) then
8242
8243          --  We have a list of N Attach_Handler (ProcI, ExprI),
8244          --  and we have to make the following call:
8245          --  Install_Handlers (_object,
8246          --    ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
8247          --  or, in the case of Ravenscar:
8248          --  Install_Handlers
8249          --    ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
8250
8251          declare
8252             Args  : constant List_Id := New_List;
8253             Table : constant List_Id := New_List;
8254             Ritem : Node_Id := First_Rep_Item (Ptyp);
8255
8256          begin
8257             if not Restricted then
8258                --  Appends the _object argument
8259
8260                Append_To (Args,
8261                  Make_Attribute_Reference (Loc,
8262                    Prefix =>
8263                      Make_Selected_Component (Loc,
8264                        Prefix => Make_Identifier (Loc, Name_uInit),
8265                        Selector_Name => Make_Identifier (Loc, Name_uObject)),
8266                    Attribute_Name => Name_Unchecked_Access));
8267             end if;
8268
8269             --  Build the Attach_Handler table argument
8270
8271             while Present (Ritem) loop
8272                if Nkind (Ritem) = N_Pragma
8273                  and then Chars (Ritem) = Name_Attach_Handler
8274                then
8275                   declare
8276                      Handler : constant Node_Id :=
8277                                  First (Pragma_Argument_Associations (Ritem));
8278
8279                      Interrupt : constant Node_Id  := Next (Handler);
8280                      Expr      : constant  Node_Id := Expression (Interrupt);
8281
8282                   begin
8283                      Append_To (Table,
8284                        Make_Aggregate (Loc, Expressions => New_List (
8285                          Unchecked_Convert_To
8286                           (RTE (RE_System_Interrupt_Id), Expr),
8287                          Make_Attribute_Reference (Loc,
8288                            Prefix => Make_Selected_Component (Loc,
8289                               Make_Identifier (Loc, Name_uInit),
8290                               Duplicate_Subexpr_No_Checks
8291                                 (Expression (Handler))),
8292                            Attribute_Name => Name_Access))));
8293                   end;
8294                end if;
8295
8296                Next_Rep_Item (Ritem);
8297             end loop;
8298
8299             --  Appends the table argument we just built.
8300             Append_To (Args, Make_Aggregate (Loc, Table));
8301
8302             --  Appends the Install_Handler call to the statements.
8303             Append_To (L,
8304               Make_Procedure_Call_Statement (Loc,
8305                 Name => New_Reference_To (RTE (RE_Install_Handlers), Loc),
8306                 Parameter_Associations => Args));
8307          end;
8308       end if;
8309
8310       return L;
8311    end Make_Initialize_Protection;
8312
8313    ---------------------------
8314    -- Make_Task_Create_Call --
8315    ---------------------------
8316
8317    function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
8318       Loc    : constant Source_Ptr := Sloc (Task_Rec);
8319       Name   : Node_Id;
8320       Tdef   : Node_Id;
8321       Tdec   : Node_Id;
8322       Ttyp   : Node_Id;
8323       Tnam   : Name_Id;
8324       Args   : List_Id;
8325       Ecount : Node_Id;
8326
8327    begin
8328       Ttyp := Corresponding_Concurrent_Type (Task_Rec);
8329       Tnam := Chars (Ttyp);
8330
8331       --  Get task declaration. In the case of a task type declaration, this
8332       --  is simply the parent of the task type entity. In the single task
8333       --  declaration, this parent will be the implicit type, and we can find
8334       --  the corresponding single task declaration by searching forward in
8335       --  the declaration list in the tree.
8336       --  ??? I am not sure that the test for N_Single_Task_Declaration
8337       --      is needed here. Nodes of this type should have been removed
8338       --      during semantic analysis.
8339
8340       Tdec := Parent (Ttyp);
8341
8342       while Nkind (Tdec) /= N_Task_Type_Declaration
8343         and then Nkind (Tdec) /= N_Single_Task_Declaration
8344       loop
8345          Next (Tdec);
8346       end loop;
8347
8348       --  Now we can find the task definition from this declaration
8349
8350       Tdef := Task_Definition (Tdec);
8351
8352       --  Build the parameter list for the call. Note that _Init is the name
8353       --  of the formal for the object to be initialized, which is the task
8354       --  value record itself.
8355
8356       Args := New_List;
8357
8358       --  Priority parameter. Set to Unspecified_Priority unless there is a
8359       --  priority pragma, in which case we take the value from the pragma.
8360
8361       if Present (Tdef)
8362         and then Has_Priority_Pragma (Tdef)
8363       then
8364          Append_To (Args,
8365            Make_Selected_Component (Loc,
8366              Prefix => Make_Identifier (Loc, Name_uInit),
8367              Selector_Name => Make_Identifier (Loc, Name_uPriority)));
8368
8369       else
8370          Append_To (Args,
8371            New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
8372       end if;
8373
8374       --  Size parameter. If no Storage_Size pragma is present, then
8375       --  the size is taken from the taskZ variable for the type, which
8376       --  is either Unspecified_Size, or has been reset by the use of
8377       --  a Storage_Size attribute definition clause. If a pragma is
8378       --  present, then the size is taken from the _Size field of the
8379       --  task value record, which was set from the pragma value.
8380
8381       if Present (Tdef)
8382         and then Has_Storage_Size_Pragma (Tdef)
8383       then
8384          Append_To (Args,
8385            Make_Selected_Component (Loc,
8386              Prefix => Make_Identifier (Loc, Name_uInit),
8387              Selector_Name => Make_Identifier (Loc, Name_uSize)));
8388
8389       else
8390          Append_To (Args,
8391            New_Reference_To (Storage_Size_Variable (Ttyp), Loc));
8392       end if;
8393
8394       --  Task_Info parameter. Set to Unspecified_Task_Info unless there is a
8395       --  Task_Info pragma, in which case we take the value from the pragma.
8396
8397       if Present (Tdef)
8398         and then Has_Task_Info_Pragma (Tdef)
8399       then
8400          Append_To (Args,
8401            Make_Selected_Component (Loc,
8402              Prefix => Make_Identifier (Loc, Name_uInit),
8403              Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
8404
8405       else
8406          Append_To (Args,
8407            New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc));
8408       end if;
8409
8410       if not Restricted_Profile then
8411
8412          --  Number of entries. This is an expression of the form:
8413          --
8414          --    n + _Init.a'Length + _Init.a'B'Length + ...
8415          --
8416          --  where a,b... are the entry family names for the task definition
8417
8418          Ecount := Build_Entry_Count_Expression (
8419            Ttyp,
8420            Component_Items (Component_List (
8421              Type_Definition (Parent (
8422                Corresponding_Record_Type (Ttyp))))),
8423            Loc);
8424          Append_To (Args, Ecount);
8425
8426          --  Master parameter. This is a reference to the _Master parameter of
8427          --  the initialization procedure, except in the case of the pragma
8428          --  Restrictions (No_Task_Hierarchy) where the value is fixed to 3.
8429          --  See comments in System.Tasking.Initialization.Init_RTS for the
8430          --  value 3.
8431
8432          if Restriction_Active (No_Task_Hierarchy) = False then
8433             Append_To (Args, Make_Identifier (Loc, Name_uMaster));
8434          else
8435             Append_To (Args, Make_Integer_Literal (Loc, 3));
8436          end if;
8437       end if;
8438
8439       --  State parameter. This is a pointer to the task body procedure. The
8440       --  required value is obtained by taking the address of the task body
8441       --  procedure and converting it (with an unchecked conversion) to the
8442       --  type required by the task kernel. For further details, see the
8443       --  description of Expand_Task_Body
8444
8445       Append_To (Args,
8446         Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
8447           Make_Attribute_Reference (Loc,
8448             Prefix =>
8449               New_Occurrence_Of (Get_Task_Body_Procedure (Ttyp), Loc),
8450             Attribute_Name => Name_Address)));
8451
8452       --  Discriminants parameter. This is just the address of the task
8453       --  value record itself (which contains the discriminant values
8454
8455       Append_To (Args,
8456         Make_Attribute_Reference (Loc,
8457           Prefix => Make_Identifier (Loc, Name_uInit),
8458           Attribute_Name => Name_Address));
8459
8460       --  Elaborated parameter. This is an access to the elaboration Boolean
8461
8462       Append_To (Args,
8463         Make_Attribute_Reference (Loc,
8464           Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
8465           Attribute_Name => Name_Unchecked_Access));
8466
8467       --  Chain parameter. This is a reference to the _Chain parameter of
8468       --  the initialization procedure.
8469
8470       Append_To (Args, Make_Identifier (Loc, Name_uChain));
8471
8472       --  Task name parameter. Take this from the _Task_Id parameter to the
8473       --  init call unless there is a Task_Name pragma, in which case we take
8474       --  the value from the pragma.
8475
8476       if Present (Tdef)
8477         and then Has_Task_Name_Pragma (Tdef)
8478       then
8479          Append_To (Args,
8480            New_Copy (
8481              Expression (First (
8482                Pragma_Argument_Associations (
8483                  Find_Task_Or_Protected_Pragma
8484                    (Tdef, Name_Task_Name))))));
8485
8486       else
8487          Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
8488       end if;
8489
8490       --  Created_Task parameter. This is the _Task_Id field of the task
8491       --  record value
8492
8493       Append_To (Args,
8494         Make_Selected_Component (Loc,
8495           Prefix => Make_Identifier (Loc, Name_uInit),
8496           Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
8497
8498       if Restricted_Profile then
8499          Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
8500       else
8501          Name := New_Reference_To (RTE (RE_Create_Task), Loc);
8502       end if;
8503
8504       return Make_Procedure_Call_Statement (Loc,
8505         Name => Name, Parameter_Associations => Args);
8506    end Make_Task_Create_Call;
8507
8508    ------------------------------
8509    -- Next_Protected_Operation --
8510    ------------------------------
8511
8512    function Next_Protected_Operation (N : Node_Id) return Node_Id is
8513       Next_Op : Node_Id;
8514
8515    begin
8516       Next_Op := Next (N);
8517
8518       while Present (Next_Op)
8519         and then Nkind (Next_Op) /= N_Subprogram_Body
8520         and then Nkind (Next_Op) /= N_Entry_Body
8521       loop
8522          Next (Next_Op);
8523       end loop;
8524
8525       return Next_Op;
8526    end Next_Protected_Operation;
8527
8528    ----------------------
8529    -- Set_Discriminals --
8530    ----------------------
8531
8532    procedure Set_Discriminals (Dec : Node_Id) is
8533       D       : Entity_Id;
8534       Pdef    : Entity_Id;
8535       D_Minal : Entity_Id;
8536
8537    begin
8538       pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
8539       Pdef := Defining_Identifier (Dec);
8540
8541       if Has_Discriminants (Pdef) then
8542          D := First_Discriminant (Pdef);
8543
8544          while Present (D) loop
8545             D_Minal :=
8546               Make_Defining_Identifier (Sloc (D),
8547                 Chars => New_External_Name (Chars (D), 'D'));
8548
8549             Set_Ekind (D_Minal, E_Constant);
8550             Set_Etype (D_Minal, Etype (D));
8551             Set_Scope (D_Minal, Pdef);
8552             Set_Discriminal (D, D_Minal);
8553             Set_Discriminal_Link (D_Minal, D);
8554
8555             Next_Discriminant (D);
8556          end loop;
8557       end if;
8558    end Set_Discriminals;
8559
8560    -----------------
8561    -- Set_Privals --
8562    -----------------
8563
8564    procedure Set_Privals
8565       (Dec : Node_Id;
8566        Op  : Node_Id;
8567        Loc : Source_Ptr)
8568    is
8569       P_Decl    : Node_Id;
8570       P_Id      : Entity_Id;
8571       Priv      : Entity_Id;
8572       Def       : Node_Id;
8573       Body_Ent  : Entity_Id;
8574       Prec_Decl : constant Node_Id :=
8575                     Parent (Corresponding_Record_Type
8576                              (Defining_Identifier (Dec)));
8577       Prec_Def  : constant Entity_Id := Type_Definition (Prec_Decl);
8578       Obj_Decl  : Node_Id;
8579       P_Subtype : Entity_Id;
8580       Assoc_L   : constant Elist_Id := New_Elmt_List;
8581       Op_Id     : Entity_Id;
8582
8583    begin
8584       pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
8585       pragma Assert
8586         (Nkind (Op) = N_Subprogram_Body or else Nkind (Op) = N_Entry_Body);
8587
8588       Def := Protected_Definition (Dec);
8589
8590       if Present (Private_Declarations (Def)) then
8591
8592          P_Decl := First (Private_Declarations (Def));
8593
8594          while Present (P_Decl) loop
8595             if Nkind (P_Decl) = N_Component_Declaration then
8596                P_Id := Defining_Identifier (P_Decl);
8597                Priv :=
8598                  Make_Defining_Identifier (Loc,
8599                    New_External_Name (Chars (P_Id), 'P'));
8600
8601                Set_Ekind     (Priv, E_Variable);
8602                Set_Etype     (Priv, Etype (P_Id));
8603                Set_Scope     (Priv, Scope (P_Id));
8604                Set_Esize     (Priv, Esize (Etype (P_Id)));
8605                Set_Alignment (Priv, Alignment (Etype (P_Id)));
8606
8607                --  If the type of the component is an itype, we must
8608                --  create a new itype for the corresponding prival in
8609                --  each protected operation, to avoid scoping problems.
8610                --  We create new itypes by copying the tree for the
8611                --  component definition.
8612
8613                if Is_Itype (Etype (P_Id)) then
8614                   Append_Elmt (P_Id, Assoc_L);
8615                   Append_Elmt (Priv, Assoc_L);
8616
8617                   if Nkind (Op) = N_Entry_Body then
8618                      Op_Id := Defining_Identifier (Op);
8619                   else
8620                      Op_Id := Defining_Unit_Name (Specification (Op));
8621                   end if;
8622
8623                   Discard_Node
8624                     (New_Copy_Tree (P_Decl, Assoc_L, New_Scope => Op_Id));
8625                end if;
8626
8627                Set_Protected_Operation (P_Id, Op);
8628                Set_Prival (P_Id, Priv);
8629             end if;
8630
8631             Next (P_Decl);
8632          end loop;
8633       end if;
8634
8635       --  There is one more implicit private declaration: the object
8636       --  itself. A "prival" for this is attached to the protected
8637       --  body defining identifier.
8638
8639       Body_Ent := Corresponding_Body (Dec);
8640
8641       Priv :=
8642         Make_Defining_Identifier (Sloc (Body_Ent),
8643           Chars => New_External_Name (Chars (Body_Ent), 'R'));
8644
8645       --  Set the Etype to the implicit subtype of Protection created when
8646       --  the protected type declaration was expanded. This node will not
8647       --  be analyzed until it is used as the defining identifier for the
8648       --  renaming declaration in the protected operation body, and it will
8649       --  be needed in the references expanded before that body is expanded.
8650       --  Since the Protection field is aliased, set Is_Aliased as well.
8651
8652       Obj_Decl := First (Component_Items (Component_List (Prec_Def)));
8653       while Chars (Defining_Identifier (Obj_Decl)) /= Name_uObject loop
8654          Next (Obj_Decl);
8655       end loop;
8656
8657       P_Subtype  := Etype (Defining_Identifier (Obj_Decl));
8658       Set_Etype (Priv, P_Subtype);
8659       Set_Is_Aliased (Priv);
8660       Set_Object_Ref (Body_Ent, Priv);
8661    end Set_Privals;
8662
8663    ----------------------------
8664    -- Update_Prival_Subtypes --
8665    ----------------------------
8666
8667    procedure Update_Prival_Subtypes (N : Node_Id) is
8668
8669       function Process (N : Node_Id) return Traverse_Result;
8670       --  Update the etype of occurrences of privals whose etype does not
8671       --  match the current Etype of the prival entity itself.
8672
8673       procedure Update_Array_Bounds (E : Entity_Id);
8674       --  Itypes generated for array expressions may depend on the
8675       --  determinants of the protected object, and need to be processed
8676       --  separately because they are not attached to the tree.
8677
8678       procedure Update_Index_Types (N : Node_Id);
8679       --  Similarly, update the types of expressions in indexed components
8680       --  which may depend on other discriminants.
8681
8682       -------------
8683       -- Process --
8684       -------------
8685
8686       function Process (N : Node_Id) return Traverse_Result is
8687       begin
8688          if Is_Entity_Name (N)  then
8689             declare
8690                E : constant Entity_Id := Entity (N);
8691
8692             begin
8693                if Present (E)
8694                  and then (Ekind (E) = E_Constant
8695                             or else Ekind (E) = E_Variable)
8696                  and then Nkind (Parent (E)) = N_Object_Renaming_Declaration
8697                  and then not Is_Scalar_Type (Etype (E))
8698                  and then Etype (N) /= Etype (E)
8699                then
8700                   Set_Etype (N, Etype (Entity (Original_Node (N))));
8701                   Update_Index_Types (N);
8702
8703                elsif Present (E)
8704                  and then Ekind (E) = E_Constant
8705                  and then Present (Discriminal_Link (E))
8706                then
8707                   Set_Etype (N, Etype (E));
8708                end if;
8709             end;
8710
8711             return OK;
8712
8713          elsif Nkind (N) = N_Defining_Identifier
8714            or else Nkind (N) = N_Defining_Operator_Symbol
8715            or else Nkind (N) = N_Defining_Character_Literal
8716          then
8717             return Skip;
8718
8719          elsif Nkind (N) = N_String_Literal then
8720             --  array type, but bounds are constant.
8721             return OK;
8722
8723          elsif Nkind (N) = N_Object_Declaration
8724            and then Is_Itype (Etype (Defining_Identifier (N)))
8725            and then Is_Array_Type (Etype (Defining_Identifier (N)))
8726          then
8727             Update_Array_Bounds (Etype (Defining_Identifier (N)));
8728             return OK;
8729
8730          --  For array components of discriminated records, use the
8731          --  base type directly, because it may depend indirectly
8732          --  on the discriminants of the protected type. Cleaner would
8733          --  be a systematic mechanism to compute actual subtypes of
8734          --  private components ???
8735
8736          elsif Nkind (N) in N_Has_Etype
8737            and then Present (Etype (N))
8738            and then Is_Array_Type (Etype (N))
8739            and then Nkind (N) = N_Selected_Component
8740            and then Has_Discriminants (Etype (Prefix (N)))
8741          then
8742             Set_Etype (N, Base_Type (Etype (N)));
8743             Update_Index_Types (N);
8744             return OK;
8745
8746          else
8747             if Nkind (N) in N_Has_Etype
8748               and then Present (Etype (N))
8749               and then Is_Itype (Etype (N)) then
8750
8751                if Is_Array_Type (Etype (N)) then
8752                   Update_Array_Bounds (Etype (N));
8753
8754                elsif Is_Scalar_Type (Etype (N)) then
8755                   Update_Prival_Subtypes (Type_Low_Bound  (Etype (N)));
8756                   Update_Prival_Subtypes (Type_High_Bound (Etype (N)));
8757                end if;
8758             end if;
8759
8760             return OK;
8761          end if;
8762       end Process;
8763
8764       -------------------------
8765       -- Update_Array_Bounds --
8766       -------------------------
8767
8768       procedure Update_Array_Bounds (E : Entity_Id) is
8769          Ind : Node_Id;
8770
8771       begin
8772          Ind := First_Index (E);
8773
8774          while Present (Ind) loop
8775             Update_Prival_Subtypes (Type_Low_Bound  (Etype (Ind)));
8776             Update_Prival_Subtypes (Type_High_Bound (Etype (Ind)));
8777             Next_Index (Ind);
8778          end loop;
8779       end Update_Array_Bounds;
8780
8781       ------------------------
8782       -- Update_Index_Types --
8783       ------------------------
8784
8785       procedure Update_Index_Types (N : Node_Id) is
8786          Indx1 : Node_Id;
8787          I_Typ : Node_Id;
8788       begin
8789          --  If the prefix has an actual subtype that is different
8790          --  from the nominal one, update the types of the indices,
8791          --  so that the proper constraints are applied. Do not
8792          --  apply this transformation to a packed array, where the
8793          --  index type is computed for a byte array and is different
8794          --  from the source index.
8795
8796          if Nkind (Parent (N)) = N_Indexed_Component
8797            and then
8798              not Is_Bit_Packed_Array (Etype (Prefix (Parent (N))))
8799          then
8800             Indx1 := First (Expressions (Parent (N)));
8801             I_Typ := First_Index (Etype (N));
8802
8803             while Present (Indx1) and then Present (I_Typ) loop
8804
8805                if not Is_Entity_Name (Indx1) then
8806                   Set_Etype (Indx1, Base_Type (Etype (I_Typ)));
8807                end if;
8808
8809                Next (Indx1);
8810                Next_Index (I_Typ);
8811             end loop;
8812          end if;
8813       end Update_Index_Types;
8814
8815       procedure Traverse is new Traverse_Proc;
8816
8817    --  Start of processing for Update_Prival_Subtypes
8818
8819    begin
8820       Traverse (N);
8821    end Update_Prival_Subtypes;
8822
8823 end Exp_Ch9;