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