gcc/ada/exp_ch9.adb

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