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