gcc/ada/exp_ch2.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 2                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Smem; use Exp_Smem;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Exp_Util; use Exp_Util;
  34 with Exp_VFpt; use Exp_VFpt;
  35 with Namet;    use Namet;
  36 with Nmake;    use Nmake;
  37 with Opt;      use Opt;
  38 with Sem;      use Sem;
  39 with Sem_Eval; use Sem_Eval;
  40 with Sem_Res;  use Sem_Res;
  41 with Sem_Util; use Sem_Util;
  42 with Sem_Warn; use Sem_Warn;
  43 with Sinfo;    use Sinfo;
  44 with Snames;   use Snames;
  45 with Tbuild;   use Tbuild;
  46 with Uintp;    use Uintp;
  47
  48 package body Exp_Ch2 is
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    procedure Expand_Current_Value (N : Node_Id);
  55    --  N is a node for a variable whose Current_Value field is set. If N is
  56    --  node is for a discrete type, replaces node with a copy of the referenced
  57    --  value. This provides a limited form of value propagation for variables
  58    --  which are initialized or assigned not been further modified at the time
  59    --  of reference. The call has no effect if the Current_Value refers to a
  60    --  conditional with condition other than equality.
  61
  62    procedure Expand_Discriminant (N : Node_Id);
  63    --  An occurrence of a discriminant within a discriminated type is replaced
  64    --  with the corresponding discriminal, that is to say the formal parameter
  65    --  of the initialization procedure for the type that is associated with
  66    --  that particular discriminant. This replacement is not performed for
  67    --  discriminants of records that appear in constraints of component of the
  68    --  record, because Gigi uses the discriminant name to retrieve its value.
  69    --  In the other hand, it has to be performed for default expressions of
  70    --  components because they are used in the record init procedure. See Einfo
  71    --  for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
  72    --  discriminants of tasks and protected types, the transformation is more
  73    --  complex when it occurs within a default expression for an entry or
  74    --  protected operation. The corresponding default_expression_function has
  75    --  an additional parameter which is the target of an entry call, and the
  76    --  discriminant of the task must be replaced with a reference to the
  77    --  discriminant of that formal parameter.
  78
  79    procedure Expand_Entity_Reference (N : Node_Id);
  80    --  Common processing for expansion of identifiers and expanded names
  81    --  Dispatches to specific expansion procedures.
  82
  83    procedure Expand_Entry_Index_Parameter (N : Node_Id);
  84    --  A reference to the identifier in the entry index specification of
  85    --  protected entry body is modified to a reference to a constant definition
  86    --  equal to the index of the entry family member being called. This
  87    --  constant is calculated as part of the elaboration of the expanded code
  88    --  for the body, and is calculated from the object-wide entry index
  89    --  returned by Next_Entry_Call.
  90
  91    procedure Expand_Entry_Parameter (N : Node_Id);
  92    --  A reference to an entry parameter is modified to be a reference to the
  93    --  corresponding component of the entry parameter record that is passed by
  94    --  the runtime to the accept body procedure.
  95
  96    procedure Expand_Formal (N : Node_Id);
  97    --  A reference to a formal parameter of a protected subprogram is expanded
  98    --  into the corresponding formal of the unprotected procedure used to
  99    --  represent the operation within the protected object. In other cases
 100    --  Expand_Formal is a no-op.
 101
 102    procedure Expand_Protected_Private (N : Node_Id);
 103    --  A reference to a private component of a protected type is expanded to a
 104    --  component selected from the record used to implement the protected
 105    --  object. Such a record is passed to all operations on a protected object
 106    --  in a parameter named _object. This object is a constant in the body of a
 107    --  function, and a variable within a procedure or entry body.
 108
 109    procedure Expand_Renaming (N : Node_Id);
 110    --  For renamings, just replace the identifier by the corresponding
 111    --  named expression. Note that this has been evaluated (see routine
 112    --  Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
 113    --  the correct renaming semantics.
 114
 115    --------------------------
 116    -- Expand_Current_Value --
 117    --------------------------
 118
 119    procedure Expand_Current_Value (N : Node_Id) is
 120       Loc : constant Source_Ptr := Sloc (N);
 121       E   : constant Entity_Id  := Entity (N);
 122       CV  : constant Node_Id    := Current_Value (E);
 123       T   : constant Entity_Id  := Etype (N);
 124       Val : Node_Id;
 125       Op  : Node_Kind;
 126
 127    --  Start of processing for Expand_Current_Value
 128
 129    begin
 130       if True
 131
 132          --  No replacement if value raises constraint error
 133
 134          and then Nkind (CV) /= N_Raise_Constraint_Error
 135
 136          --  Do this only for discrete types
 137
 138          and then Is_Discrete_Type (T)
 139
 140          --  Do not replace biased types, since it is problematic to
 141          --  consistently generate a sensible constant value in this case.
 142
 143          and then not Has_Biased_Representation (T)
 144
 145          --  Do not replace lvalues
 146
 147          and then not May_Be_Lvalue (N)
 148
 149          --  Check that entity is suitable for replacement
 150
 151          and then OK_To_Do_Constant_Replacement (E)
 152
 153          --  Do not replace occurrences in pragmas (where names typically
 154          --  appear not as values, but as simply names. If there are cases
 155          --  where values are required, it is only a very minor efficiency
 156          --  issue that they do not get replaced when they could be).
 157
 158          and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
 159
 160          --  Do not replace the prefixes of attribute references, since this
 161          --  causes trouble with cases like 4'Size. Also for Name_Asm_Input and
 162          --  Name_Asm_Output, don't do replacement anywhere, since we can have
 163          --  lvalue references in the arguments.
 164
 165          and then not (Nkind (Parent (N)) = N_Attribute_Reference
 166                          and then
 167                            (Attribute_Name (Parent (N)) = Name_Asm_Input
 168                               or else
 169                             Attribute_Name (Parent (N)) = Name_Asm_Output
 170                               or else
 171                             Prefix (Parent (N)) = N))
 172
 173       then
 174          --  Case of Current_Value is a compile time known value
 175
 176          if Nkind (CV) in N_Subexpr then
 177             Val := CV;
 178
 179          --  Case of Current_Value is a conditional expression reference
 180
 181          else
 182             Get_Current_Value_Condition (N, Op, Val);
 183
 184             if Op /= N_Op_Eq then
 185                return;
 186             end if;
 187          end if;
 188
 189          --  If constant value is an occurrence of an enumeration literal,
 190          --  then we just make another occurence of the same literal.
 191
 192          if Is_Entity_Name (Val)
 193            and then Ekind (Entity (Val)) = E_Enumeration_Literal
 194          then
 195             Rewrite (N,
 196               Unchecked_Convert_To (T,
 197                 New_Occurrence_Of (Entity (Val), Loc)));
 198
 199          --  Otherwise get the value, and convert to appropriate type
 200
 201          else
 202             Rewrite (N,
 203               Unchecked_Convert_To (T,
 204                 Make_Integer_Literal (Loc,
 205                   Intval => Expr_Rep_Value (Val))));
 206          end if;
 207
 208          Analyze_And_Resolve (N, T);
 209          Set_Is_Static_Expression (N, False);
 210       end if;
 211    end Expand_Current_Value;
 212
 213    -------------------------
 214    -- Expand_Discriminant --
 215    -------------------------
 216
 217    procedure Expand_Discriminant (N : Node_Id) is
 218       Scop     : constant Entity_Id := Scope (Entity (N));
 219       P        : Node_Id := N;
 220       Parent_P : Node_Id := Parent (P);
 221       In_Entry : Boolean := False;
 222
 223    begin
 224       --  The Incomplete_Or_Private_Kind happens while resolving the
 225       --  discriminant constraint involved in a derived full type,
 226       --  such as:
 227
 228       --    type D is private;
 229       --    type D(C : ...) is new T(C);
 230
 231       if Ekind (Scop) = E_Record_Type
 232         or Ekind (Scop) in Incomplete_Or_Private_Kind
 233       then
 234          --  Find the origin by walking up the tree till the component
 235          --  declaration
 236
 237          while Present (Parent_P)
 238            and then Nkind (Parent_P) /= N_Component_Declaration
 239          loop
 240             P := Parent_P;
 241             Parent_P := Parent (P);
 242          end loop;
 243
 244          --  If the discriminant reference was part of the default expression
 245          --  it has to be "discriminalized"
 246
 247          if Present (Parent_P) and then P = Expression (Parent_P) then
 248             Set_Entity (N, Discriminal (Entity (N)));
 249          end if;
 250
 251       elsif Is_Concurrent_Type (Scop) then
 252          while Present (Parent_P)
 253            and then Nkind (Parent_P) /= N_Subprogram_Body
 254          loop
 255             P := Parent_P;
 256
 257             if Nkind (P) = N_Entry_Declaration then
 258                In_Entry := True;
 259             end if;
 260
 261             Parent_P := Parent (Parent_P);
 262          end loop;
 263
 264          --  If the discriminant occurs within the default expression for a
 265          --  formal of an entry or protected operation, create a default
 266          --  function for it, and replace the discriminant with a reference to
 267          --  the discriminant of the formal of the default function. The
 268          --  discriminant entity is the one defined in the corresponding
 269          --  record.
 270
 271          if Present (Parent_P)
 272            and then Present (Corresponding_Spec (Parent_P))
 273          then
 274             declare
 275                Loc    : constant Source_Ptr := Sloc (N);
 276                D_Fun  : constant Entity_Id := Corresponding_Spec  (Parent_P);
 277                Formal : constant Entity_Id := First_Formal (D_Fun);
 278                New_N  : Node_Id;
 279                Disc   : Entity_Id;
 280
 281             begin
 282                --  Verify that we are within a default function: the type of
 283                --  its formal parameter is the same task or protected type.
 284
 285                if Present (Formal)
 286                  and then Etype (Formal) = Scope (Entity (N))
 287                then
 288                   Disc := CR_Discriminant (Entity (N));
 289
 290                   New_N :=
 291                     Make_Selected_Component (Loc,
 292                       Prefix => New_Occurrence_Of (Formal, Loc),
 293                       Selector_Name => New_Occurrence_Of (Disc, Loc));
 294
 295                   Set_Etype (New_N, Etype (N));
 296                   Rewrite (N, New_N);
 297
 298                else
 299                   Set_Entity (N, Discriminal (Entity (N)));
 300                end if;
 301             end;
 302
 303          elsif Nkind (Parent (N)) = N_Range
 304            and then In_Entry
 305          then
 306             Set_Entity (N, CR_Discriminant (Entity (N)));
 307          else
 308             Set_Entity (N, Discriminal (Entity (N)));
 309          end if;
 310
 311       else
 312          Set_Entity (N, Discriminal (Entity (N)));
 313       end if;
 314    end Expand_Discriminant;
 315
 316    -----------------------------
 317    -- Expand_Entity_Reference --
 318    -----------------------------
 319
 320    procedure Expand_Entity_Reference (N : Node_Id) is
 321       E : constant Entity_Id := Entity (N);
 322
 323    begin
 324       --  Defend against errors
 325
 326       if No (E) and then Total_Errors_Detected /= 0 then
 327          return;
 328       end if;
 329
 330       if Ekind (E) = E_Discriminant then
 331          Expand_Discriminant (N);
 332
 333       elsif Is_Entry_Formal (E) then
 334          Expand_Entry_Parameter (N);
 335
 336       elsif Ekind (E) = E_Component
 337         and then Is_Protected_Private (E)
 338       then
 339          --  Protect against junk use of tasking in no run time mode
 340
 341          if No_Run_Time_Mode then
 342             return;
 343          end if;
 344
 345          Expand_Protected_Private (N);
 346
 347       elsif Ekind (E) = E_Entry_Index_Parameter then
 348          Expand_Entry_Index_Parameter (N);
 349
 350       elsif Is_Formal (E) then
 351          Expand_Formal (N);
 352
 353       elsif Is_Renaming_Of_Object (E) then
 354          Expand_Renaming (N);
 355
 356       elsif Ekind (E) = E_Variable
 357         and then Is_Shared_Passive (E)
 358       then
 359          Expand_Shared_Passive_Variable (N);
 360       end if;
 361
 362       --  Interpret possible Current_Value for variable case
 363
 364       if (Ekind (E) = E_Variable
 365             or else
 366           Ekind (E) = E_In_Out_Parameter
 367             or else
 368           Ekind (E) = E_Out_Parameter)
 369         and then Present (Current_Value (E))
 370       then
 371          Expand_Current_Value (N);
 372
 373          --  We do want to warn for the case of a boolean variable (not a
 374          --  boolean constant) whose value is known at compile time.
 375
 376          if Is_Boolean_Type (Etype (N)) then
 377             Warn_On_Known_Condition (N);
 378          end if;
 379
 380       --  Don't mess with Current_Value for compile time known values. Not
 381       --  only is it unnecessary, but we could disturb an indication of a
 382       --  static value, which could cause semantic trouble.
 383
 384       elsif Compile_Time_Known_Value (N) then
 385          null;
 386
 387       --  Interpret possible Current_Value for constant case
 388
 389       elsif (Ekind (E) = E_Constant
 390                or else
 391              Ekind (E) = E_In_Parameter
 392                or else
 393              Ekind (E) = E_Loop_Parameter)
 394         and then Present (Current_Value (E))
 395       then
 396          Expand_Current_Value (N);
 397       end if;
 398    end Expand_Entity_Reference;
 399
 400    ----------------------------------
 401    -- Expand_Entry_Index_Parameter --
 402    ----------------------------------
 403
 404    procedure Expand_Entry_Index_Parameter (N : Node_Id) is
 405    begin
 406       Set_Entity (N, Entry_Index_Constant (Entity (N)));
 407    end Expand_Entry_Index_Parameter;
 408
 409    ----------------------------
 410    -- Expand_Entry_Parameter --
 411    ----------------------------
 412
 413    procedure Expand_Entry_Parameter (N : Node_Id) is
 414       Loc        : constant Source_Ptr := Sloc (N);
 415       Ent_Formal : constant Entity_Id  := Entity (N);
 416       Ent_Spec   : constant Entity_Id  := Scope (Ent_Formal);
 417       Parm_Type  : constant Entity_Id  := Entry_Parameters_Type (Ent_Spec);
 418       Acc_Stack  : constant Elist_Id   := Accept_Address (Ent_Spec);
 419       Addr_Ent   : constant Entity_Id  := Node (Last_Elmt (Acc_Stack));
 420       P_Comp_Ref : Entity_Id;
 421
 422       function In_Assignment_Context (N : Node_Id) return Boolean;
 423       --  Check whether this is a context in which the entry formal may be
 424       --  assigned to.
 425
 426       ---------------------------
 427       -- In_Assignment_Context --
 428       ---------------------------
 429
 430       function In_Assignment_Context (N : Node_Id) return Boolean is
 431       begin
 432          --  Case of use in a call
 433
 434          --  ??? passing a formal as actual for a mode IN formal is
 435          --  considered as an assignment?
 436
 437          if Nkind (Parent (N)) = N_Procedure_Call_Statement
 438            or else Nkind (Parent (N)) = N_Entry_Call_Statement
 439            or else
 440              (Nkind (Parent (N)) = N_Assignment_Statement
 441                  and then N = Name (Parent (N)))
 442          then
 443             return True;
 444
 445          --  Case of a parameter association: climb up to enclosing call
 446
 447          elsif Nkind (Parent (N)) = N_Parameter_Association then
 448             return In_Assignment_Context (Parent (N));
 449
 450          --  Case of a selected component, indexed component or slice prefix:
 451          --  climb up the tree, unless the prefix is of an access type (in
 452          --  which case there is an implicit dereference, and the formal itself
 453          --  is not being assigned to).
 454
 455          elsif (Nkind (Parent (N)) = N_Selected_Component
 456                  or else Nkind (Parent (N)) = N_Indexed_Component
 457                  or else Nkind (Parent (N)) = N_Slice)
 458            and then N = Prefix (Parent (N))
 459            and then not Is_Access_Type (Etype (N))
 460            and then In_Assignment_Context (Parent (N))
 461          then
 462             return True;
 463
 464          else
 465             return False;
 466          end if;
 467       end In_Assignment_Context;
 468
 469    --  Start of processing for Expand_Entry_Parameter
 470
 471    begin
 472       if Is_Task_Type (Scope (Ent_Spec))
 473         and then Comes_From_Source (Ent_Formal)
 474       then
 475          --  Before replacing the formal with the local renaming that is used
 476          --  in the accept block, note if this is an assignment context, and
 477          --  note the modification to avoid spurious warnings, because the
 478          --  original entity is not used further. If formal is unconstrained,
 479          --  we also generate an extra parameter to hold the Constrained
 480          --  attribute of the actual. No renaming is generated for this flag.
 481
 482          if Ekind (Entity (N)) /= E_In_Parameter
 483            and then In_Assignment_Context (N)
 484          then
 485             Note_Possible_Modification (N);
 486          end if;
 487
 488          Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
 489          return;
 490       end if;
 491
 492       --  What we need is a reference to the corresponding component of the
 493       --  parameter record object. The Accept_Address field of the entry entity
 494       --  references the address variable that contains the address of the
 495       --  accept parameters record. We first have to do an unchecked conversion
 496       --  to turn this into a pointer to the parameter record and then we
 497       --  select the required parameter field.
 498
 499       P_Comp_Ref :=
 500         Make_Selected_Component (Loc,
 501           Prefix =>
 502             Make_Explicit_Dereference (Loc,
 503               Unchecked_Convert_To (Parm_Type,
 504                 New_Reference_To (Addr_Ent, Loc))),
 505           Selector_Name =>
 506             New_Reference_To (Entry_Component (Ent_Formal), Loc));
 507
 508       --  For all types of parameters, the constructed parameter record object
 509       --  contains a pointer to the parameter. Thus we must dereference them to
 510       --  access them (this will often be redundant, since the needed deference
 511       --  is implicit, but no harm is done by making it explicit).
 512
 513       Rewrite (N,
 514         Make_Explicit_Dereference (Loc, P_Comp_Ref));
 515
 516       Analyze (N);
 517    end Expand_Entry_Parameter;
 518
 519    -------------------
 520    -- Expand_Formal --
 521    -------------------
 522
 523    procedure Expand_Formal (N : Node_Id) is
 524       E    : constant Entity_Id  := Entity (N);
 525       Scop : constant Entity_Id  := Scope (E);
 526
 527    begin
 528       --  Check whether the subprogram of which this is a formal is
 529       --  a protected operation. The initialization procedure for
 530       --  the corresponding record type is not itself a protected operation.
 531
 532       if Is_Protected_Type (Scope (Scop))
 533         and then not Is_Init_Proc (Scop)
 534         and then Present (Protected_Formal (E))
 535       then
 536          Set_Entity (N, Protected_Formal (E));
 537       end if;
 538    end Expand_Formal;
 539
 540    ----------------------------
 541    -- Expand_N_Expanded_Name --
 542    ----------------------------
 543
 544    procedure Expand_N_Expanded_Name (N : Node_Id) is
 545    begin
 546       Expand_Entity_Reference (N);
 547    end Expand_N_Expanded_Name;
 548
 549    -------------------------
 550    -- Expand_N_Identifier --
 551    -------------------------
 552
 553    procedure Expand_N_Identifier (N : Node_Id) is
 554    begin
 555       Expand_Entity_Reference (N);
 556    end Expand_N_Identifier;
 557
 558    ---------------------------
 559    -- Expand_N_Real_Literal --
 560    ---------------------------
 561
 562    procedure Expand_N_Real_Literal (N : Node_Id) is
 563    begin
 564       if Vax_Float (Etype (N)) then
 565          Expand_Vax_Real_Literal (N);
 566       end if;
 567    end Expand_N_Real_Literal;
 568
 569    ------------------------------
 570    -- Expand_Protected_Private --
 571    ------------------------------
 572
 573    procedure Expand_Protected_Private (N : Node_Id) is
 574       Loc      : constant Source_Ptr := Sloc (N);
 575       E        : constant Entity_Id  := Entity (N);
 576       Op       : constant Node_Id    := Protected_Operation (E);
 577       Scop     : Entity_Id;
 578       Lo       : Node_Id;
 579       Hi       : Node_Id;
 580       D_Range  : Node_Id;
 581
 582    begin
 583       if Nkind (Op) /= N_Subprogram_Body
 584         or else Nkind (Specification (Op)) /= N_Function_Specification
 585       then
 586          Set_Ekind (Prival (E), E_Variable);
 587       else
 588          Set_Ekind (Prival (E), E_Constant);
 589       end if;
 590
 591       --  If the private component appears in an assignment (either lhs or
 592       --  rhs) and is a one-dimensional array constrained by a discriminant,
 593       --  rewrite as  P (Lo .. Hi) with an explicit range, so that discriminal
 594       --  is directly visible. This solves delicate visibility problems.
 595
 596       if Comes_From_Source (N)
 597         and then Is_Array_Type (Etype (E))
 598         and then Number_Dimensions (Etype (E)) = 1
 599         and then not Within_Init_Proc
 600       then
 601          Lo := Type_Low_Bound  (Etype (First_Index (Etype (E))));
 602          Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
 603
 604          if Nkind (Parent (N)) = N_Assignment_Statement
 605            and then ((Is_Entity_Name (Lo)
 606                           and then Ekind (Entity (Lo)) = E_In_Parameter)
 607                        or else (Is_Entity_Name (Hi)
 608                                   and then
 609                                     Ekind (Entity (Hi)) = E_In_Parameter))
 610          then
 611             D_Range := New_Node (N_Range, Loc);
 612
 613             if Is_Entity_Name (Lo)
 614               and then Ekind (Entity (Lo)) = E_In_Parameter
 615             then
 616                Set_Low_Bound (D_Range,
 617                  Make_Identifier (Loc, Chars (Entity (Lo))));
 618             else
 619                Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
 620             end if;
 621
 622             if Is_Entity_Name (Hi)
 623               and then Ekind (Entity (Hi)) = E_In_Parameter
 624             then
 625                Set_High_Bound (D_Range,
 626                  Make_Identifier (Loc, Chars (Entity (Hi))));
 627             else
 628                Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
 629             end if;
 630
 631             Rewrite (N,
 632               Make_Slice (Loc,
 633                 Prefix => New_Occurrence_Of (E, Loc),
 634                 Discrete_Range => D_Range));
 635
 636             Analyze_And_Resolve (N, Etype (E));
 637             return;
 638          end if;
 639       end if;
 640
 641       --  The type of the reference is the type of the prival, which may differ
 642       --  from that of the original component if it is an itype.
 643
 644       Set_Entity (N, Prival (E));
 645       Set_Etype  (N, Etype (Prival (E)));
 646       Scop := Current_Scope;
 647
 648       --  Find entity for protected operation, which must be on scope stack
 649
 650       while not Is_Protected_Type (Scope (Scop)) loop
 651          Scop := Scope (Scop);
 652       end loop;
 653
 654       Append_Elmt (N, Privals_Chain (Scop));
 655    end Expand_Protected_Private;
 656
 657    ---------------------
 658    -- Expand_Renaming --
 659    ---------------------
 660
 661    procedure Expand_Renaming (N : Node_Id) is
 662       E : constant Entity_Id := Entity (N);
 663       T : constant Entity_Id := Etype (N);
 664
 665    begin
 666       Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
 667
 668       --  We mark the copy as unanalyzed, so that it is sure to be reanalyzed
 669       --  at the top level. This is needed in the packed case since we
 670       --  specifically avoided expanding packed array references when the
 671       --  renaming declaration was analyzed.
 672
 673       Reset_Analyzed_Flags (N);
 674       Analyze_And_Resolve (N, T);
 675    end Expand_Renaming;
 676
 677    ------------------
 678    -- Param_Entity --
 679    ------------------
 680
 681    --  This would be trivial, simply a test for an identifier that was a
 682    --  reference to a formal, if it were not for the fact that a previous call
 683    --  to Expand_Entry_Parameter will have modified the reference to the
 684    --  identifier. A formal of a protected entity is rewritten as
 685
 686    --    typ!(recobj).rec.all'Constrained
 687
 688    --  where rec is a selector whose Entry_Formal link points to the formal
 689    --  For a formal of a task entity, the formal is rewritten as a local
 690    --  renaming.
 691
 692    --  In addition, a formal that is marked volatile because it is aliased
 693    --  through an address clause is rewritten as dereference as well.
 694
 695    function Param_Entity (N : Node_Id) return Entity_Id is
 696       Renamed_Obj : Node_Id;
 697
 698    begin
 699       --  Simple reference case
 700
 701       if Nkind (N) = N_Identifier or else Nkind (N) = N_Expanded_Name then
 702          if Is_Formal (Entity (N)) then
 703             return Entity (N);
 704
 705          --  Handle renamings of formal parameters and formals of tasks that
 706          --  are rewritten as renamings.
 707
 708          elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
 709             Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
 710
 711             if Is_Entity_Name (Renamed_Obj)
 712               and then Is_Formal (Entity (Renamed_Obj))
 713             then
 714                return Entity (Renamed_Obj);
 715
 716             elsif
 717               Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
 718             then
 719                return Entity (N);
 720             end if;
 721          end if;
 722
 723       else
 724          if Nkind (N) = N_Explicit_Dereference then
 725             declare
 726                P : constant Node_Id := Prefix (N);
 727                S : Node_Id;
 728
 729             begin
 730                if Nkind (P) = N_Selected_Component then
 731                   S := Selector_Name (P);
 732
 733                   if Present (Entry_Formal (Entity (S))) then
 734                      return Entry_Formal (Entity (S));
 735                   end if;
 736
 737                elsif Nkind (Original_Node (N)) = N_Identifier then
 738                   return Param_Entity (Original_Node (N));
 739                end if;
 740             end;
 741          end if;
 742       end if;
 743
 744       return (Empty);
 745    end Param_Entity;
 746
 747 end Exp_Ch2;