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