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-2013, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Exp_Smem; use Exp_Smem;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Exp_Util; use Exp_Util;
  34 with Namet;    use Namet;
  35 with Nmake;    use Nmake;
  36 with Opt;      use Opt;
  37 with Output;   use Output;
  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 Sinput;   use Sinput;
  45 with Snames;   use Snames;
  46 with Tbuild;   use Tbuild;
  47 with Uintp;    use Uintp;
  48
  49 package body Exp_Ch2 is
  50
  51    -----------------------
  52    -- Local Subprograms --
  53    -----------------------
  54
  55    procedure Expand_Current_Value (N : Node_Id);
  56    --  N is a node for a variable whose Current_Value field is set. If N is
  57    --  node is for a discrete type, replaces node with a copy of the referenced
  58    --  value. This provides a limited form of value propagation for variables
  59    --  which are initialized or assigned not been further modified at the time
  60    --  of reference. The call has no effect if the Current_Value refers to a
  61    --  conditional with condition other than equality.
  62
  63    procedure Expand_Discriminant (N : Node_Id);
  64    --  An occurrence of a discriminant within a discriminated type is replaced
  65    --  with the corresponding discriminal, that is to say the formal parameter
  66    --  of the initialization procedure for the type that is associated with
  67    --  that particular discriminant. This replacement is not performed for
  68    --  discriminants of records that appear in constraints of component of the
  69    --  record, because Gigi uses the discriminant name to retrieve its value.
  70    --  In the other hand, it has to be performed for default expressions of
  71    --  components because they are used in the record init procedure. See Einfo
  72    --  for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
  73    --  discriminants of tasks and protected types, the transformation is more
  74    --  complex when it occurs within a default expression for an entry or
  75    --  protected operation. The corresponding default_expression_function has
  76    --  an additional parameter which is the target of an entry call, and the
  77    --  discriminant of the task must be replaced with a reference to the
  78    --  discriminant of that formal parameter.
  79
  80    procedure Expand_Entity_Reference (N : Node_Id);
  81    --  Common processing for expansion of identifiers and expanded names
  82    --  Dispatches to specific expansion procedures.
  83
  84    procedure Expand_Entry_Index_Parameter (N : Node_Id);
  85    --  A reference to the identifier in the entry index specification of an
  86    --  entry body is modified to a reference to a constant definition equal to
  87    --  the index of the entry family member being called. This constant is
  88    --  calculated as part of the elaboration of the expanded code for the body,
  89    --  and is calculated from the object-wide entry index returned by Next_
  90    --  Entry_Call.
  91
  92    procedure Expand_Entry_Parameter (N : Node_Id);
  93    --  A reference to an entry parameter is modified to be a reference to the
  94    --  corresponding component of the entry parameter record that is passed by
  95    --  the runtime to the accept body procedure.
  96
  97    procedure Expand_Formal (N : Node_Id);
  98    --  A reference to a formal parameter of a protected subprogram is expanded
  99    --  into the corresponding formal of the unprotected procedure used to
 100    --  represent the operation within the protected object. In other cases
 101    --  Expand_Formal is a no-op.
 102
 103    procedure Expand_Protected_Component (N : Node_Id);
 104    --  A reference to a private component of a protected type is expanded into
 105    --  a reference to the corresponding prival in the current protected entry
 106    --  or subprogram.
 107
 108    procedure Expand_Renaming (N : Node_Id);
 109    --  For renamings, just replace the identifier by the corresponding
 110    --  named expression. Note that this has been evaluated (see routine
 111    --  Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
 112    --  the correct renaming semantics.
 113
 114    --------------------------
 115    -- Expand_Current_Value --
 116    --------------------------
 117
 118    procedure Expand_Current_Value (N : Node_Id) is
 119       Loc : constant Source_Ptr := Sloc (N);
 120       E   : constant Entity_Id  := Entity (N);
 121       CV  : constant Node_Id    := Current_Value (E);
 122       T   : constant Entity_Id  := Etype (N);
 123       Val : Node_Id;
 124       Op  : Node_Kind;
 125
 126    --  Start of processing for Expand_Current_Value
 127
 128    begin
 129       if True
 130
 131          --  No replacement if value raises constraint error
 132
 133          and then Nkind (CV) /= N_Raise_Constraint_Error
 134
 135          --  Do this only for discrete types
 136
 137          and then Is_Discrete_Type (T)
 138
 139          --  Do not replace biased types, since it is problematic to
 140          --  consistently generate a sensible constant value in this case.
 141
 142          and then not Has_Biased_Representation (T)
 143
 144          --  Do not replace lvalues
 145
 146          and then not May_Be_Lvalue (N)
 147
 148          --  Check that entity is suitable for replacement
 149
 150          and then OK_To_Do_Constant_Replacement (E)
 151
 152          --  Do not replace occurrences in pragmas (where names typically
 153          --  appear not as values, but as simply names. If there are cases
 154          --  where values are required, it is only a very minor efficiency
 155          --  issue that they do not get replaced when they could be).
 156
 157          and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
 158
 159          --  Do not replace the prefixes of attribute references, since this
 160          --  causes trouble with cases like 4'Size. Also for Name_Asm_Input and
 161          --  Name_Asm_Output, don't do replacement anywhere, since we can have
 162          --  lvalue references in the arguments.
 163
 164          and then not (Nkind (Parent (N)) = N_Attribute_Reference
 165                         and then
 166                           (Nam_In (Attribute_Name (Parent (N)),
 167                                    Name_Asm_Input,
 168                                    Name_Asm_Output)
 169                             or else Prefix (Parent (N)) = N))
 170
 171       then
 172          --  Case of Current_Value is a compile time known value
 173
 174          if Nkind (CV) in N_Subexpr then
 175             Val := CV;
 176
 177          --  Case of Current_Value is an if expression reference
 178
 179          else
 180             Get_Current_Value_Condition (N, Op, Val);
 181
 182             if Op /= N_Op_Eq then
 183                return;
 184             end if;
 185          end if;
 186
 187          --  If constant value is an occurrence of an enumeration literal,
 188          --  then we just make another occurrence of the same literal.
 189
 190          if Is_Entity_Name (Val)
 191            and then Ekind (Entity (Val)) = E_Enumeration_Literal
 192          then
 193             Rewrite (N,
 194               Unchecked_Convert_To (T,
 195                 New_Occurrence_Of (Entity (Val), Loc)));
 196
 197          --  If constant is of an integer type, just make an appropriately
 198          --  integer literal, which will get the proper type.
 199
 200          elsif Is_Integer_Type (T) then
 201             Rewrite (N,
 202               Make_Integer_Literal (Loc,
 203                 Intval => Expr_Rep_Value (Val)));
 204
 205          --  Otherwise do unchecked conversion of value to right type
 206
 207          else
 208             Rewrite (N,
 209               Unchecked_Convert_To (T,
 210                  Make_Integer_Literal (Loc,
 211                    Intval => Expr_Rep_Value (Val))));
 212          end if;
 213
 214          Analyze_And_Resolve (N, T);
 215          Set_Is_Static_Expression (N, False);
 216       end if;
 217    end Expand_Current_Value;
 218
 219    -------------------------
 220    -- Expand_Discriminant --
 221    -------------------------
 222
 223    procedure Expand_Discriminant (N : Node_Id) is
 224       Scop     : constant Entity_Id := Scope (Entity (N));
 225       P        : Node_Id := N;
 226       Parent_P : Node_Id := Parent (P);
 227       In_Entry : Boolean := False;
 228
 229    begin
 230       --  The Incomplete_Or_Private_Kind happens while resolving the
 231       --  discriminant constraint involved in a derived full type,
 232       --  such as:
 233
 234       --    type D is private;
 235       --    type D(C : ...) is new T(C);
 236
 237       if Ekind (Scop) = E_Record_Type
 238         or Ekind (Scop) in Incomplete_Or_Private_Kind
 239       then
 240          --  Find the origin by walking up the tree till the component
 241          --  declaration
 242
 243          while Present (Parent_P)
 244            and then Nkind (Parent_P) /= N_Component_Declaration
 245          loop
 246             P := Parent_P;
 247             Parent_P := Parent (P);
 248          end loop;
 249
 250          --  If the discriminant reference was part of the default expression
 251          --  it has to be "discriminalized"
 252
 253          if Present (Parent_P) and then P = Expression (Parent_P) then
 254             Set_Entity (N, Discriminal (Entity (N)));
 255          end if;
 256
 257       elsif Is_Concurrent_Type (Scop) then
 258          while Present (Parent_P)
 259            and then Nkind (Parent_P) /= N_Subprogram_Body
 260          loop
 261             P := Parent_P;
 262
 263             if Nkind (P) = N_Entry_Declaration then
 264                In_Entry := True;
 265             end if;
 266
 267             Parent_P := Parent (Parent_P);
 268          end loop;
 269
 270          --  If the discriminant occurs within the default expression for a
 271          --  formal of an entry or protected operation, replace it with a
 272          --  reference to the discriminant of the formal of the enclosing
 273          --  operation.
 274
 275          if Present (Parent_P)
 276            and then Present (Corresponding_Spec (Parent_P))
 277          then
 278             declare
 279                Loc    : constant Source_Ptr := Sloc (N);
 280                D_Fun  : constant Entity_Id := Corresponding_Spec  (Parent_P);
 281                Formal : constant Entity_Id := First_Formal (D_Fun);
 282                New_N  : Node_Id;
 283                Disc   : Entity_Id;
 284
 285             begin
 286                --  Verify that we are within the body of an entry or protected
 287                --  operation. Its first formal parameter is the synchronized
 288                --  type itself.
 289
 290                if Present (Formal)
 291                  and then Etype (Formal) = Scope (Entity (N))
 292                then
 293                   Disc := CR_Discriminant (Entity (N));
 294
 295                   New_N :=
 296                     Make_Selected_Component (Loc,
 297                       Prefix => New_Occurrence_Of (Formal, Loc),
 298                       Selector_Name => New_Occurrence_Of (Disc, Loc));
 299
 300                   Set_Etype (New_N, Etype (N));
 301                   Rewrite (N, New_N);
 302
 303                else
 304                   Set_Entity (N, Discriminal (Entity (N)));
 305                end if;
 306             end;
 307
 308          elsif Nkind (Parent (N)) = N_Range
 309            and then In_Entry
 310          then
 311             Set_Entity (N, CR_Discriminant (Entity (N)));
 312
 313             --  Finally, if the entity is the discriminant of the original
 314             --  type declaration, and we are within the initialization
 315             --  procedure for a task, the designated entity is the
 316             --  discriminal of the task body. This can happen when the
 317             --  argument of pragma Task_Name mentions a discriminant,
 318             --  because the pragma is analyzed in the task declaration
 319             --  but is expanded in the call to Create_Task in the init_proc.
 320
 321          elsif Within_Init_Proc then
 322             Set_Entity (N, Discriminal (CR_Discriminant (Entity (N))));
 323          else
 324             Set_Entity (N, Discriminal (Entity (N)));
 325          end if;
 326
 327       else
 328          Set_Entity (N, Discriminal (Entity (N)));
 329       end if;
 330    end Expand_Discriminant;
 331
 332    -----------------------------
 333    -- Expand_Entity_Reference --
 334    -----------------------------
 335
 336    procedure Expand_Entity_Reference (N : Node_Id) is
 337       E : constant Entity_Id := Entity (N);
 338
 339    begin
 340       --  Defend against errors
 341
 342       if No (E) then
 343          Check_Error_Detected;
 344          return;
 345       end if;
 346
 347       if Ekind (E) = E_Discriminant then
 348          Expand_Discriminant (N);
 349
 350       elsif Is_Entry_Formal (E) then
 351          Expand_Entry_Parameter (N);
 352
 353       elsif Is_Protected_Component (E) then
 354          if No_Run_Time_Mode then
 355             return;
 356          else
 357             Expand_Protected_Component (N);
 358          end if;
 359
 360       elsif Ekind (E) = E_Entry_Index_Parameter then
 361          Expand_Entry_Index_Parameter (N);
 362
 363       elsif Is_Formal (E) then
 364          Expand_Formal (N);
 365
 366       elsif Is_Renaming_Of_Object (E) then
 367          Expand_Renaming (N);
 368
 369       elsif Ekind (E) = E_Variable
 370         and then Is_Shared_Passive (E)
 371       then
 372          Expand_Shared_Passive_Variable (N);
 373       end if;
 374
 375       --  Test code for implementing the pragma Reviewable requirement of
 376       --  classifying reads of scalars as referencing potentially uninitialized
 377       --  objects or not.
 378
 379       if Debug_Flag_XX
 380         and then Is_Scalar_Type (Etype (N))
 381         and then (Is_Assignable (E) or else Is_Constant_Object (E))
 382         and then Comes_From_Source (N)
 383         and then not Is_LHS (N)
 384         and then not Is_Actual_Out_Parameter (N)
 385         and then (Nkind (Parent (N)) /= N_Attribute_Reference
 386                    or else Attribute_Name (Parent (N)) /= Name_Valid)
 387       then
 388          Write_Location (Sloc (N));
 389          Write_Str (": Read from scalar """);
 390          Write_Name (Chars (N));
 391          Write_Str ("""");
 392
 393          if Is_Known_Valid (E) then
 394             Write_Str (", Is_Known_Valid");
 395          end if;
 396
 397          Write_Eol;
 398       end if;
 399
 400       --  Set Atomic_Sync_Required if necessary for atomic variable
 401
 402       if Nkind_In (N, N_Identifier, N_Expanded_Name)
 403         and then Ekind (E) = E_Variable
 404         and then (Is_Atomic (E) or else Is_Atomic (Etype (E)))
 405       then
 406          declare
 407             Set  : Boolean;
 408
 409          begin
 410             --  If variable is atomic, but type is not, setting depends on
 411             --  disable/enable state for the variable.
 412
 413             if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
 414                Set := not Atomic_Synchronization_Disabled (E);
 415
 416             --  If variable is not atomic, but its type is atomic, setting
 417             --  depends on disable/enable state for the type.
 418
 419             elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
 420                Set := not Atomic_Synchronization_Disabled (Etype (E));
 421
 422             --  Else both variable and type are atomic (see outer if), and we
 423             --  disable if either variable or its type have sync disabled.
 424
 425             else
 426                Set := (not Atomic_Synchronization_Disabled (E))
 427                         and then
 428                       (not Atomic_Synchronization_Disabled (Etype (E)));
 429             end if;
 430
 431             --  Set flag if required
 432
 433             if Set then
 434                Activate_Atomic_Synchronization (N);
 435             end if;
 436          end;
 437       end if;
 438
 439       --  Interpret possible Current_Value for variable case
 440
 441       if Is_Assignable (E)
 442         and then Present (Current_Value (E))
 443       then
 444          Expand_Current_Value (N);
 445
 446          --  We do want to warn for the case of a boolean variable (not a
 447          --  boolean constant) whose value is known at compile time.
 448
 449          if Is_Boolean_Type (Etype (N)) then
 450             Warn_On_Known_Condition (N);
 451          end if;
 452
 453       --  Don't mess with Current_Value for compile time known values. Not
 454       --  only is it unnecessary, but we could disturb an indication of a
 455       --  static value, which could cause semantic trouble.
 456
 457       elsif Compile_Time_Known_Value (N) then
 458          null;
 459
 460       --  Interpret possible Current_Value for constant case
 461
 462       elsif Is_Constant_Object (E)
 463         and then Present (Current_Value (E))
 464       then
 465          Expand_Current_Value (N);
 466       end if;
 467    end Expand_Entity_Reference;
 468
 469    ----------------------------------
 470    -- Expand_Entry_Index_Parameter --
 471    ----------------------------------
 472
 473    procedure Expand_Entry_Index_Parameter (N : Node_Id) is
 474       Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
 475    begin
 476       Set_Entity (N, Index_Con);
 477       Set_Etype  (N, Etype (Index_Con));
 478    end Expand_Entry_Index_Parameter;
 479
 480    ----------------------------
 481    -- Expand_Entry_Parameter --
 482    ----------------------------
 483
 484    procedure Expand_Entry_Parameter (N : Node_Id) is
 485       Loc        : constant Source_Ptr := Sloc (N);
 486       Ent_Formal : constant Entity_Id  := Entity (N);
 487       Ent_Spec   : constant Entity_Id  := Scope (Ent_Formal);
 488       Parm_Type  : constant Entity_Id  := Entry_Parameters_Type (Ent_Spec);
 489       Acc_Stack  : constant Elist_Id   := Accept_Address (Ent_Spec);
 490       Addr_Ent   : constant Entity_Id  := Node (Last_Elmt (Acc_Stack));
 491       P_Comp_Ref : Entity_Id;
 492
 493       function In_Assignment_Context (N : Node_Id) return Boolean;
 494       --  Check whether this is a context in which the entry formal may be
 495       --  assigned to.
 496
 497       ---------------------------
 498       -- In_Assignment_Context --
 499       ---------------------------
 500
 501       function In_Assignment_Context (N : Node_Id) return Boolean is
 502       begin
 503          --  Case of use in a call
 504
 505          --  ??? passing a formal as actual for a mode IN formal is
 506          --  considered as an assignment?
 507
 508          if Nkind_In (Parent (N), N_Procedure_Call_Statement,
 509                                   N_Entry_Call_Statement)
 510            or else (Nkind (Parent (N)) = N_Assignment_Statement
 511                       and then N = Name (Parent (N)))
 512          then
 513             return True;
 514
 515          --  Case of a parameter association: climb up to enclosing call
 516
 517          elsif Nkind (Parent (N)) = N_Parameter_Association then
 518             return In_Assignment_Context (Parent (N));
 519
 520          --  Case of a selected component, indexed component or slice prefix:
 521          --  climb up the tree, unless the prefix is of an access type (in
 522          --  which case there is an implicit dereference, and the formal itself
 523          --  is not being assigned to).
 524
 525          elsif Nkind_In (Parent (N), N_Selected_Component,
 526                                      N_Indexed_Component,
 527                                      N_Slice)
 528            and then N = Prefix (Parent (N))
 529            and then not Is_Access_Type (Etype (N))
 530            and then In_Assignment_Context (Parent (N))
 531          then
 532             return True;
 533
 534          else
 535             return False;
 536          end if;
 537       end In_Assignment_Context;
 538
 539    --  Start of processing for Expand_Entry_Parameter
 540
 541    begin
 542       if Is_Task_Type (Scope (Ent_Spec))
 543         and then Comes_From_Source (Ent_Formal)
 544       then
 545          --  Before replacing the formal with the local renaming that is used
 546          --  in the accept block, note if this is an assignment context, and
 547          --  note the modification to avoid spurious warnings, because the
 548          --  original entity is not used further. If formal is unconstrained,
 549          --  we also generate an extra parameter to hold the Constrained
 550          --  attribute of the actual. No renaming is generated for this flag.
 551
 552          --  Calling Note_Possible_Modification in the expander is dubious,
 553          --  because this generates a cross-reference entry, and should be
 554          --  done during semantic processing so it is called in -gnatc mode???
 555
 556          if Ekind (Entity (N)) /= E_In_Parameter
 557            and then In_Assignment_Context (N)
 558          then
 559             Note_Possible_Modification (N, Sure => True);
 560          end if;
 561       end if;
 562
 563       --  What we need is a reference to the corresponding component of the
 564       --  parameter record object. The Accept_Address field of the entry entity
 565       --  references the address variable that contains the address of the
 566       --  accept parameters record. We first have to do an unchecked conversion
 567       --  to turn this into a pointer to the parameter record and then we
 568       --  select the required parameter field.
 569
 570       --  The same processing applies to protected entries, where the Accept_
 571       --  Address is also the address of the Parameters record.
 572
 573       P_Comp_Ref :=
 574         Make_Selected_Component (Loc,
 575           Prefix =>
 576             Make_Explicit_Dereference (Loc,
 577               Unchecked_Convert_To (Parm_Type,
 578                 New_Reference_To (Addr_Ent, Loc))),
 579           Selector_Name =>
 580             New_Reference_To (Entry_Component (Ent_Formal), Loc));
 581
 582       --  For all types of parameters, the constructed parameter record object
 583       --  contains a pointer to the parameter. Thus we must dereference them to
 584       --  access them (this will often be redundant, since the dereference is
 585       --  implicit, but no harm is done by making it explicit).
 586
 587       Rewrite (N,
 588         Make_Explicit_Dereference (Loc, P_Comp_Ref));
 589
 590       Analyze (N);
 591    end Expand_Entry_Parameter;
 592
 593    -------------------
 594    -- Expand_Formal --
 595    -------------------
 596
 597    procedure Expand_Formal (N : Node_Id) is
 598       E    : constant Entity_Id  := Entity (N);
 599       Scop : constant Entity_Id  := Scope (E);
 600
 601    begin
 602       --  Check whether the subprogram of which this is a formal is
 603       --  a protected operation. The initialization procedure for
 604       --  the corresponding record type is not itself a protected operation.
 605
 606       if Is_Protected_Type (Scope (Scop))
 607         and then not Is_Init_Proc (Scop)
 608         and then Present (Protected_Formal (E))
 609       then
 610          Set_Entity (N, Protected_Formal (E));
 611       end if;
 612    end Expand_Formal;
 613
 614    ----------------------------
 615    -- Expand_N_Expanded_Name --
 616    ----------------------------
 617
 618    procedure Expand_N_Expanded_Name (N : Node_Id) is
 619    begin
 620       Expand_Entity_Reference (N);
 621    end Expand_N_Expanded_Name;
 622
 623    -------------------------
 624    -- Expand_N_Identifier --
 625    -------------------------
 626
 627    procedure Expand_N_Identifier (N : Node_Id) is
 628    begin
 629       Expand_Entity_Reference (N);
 630    end Expand_N_Identifier;
 631
 632    ---------------------------
 633    -- Expand_N_Real_Literal --
 634    ---------------------------
 635
 636    procedure Expand_N_Real_Literal (N : Node_Id) is
 637       pragma Unreferenced (N);
 638
 639    begin
 640       --  Historically, this routine existed because there were expansion
 641       --  requirements for Vax real literals, but now Vax real literals
 642       --  are now handled by gigi, so this routine no longer does anything.
 643
 644       null;
 645    end Expand_N_Real_Literal;
 646
 647    --------------------------------
 648    -- Expand_Protected_Component --
 649    --------------------------------
 650
 651    procedure Expand_Protected_Component (N : Node_Id) is
 652
 653       function Inside_Eliminated_Body return Boolean;
 654       --  Determine whether the current entity is inside a subprogram or an
 655       --  entry which has been marked as eliminated.
 656
 657       ----------------------------
 658       -- Inside_Eliminated_Body --
 659       ----------------------------
 660
 661       function Inside_Eliminated_Body return Boolean is
 662          S : Entity_Id := Current_Scope;
 663
 664       begin
 665          while Present (S) loop
 666             if (Ekind (S) = E_Entry
 667                   or else Ekind (S) = E_Entry_Family
 668                   or else Ekind (S) = E_Function
 669                   or else Ekind (S) = E_Procedure)
 670               and then Is_Eliminated (S)
 671             then
 672                return True;
 673             end if;
 674
 675             S := Scope (S);
 676          end loop;
 677
 678          return False;
 679       end Inside_Eliminated_Body;
 680
 681    --  Start of processing for Expand_Protected_Component
 682
 683    begin
 684       --  Eliminated bodies are not expanded and thus do not need privals
 685
 686       if not Inside_Eliminated_Body then
 687          declare
 688             Priv : constant Entity_Id := Prival (Entity (N));
 689          begin
 690             Set_Entity (N, Priv);
 691             Set_Etype  (N, Etype (Priv));
 692          end;
 693       end if;
 694    end Expand_Protected_Component;
 695
 696    ---------------------
 697    -- Expand_Renaming --
 698    ---------------------
 699
 700    procedure Expand_Renaming (N : Node_Id) is
 701       E : constant Entity_Id := Entity (N);
 702       T : constant Entity_Id := Etype (N);
 703
 704    begin
 705       Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
 706
 707       --  We mark the copy as unanalyzed, so that it is sure to be reanalyzed
 708       --  at the top level. This is needed in the packed case since we
 709       --  specifically avoided expanding packed array references when the
 710       --  renaming declaration was analyzed.
 711
 712       Reset_Analyzed_Flags (N);
 713       Analyze_And_Resolve (N, T);
 714    end Expand_Renaming;
 715
 716    ------------------
 717    -- Param_Entity --
 718    ------------------
 719
 720    --  This would be trivial, simply a test for an identifier that was a
 721    --  reference to a formal, if it were not for the fact that a previous call
 722    --  to Expand_Entry_Parameter will have modified the reference to the
 723    --  identifier. A formal of a protected entity is rewritten as
 724
 725    --    typ!(recobj).rec.all'Constrained
 726
 727    --  where rec is a selector whose Entry_Formal link points to the formal
 728
 729    --  If the type of the entry parameter has a representation clause, then an
 730    --  extra temp is involved (see below).
 731
 732    --  For a formal of a task entity, the formal is rewritten as a local
 733    --  renaming.
 734
 735    --  In addition, a formal that is marked volatile because it is aliased
 736    --  through an address clause is rewritten as dereference as well.
 737
 738    function Param_Entity (N : Node_Id) return Entity_Id is
 739       Renamed_Obj : Node_Id;
 740
 741    begin
 742       --  Simple reference case
 743
 744       if Nkind_In (N, N_Identifier, N_Expanded_Name) then
 745          if Is_Formal (Entity (N)) then
 746             return Entity (N);
 747
 748          --  Handle renamings of formal parameters and formals of tasks that
 749          --  are rewritten as renamings.
 750
 751          elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
 752             Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
 753
 754             if Is_Entity_Name (Renamed_Obj)
 755               and then Is_Formal (Entity (Renamed_Obj))
 756             then
 757                return Entity (Renamed_Obj);
 758
 759             elsif
 760               Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
 761             then
 762                return Entity (N);
 763             end if;
 764          end if;
 765
 766       else
 767          if Nkind (N) = N_Explicit_Dereference then
 768             declare
 769                P    : Node_Id := Prefix (N);
 770                S    : Node_Id;
 771                E    : Entity_Id;
 772                Decl : Node_Id;
 773
 774             begin
 775                --  If the type of an entry parameter has a representation
 776                --  clause, then the prefix is not a selected component, but
 777                --  instead a reference to a temp pointing at the selected
 778                --  component. In this case, set P to be the initial value of
 779                --  that temp.
 780
 781                if Nkind (P) = N_Identifier then
 782                   E := Entity (P);
 783
 784                   if Ekind (E) = E_Constant then
 785                      Decl := Parent (E);
 786
 787                      if Nkind (Decl) = N_Object_Declaration then
 788                         P := Expression (Decl);
 789                      end if;
 790                   end if;
 791                end if;
 792
 793                if Nkind (P) = N_Selected_Component then
 794                   S := Selector_Name (P);
 795
 796                   if Present (Entry_Formal (Entity (S))) then
 797                      return Entry_Formal (Entity (S));
 798                   end if;
 799
 800                elsif Nkind (Original_Node (N)) = N_Identifier then
 801                   return Param_Entity (Original_Node (N));
 802                end if;
 803             end;
 804          end if;
 805       end if;
 806
 807       return (Empty);
 808    end Param_Entity;
 809
 810 end Exp_Ch2;