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