gcc/ada/exp_ch9.adb

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