gcc/ada/exp_ch9.adb

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