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