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