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