gcc/ada/exp_util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ U T I L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Ch11; use Exp_Ch11;
  34 with Exp_Tss;  use Exp_Tss;
  35 with Hostparm; use Hostparm;
  36 with Inline;   use Inline;
  37 with Itypes;   use Itypes;
  38 with Lib;      use Lib;
  39 with Namet;    use Namet;
  40 with Nlists;   use Nlists;
  41 with Nmake;    use Nmake;
  42 with Opt;      use Opt;
  43 with Restrict; use Restrict;
  44 with Rident;   use Rident;
  45 with Sem;      use Sem;
  46 with Sem_Ch8;  use Sem_Ch8;
  47 with Sem_Eval; use Sem_Eval;
  48 with Sem_Res;  use Sem_Res;
  49 with Sem_Util; use Sem_Util;
  50 with Sinfo;    use Sinfo;
  51 with Snames;   use Snames;
  52 with Stand;    use Stand;
  53 with Stringt;  use Stringt;
  54 with Targparm; use Targparm;
  55 with Tbuild;   use Tbuild;
  56 with Ttypes;   use Ttypes;
  57 with Uintp;    use Uintp;
  58 with Urealp;   use Urealp;
  59 with Validsw;  use Validsw;
  60
  61 package body Exp_Util is
  62
  63    -----------------------
  64    -- Local Subprograms --
  65    -----------------------
  66
  67    function Build_Task_Array_Image
  68      (Loc    : Source_Ptr;
  69       Id_Ref : Node_Id;
  70       A_Type : Entity_Id;
  71       Dyn    : Boolean := False)
  72       return   Node_Id;
  73    --  Build function to generate the image string for a task that is an
  74    --  array component, concatenating the images of each index. To avoid
  75    --  storage leaks, the string is built with successive slice assignments.
  76    --  The flag Dyn indicates whether this is called for the initialization
  77    --  procedure of an array of tasks, or for the name of a dynamically
  78    --  created task that is assigned to an indexed component.
  79
  80    function Build_Task_Image_Function
  81      (Loc   : Source_Ptr;
  82       Decls : List_Id;
  83       Stats : List_Id;
  84       Res   : Entity_Id)
  85       return  Node_Id;
  86    --  Common processing for Task_Array_Image and Task_Record_Image.
  87    --  Build function body that computes image.
  88
  89    procedure Build_Task_Image_Prefix
  90       (Loc    : Source_Ptr;
  91        Len    : out Entity_Id;
  92        Res    : out Entity_Id;
  93        Pos    : out Entity_Id;
  94        Prefix : Entity_Id;
  95        Sum    : Node_Id;
  96        Decls  : in out List_Id;
  97        Stats  : in out List_Id);
  98    --  Common processing for Task_Array_Image and Task_Record_Image.
  99    --  Create local variables and assign prefix of name to result string.
 100
 101    function Build_Task_Record_Image
 102      (Loc    : Source_Ptr;
 103       Id_Ref : Node_Id;
 104       Dyn    : Boolean := False)
 105       return   Node_Id;
 106    --  Build function to generate the image string for a task that is a
 107    --  record component. Concatenate name of variable with that of selector.
 108    --  The flag Dyn indicates whether this is called for the initialization
 109    --  procedure of record with task components, or for a dynamically
 110    --  created task that is assigned to a selected component.
 111
 112    function Make_CW_Equivalent_Type
 113      (T    : Entity_Id;
 114       E    : Node_Id)
 115       return Entity_Id;
 116    --  T is a class-wide type entity, E is the initial expression node that
 117    --  constrains T in case such as: " X: T := E" or "new T'(E)"
 118    --  This function returns the entity of the Equivalent type and inserts
 119    --  on the fly the necessary declaration such as:
 120    --
 121    --    type anon is record
 122    --       _parent : Root_Type (T); constrained with E discriminants (if any)
 123    --       Extension : String (1 .. expr to match size of E);
 124    --    end record;
 125    --
 126    --  This record is compatible with any object of the class of T thanks
 127    --  to the first field and has the same size as E thanks to the second.
 128
 129    function Make_Literal_Range
 130      (Loc         : Source_Ptr;
 131       Literal_Typ : Entity_Id)
 132       return        Node_Id;
 133    --  Produce a Range node whose bounds are:
 134    --    Low_Bound (Literal_Type) ..
 135    --        Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
 136    --  this is used for expanding declarations like X : String := "sdfgdfg";
 137
 138    function New_Class_Wide_Subtype
 139      (CW_Typ : Entity_Id;
 140       N      : Node_Id)
 141       return   Entity_Id;
 142    --  Create an implicit subtype of CW_Typ attached to node N.
 143
 144    ----------------------
 145    -- Adjust_Condition --
 146    ----------------------
 147
 148    procedure Adjust_Condition (N : Node_Id) is
 149    begin
 150       if No (N) then
 151          return;
 152       end if;
 153
 154       declare
 155          Loc : constant Source_Ptr := Sloc (N);
 156          T   : constant Entity_Id  := Etype (N);
 157          Ti  : Entity_Id;
 158
 159       begin
 160          --  For now, we simply ignore a call where the argument has no
 161          --  type (probably case of unanalyzed condition), or has a type
 162          --  that is not Boolean. This is because this is a pretty marginal
 163          --  piece of functionality, and violations of these rules are
 164          --  likely to be truly marginal (how much code uses Fortran Logical
 165          --  as the barrier to a protected entry?) and we do not want to
 166          --  blow up existing programs. We can change this to an assertion
 167          --  after 3.12a is released ???
 168
 169          if No (T) or else not Is_Boolean_Type (T) then
 170             return;
 171          end if;
 172
 173          --  Apply validity checking if needed
 174
 175          if Validity_Checks_On and Validity_Check_Tests then
 176             Ensure_Valid (N);
 177          end if;
 178
 179          --  Immediate return if standard boolean, the most common case,
 180          --  where nothing needs to be done.
 181
 182          if Base_Type (T) = Standard_Boolean then
 183             return;
 184          end if;
 185
 186          --  Case of zero/non-zero semantics or non-standard enumeration
 187          --  representation. In each case, we rewrite the node as:
 188
 189          --      ityp!(N) /= False'Enum_Rep
 190
 191          --  where ityp is an integer type with large enough size to hold
 192          --  any value of type T.
 193
 194          if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
 195             if Esize (T) <= Esize (Standard_Integer) then
 196                Ti := Standard_Integer;
 197             else
 198                Ti := Standard_Long_Long_Integer;
 199             end if;
 200
 201             Rewrite (N,
 202               Make_Op_Ne (Loc,
 203                 Left_Opnd  => Unchecked_Convert_To (Ti, N),
 204                 Right_Opnd =>
 205                   Make_Attribute_Reference (Loc,
 206                     Attribute_Name => Name_Enum_Rep,
 207                     Prefix         =>
 208                       New_Occurrence_Of (First_Literal (T), Loc))));
 209             Analyze_And_Resolve (N, Standard_Boolean);
 210
 211          else
 212             Rewrite (N, Convert_To (Standard_Boolean, N));
 213             Analyze_And_Resolve (N, Standard_Boolean);
 214          end if;
 215       end;
 216    end Adjust_Condition;
 217
 218    ------------------------
 219    -- Adjust_Result_Type --
 220    ------------------------
 221
 222    procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
 223    begin
 224       --  Ignore call if current type is not Standard.Boolean
 225
 226       if Etype (N) /= Standard_Boolean then
 227          return;
 228       end if;
 229
 230       --  If result is already of correct type, nothing to do. Note that
 231       --  this will get the most common case where everything has a type
 232       --  of Standard.Boolean.
 233
 234       if Base_Type (T) = Standard_Boolean then
 235          return;
 236
 237       else
 238          declare
 239             KP : constant Node_Kind := Nkind (Parent (N));
 240
 241          begin
 242             --  If result is to be used as a Condition in the syntax, no need
 243             --  to convert it back, since if it was changed to Standard.Boolean
 244             --  using Adjust_Condition, that is just fine for this usage.
 245
 246             if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
 247                return;
 248
 249             --  If result is an operand of another logical operation, no need
 250             --  to reset its type, since Standard.Boolean is just fine, and
 251             --  such operations always do Adjust_Condition on their operands.
 252
 253             elsif KP in N_Op_Boolean
 254               or else KP = N_And_Then
 255               or else KP = N_Or_Else
 256               or else KP = N_Op_Not
 257             then
 258                return;
 259
 260             --  Otherwise we perform a conversion from the current type,
 261             --  which must be Standard.Boolean, to the desired type.
 262
 263             else
 264                Set_Analyzed (N);
 265                Rewrite (N, Convert_To (T, N));
 266                Analyze_And_Resolve (N, T);
 267             end if;
 268          end;
 269       end if;
 270    end Adjust_Result_Type;
 271
 272    --------------------------
 273    -- Append_Freeze_Action --
 274    --------------------------
 275
 276    procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
 277       Fnode : Node_Id := Freeze_Node (T);
 278
 279    begin
 280       Ensure_Freeze_Node (T);
 281       Fnode := Freeze_Node (T);
 282
 283       if not Present (Actions (Fnode)) then
 284          Set_Actions (Fnode, New_List);
 285       end if;
 286
 287       Append (N, Actions (Fnode));
 288    end Append_Freeze_Action;
 289
 290    ---------------------------
 291    -- Append_Freeze_Actions --
 292    ---------------------------
 293
 294    procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
 295       Fnode : constant Node_Id := Freeze_Node (T);
 296
 297    begin
 298       if No (L) then
 299          return;
 300
 301       else
 302          if No (Actions (Fnode)) then
 303             Set_Actions (Fnode, L);
 304
 305          else
 306             Append_List (L, Actions (Fnode));
 307          end if;
 308
 309       end if;
 310    end Append_Freeze_Actions;
 311
 312    ------------------------
 313    -- Build_Runtime_Call --
 314    ------------------------
 315
 316    function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
 317    begin
 318       --  If entity is not available, we can skip making the call (this avoids
 319       --  junk duplicated error messages in a number of cases).
 320
 321       if not RTE_Available (RE) then
 322          return Make_Null_Statement (Loc);
 323       else
 324          return
 325            Make_Procedure_Call_Statement (Loc,
 326              Name => New_Reference_To (RTE (RE), Loc));
 327       end if;
 328    end Build_Runtime_Call;
 329
 330    ----------------------------
 331    -- Build_Task_Array_Image --
 332    ----------------------------
 333
 334    --  This function generates the body for a function that constructs the
 335    --  image string for a task that is an array component. The function is
 336    --  local to the init proc for the array type, and is called for each one
 337    --  of the components. The constructed image has the form of an indexed
 338    --  component, whose prefix is the outer variable of the array type.
 339    --  The n-dimensional array type has known indices Index, Index2...
 340    --  Id_Ref is an indexed component form created by the enclosing init proc.
 341    --  Its successive indices are Val1, Val2,.. which are the loop variables
 342    --  in the loops that call the individual task init proc on each component.
 343
 344    --  The generated function has the following structure:
 345
 346    --  function F return String is
 347    --     Pref : string renames Task_Name;
 348    --     T1   : String := Index1'Image (Val1);
 349    --     ...
 350    --     Tn   : String := indexn'image (Valn);
 351    --     Len  : Integer := T1'Length + ... + Tn'Length + n + 1;
 352    --     --  Len includes commas and the end parentheses.
 353    --     Res  : String (1..Len);
 354    --     Pos  : Integer := Pref'Length;
 355    --
 356    --  begin
 357    --     Res (1 .. Pos) := Pref;
 358    --     Pos := Pos + 1;
 359    --     Res (Pos)    := '(';
 360    --     Pos := Pos + 1;
 361    --     Res (Pos .. Pos + T1'Length - 1) := T1;
 362    --     Pos := Pos + T1'Length;
 363    --     Res (Pos) := '.';
 364    --     Pos := Pos + 1;
 365    --     ...
 366    --     Res (Pos .. Pos + Tn'Length - 1) := Tn;
 367    --     Res (Len) := ')';
 368    --
 369    --     return Res;
 370    --  end F;
 371    --
 372    --  Needless to say, multidimensional arrays of tasks are rare enough
 373    --  that the bulkiness of this code is not really a concern.
 374
 375    function Build_Task_Array_Image
 376      (Loc    : Source_Ptr;
 377       Id_Ref : Node_Id;
 378       A_Type : Entity_Id;
 379       Dyn    : Boolean := False)
 380       return   Node_Id
 381    is
 382       Dims : constant Nat := Number_Dimensions (A_Type);
 383       --  Number of dimensions for array of tasks.
 384
 385       Temps : array (1 .. Dims) of Entity_Id;
 386       --  Array of temporaries to hold string for each index.
 387
 388       Indx : Node_Id;
 389       --  Index expression
 390
 391       Len : Entity_Id;
 392       --  Total length of generated name
 393
 394       Pos : Entity_Id;
 395       --  Running index for substring assignments
 396
 397       Pref : Entity_Id;
 398       --  Name of enclosing variable, prefix of resulting name
 399
 400       Res : Entity_Id;
 401       --  String to hold result
 402
 403       Val : Node_Id;
 404       --  Value of successive indices
 405
 406       Sum : Node_Id;
 407       --  Expression to compute total size of string
 408
 409       T : Entity_Id;
 410       --  Entity for name at one index position
 411
 412       Decls : List_Id := New_List;
 413       Stats : List_Id := New_List;
 414
 415    begin
 416       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 417
 418       --  For a dynamic task, the name comes from the target variable.
 419       --  For a static one it is a formal of the enclosing init proc.
 420
 421       if Dyn then
 422          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
 423          Append_To (Decls,
 424            Make_Object_Declaration (Loc,
 425              Defining_Identifier => Pref,
 426              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 427              Expression =>
 428                Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
 429
 430       else
 431          Append_To (Decls,
 432            Make_Object_Renaming_Declaration (Loc,
 433              Defining_Identifier => Pref,
 434              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
 435              Name                => Make_Identifier (Loc, Name_uTask_Name)));
 436       end if;
 437
 438       Indx := First_Index (A_Type);
 439       Val  := First (Expressions (Id_Ref));
 440
 441       for J in 1 .. Dims loop
 442          T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
 443          Temps (J) := T;
 444
 445          Append_To (Decls,
 446             Make_Object_Declaration (Loc,
 447                Defining_Identifier => T,
 448                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 449                Expression =>
 450                  Make_Attribute_Reference (Loc,
 451                    Attribute_Name => Name_Image,
 452                    Prefix =>
 453                      New_Occurrence_Of (Etype (Indx), Loc),
 454                    Expressions => New_List (
 455                      New_Copy_Tree (Val)))));
 456
 457          Next_Index (Indx);
 458          Next (Val);
 459       end loop;
 460
 461       Sum := Make_Integer_Literal (Loc, Dims + 1);
 462
 463       Sum :=
 464         Make_Op_Add (Loc,
 465           Left_Opnd => Sum,
 466           Right_Opnd =>
 467            Make_Attribute_Reference (Loc,
 468              Attribute_Name => Name_Length,
 469              Prefix =>
 470                New_Occurrence_Of (Pref, Loc),
 471              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 472
 473       for J in 1 .. Dims loop
 474          Sum :=
 475             Make_Op_Add (Loc,
 476              Left_Opnd => Sum,
 477              Right_Opnd =>
 478               Make_Attribute_Reference (Loc,
 479                 Attribute_Name => Name_Length,
 480                 Prefix =>
 481                   New_Occurrence_Of (Temps (J), Loc),
 482                 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 483       end loop;
 484
 485       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
 486
 487       Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
 488
 489       Append_To (Stats,
 490          Make_Assignment_Statement (Loc,
 491            Name => Make_Indexed_Component (Loc,
 492               Prefix => New_Occurrence_Of (Res, Loc),
 493               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 494            Expression =>
 495              Make_Character_Literal (Loc,
 496                Chars => Name_Find,
 497                Char_Literal_Value =>
 498                  Char_Code (Character'Pos ('(')))));
 499
 500       Append_To (Stats,
 501          Make_Assignment_Statement (Loc,
 502             Name => New_Occurrence_Of (Pos, Loc),
 503             Expression =>
 504               Make_Op_Add (Loc,
 505                 Left_Opnd => New_Occurrence_Of (Pos, Loc),
 506                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
 507
 508       for J in 1 .. Dims loop
 509
 510          Append_To (Stats,
 511             Make_Assignment_Statement (Loc,
 512               Name => Make_Slice (Loc,
 513                  Prefix => New_Occurrence_Of (Res, Loc),
 514                  Discrete_Range  =>
 515                    Make_Range (Loc,
 516                       Low_Bound => New_Occurrence_Of  (Pos, Loc),
 517                       High_Bound => Make_Op_Subtract (Loc,
 518                         Left_Opnd =>
 519                           Make_Op_Add (Loc,
 520                             Left_Opnd => New_Occurrence_Of (Pos, Loc),
 521                             Right_Opnd =>
 522                               Make_Attribute_Reference (Loc,
 523                                 Attribute_Name => Name_Length,
 524                                 Prefix =>
 525                                   New_Occurrence_Of (Temps (J), Loc),
 526                                 Expressions =>
 527                                   New_List (Make_Integer_Literal (Loc, 1)))),
 528                          Right_Opnd => Make_Integer_Literal (Loc, 1)))),
 529
 530               Expression => New_Occurrence_Of (Temps (J), Loc)));
 531
 532          if J < Dims then
 533             Append_To (Stats,
 534                Make_Assignment_Statement (Loc,
 535                   Name => New_Occurrence_Of (Pos, Loc),
 536                   Expression =>
 537                     Make_Op_Add (Loc,
 538                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
 539                       Right_Opnd =>
 540                         Make_Attribute_Reference (Loc,
 541                           Attribute_Name => Name_Length,
 542                             Prefix => New_Occurrence_Of (Temps (J), Loc),
 543                             Expressions =>
 544                               New_List (Make_Integer_Literal (Loc, 1))))));
 545
 546             Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
 547
 548             Append_To (Stats,
 549                Make_Assignment_Statement (Loc,
 550                  Name => Make_Indexed_Component (Loc,
 551                     Prefix => New_Occurrence_Of (Res, Loc),
 552                     Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 553                  Expression =>
 554                    Make_Character_Literal (Loc,
 555                      Chars => Name_Find,
 556                      Char_Literal_Value =>
 557                        Char_Code (Character'Pos (',')))));
 558
 559             Append_To (Stats,
 560               Make_Assignment_Statement (Loc,
 561                 Name => New_Occurrence_Of (Pos, Loc),
 562                   Expression =>
 563                     Make_Op_Add (Loc,
 564                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
 565                       Right_Opnd => Make_Integer_Literal (Loc, 1))));
 566          end if;
 567       end loop;
 568
 569       Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
 570
 571       Append_To (Stats,
 572          Make_Assignment_Statement (Loc,
 573            Name => Make_Indexed_Component (Loc,
 574               Prefix => New_Occurrence_Of (Res, Loc),
 575               Expressions => New_List (New_Occurrence_Of (Len, Loc))),
 576            Expression =>
 577              Make_Character_Literal (Loc,
 578                Chars => Name_Find,
 579                Char_Literal_Value =>
 580                  Char_Code (Character'Pos (')')))));
 581       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
 582    end Build_Task_Array_Image;
 583
 584    ----------------------------
 585    -- Build_Task_Image_Decls --
 586    ----------------------------
 587
 588    function Build_Task_Image_Decls
 589      (Loc    : Source_Ptr;
 590       Id_Ref : Node_Id;
 591       A_Type : Entity_Id)
 592       return   List_Id
 593    is
 594       Decls  : constant List_Id   := New_List;
 595       T_Id   : Entity_Id := Empty;
 596       Decl   : Node_Id;
 597       Expr   : Node_Id   := Empty;
 598       Fun    : Node_Id   := Empty;
 599       Is_Dyn : constant Boolean :=
 600                  Nkind (Parent (Id_Ref)) = N_Assignment_Statement
 601                    and then
 602                  Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
 603
 604    begin
 605       --  If Discard_Names or No_Implicit_Heap_Allocations are in effect,
 606       --  generate a dummy declaration only.
 607
 608       if Restriction_Active (No_Implicit_Heap_Allocations)
 609         or else Global_Discard_Names
 610       then
 611          T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 612          Name_Len := 0;
 613
 614          return
 615            New_List (
 616              Make_Object_Declaration (Loc,
 617                Defining_Identifier => T_Id,
 618                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 619                Expression =>
 620                  Make_String_Literal
 621                    (Loc, Strval => String_From_Name_Buffer)));
 622
 623       else
 624          if Nkind (Id_Ref) = N_Identifier
 625            or else Nkind (Id_Ref) = N_Defining_Identifier
 626          then
 627             --  For a simple variable, the image of the task is built from
 628             --  the name of the variable. To avoid possible conflict with
 629             --  the anonymous type created for a single protected object,
 630             --  add a numeric suffix.
 631
 632             T_Id :=
 633               Make_Defining_Identifier (Loc,
 634                 New_External_Name (Chars (Id_Ref), 'T', 1));
 635
 636             Get_Name_String (Chars (Id_Ref));
 637
 638             Expr := Make_String_Literal
 639               (Loc, Strval => String_From_Name_Buffer);
 640
 641          elsif Nkind (Id_Ref) = N_Selected_Component then
 642             T_Id :=
 643               Make_Defining_Identifier (Loc,
 644                 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
 645             Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
 646
 647          elsif Nkind (Id_Ref) = N_Indexed_Component then
 648             T_Id :=
 649               Make_Defining_Identifier (Loc,
 650                 New_External_Name (Chars (A_Type), 'N'));
 651
 652             Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
 653          end if;
 654       end if;
 655
 656       if Present (Fun) then
 657          Append (Fun, Decls);
 658          Expr := Make_Function_Call (Loc,
 659            Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
 660       end if;
 661
 662       Decl := Make_Object_Declaration (Loc,
 663         Defining_Identifier => T_Id,
 664         Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
 665         Constant_Present    => True,
 666         Expression          => Expr);
 667
 668       Append (Decl, Decls);
 669       return Decls;
 670    end Build_Task_Image_Decls;
 671
 672    -------------------------------
 673    -- Build_Task_Image_Function --
 674    -------------------------------
 675
 676    function Build_Task_Image_Function
 677      (Loc   : Source_Ptr;
 678       Decls : List_Id;
 679       Stats : List_Id;
 680       Res   : Entity_Id)
 681       return  Node_Id
 682    is
 683       Spec : Node_Id;
 684
 685    begin
 686       Append_To (Stats,
 687         Make_Return_Statement (Loc,
 688           Expression => New_Occurrence_Of (Res, Loc)));
 689
 690       Spec := Make_Function_Specification (Loc,
 691         Defining_Unit_Name =>
 692           Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
 693         Subtype_Mark => New_Occurrence_Of (Standard_String, Loc));
 694
 695       --  Calls to 'Image use the secondary stack, which must be cleaned
 696       --  up after the task name is built.
 697
 698       Set_Uses_Sec_Stack (Defining_Unit_Name (Spec));
 699
 700       return Make_Subprogram_Body (Loc,
 701          Specification => Spec,
 702          Declarations => Decls,
 703          Handled_Statement_Sequence =>
 704            Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
 705    end Build_Task_Image_Function;
 706
 707    -----------------------------
 708    -- Build_Task_Image_Prefix --
 709    -----------------------------
 710
 711    procedure Build_Task_Image_Prefix
 712       (Loc    : Source_Ptr;
 713        Len    : out Entity_Id;
 714        Res    : out Entity_Id;
 715        Pos    : out Entity_Id;
 716        Prefix : Entity_Id;
 717        Sum    : Node_Id;
 718        Decls  : in out List_Id;
 719        Stats  : in out List_Id)
 720    is
 721    begin
 722       Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
 723
 724       Append_To (Decls,
 725         Make_Object_Declaration (Loc,
 726           Defining_Identifier => Len,
 727           Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
 728           Expression        => Sum));
 729
 730       Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
 731
 732       Append_To (Decls,
 733          Make_Object_Declaration (Loc,
 734             Defining_Identifier => Res,
 735             Object_Definition =>
 736                Make_Subtype_Indication (Loc,
 737                   Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
 738                Constraint =>
 739                  Make_Index_Or_Discriminant_Constraint (Loc,
 740                    Constraints =>
 741                      New_List (
 742                        Make_Range (Loc,
 743                          Low_Bound => Make_Integer_Literal (Loc, 1),
 744                          High_Bound => New_Occurrence_Of (Len, Loc)))))));
 745
 746       Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 747
 748       Append_To (Decls,
 749          Make_Object_Declaration (Loc,
 750             Defining_Identifier => Pos,
 751             Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
 752
 753       --  Pos := Prefix'Length;
 754
 755       Append_To (Stats,
 756          Make_Assignment_Statement (Loc,
 757             Name => New_Occurrence_Of (Pos, Loc),
 758             Expression =>
 759               Make_Attribute_Reference (Loc,
 760                 Attribute_Name => Name_Length,
 761                 Prefix => New_Occurrence_Of (Prefix, Loc),
 762                 Expressions =>
 763                     New_List (Make_Integer_Literal (Loc, 1)))));
 764
 765       --  Res (1 .. Pos) := Prefix;
 766
 767       Append_To (Stats,
 768          Make_Assignment_Statement (Loc,
 769            Name => Make_Slice (Loc,
 770               Prefix => New_Occurrence_Of (Res, Loc),
 771               Discrete_Range  =>
 772                 Make_Range (Loc,
 773                    Low_Bound => Make_Integer_Literal (Loc, 1),
 774                    High_Bound => New_Occurrence_Of (Pos, Loc))),
 775
 776            Expression => New_Occurrence_Of (Prefix, Loc)));
 777
 778       Append_To (Stats,
 779          Make_Assignment_Statement (Loc,
 780             Name => New_Occurrence_Of (Pos, Loc),
 781             Expression =>
 782               Make_Op_Add (Loc,
 783                 Left_Opnd => New_Occurrence_Of (Pos, Loc),
 784                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
 785    end Build_Task_Image_Prefix;
 786
 787    -----------------------------
 788    -- Build_Task_Record_Image --
 789    -----------------------------
 790
 791    function Build_Task_Record_Image
 792      (Loc    : Source_Ptr;
 793       Id_Ref : Node_Id;
 794       Dyn    : Boolean := False)
 795       return   Node_Id
 796    is
 797       Len : Entity_Id;
 798       --  Total length of generated name
 799
 800       Pos : Entity_Id;
 801       --  Index into result
 802
 803       Res : Entity_Id;
 804       --  String to hold result
 805
 806       Pref : Entity_Id;
 807       --  Name of enclosing variable, prefix of resulting name
 808
 809       Sum : Node_Id;
 810       --  Expression to compute total size of string.
 811
 812       Sel : Entity_Id;
 813       --  Entity for selector name
 814
 815       Decls : List_Id := New_List;
 816       Stats : List_Id := New_List;
 817
 818    begin
 819       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 820
 821       --  For a dynamic task, the name comes from the target variable.
 822       --  For a static one it is a formal of the enclosing init proc.
 823
 824       if Dyn then
 825          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
 826          Append_To (Decls,
 827            Make_Object_Declaration (Loc,
 828              Defining_Identifier => Pref,
 829              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 830              Expression =>
 831                Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
 832
 833       else
 834          Append_To (Decls,
 835            Make_Object_Renaming_Declaration (Loc,
 836              Defining_Identifier => Pref,
 837              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
 838              Name                => Make_Identifier (Loc, Name_uTask_Name)));
 839       end if;
 840
 841       Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 842
 843       Get_Name_String (Chars (Selector_Name (Id_Ref)));
 844
 845       Append_To (Decls,
 846          Make_Object_Declaration (Loc,
 847            Defining_Identifier => Sel,
 848            Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 849            Expression =>
 850               Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
 851
 852       Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
 853
 854       Sum :=
 855         Make_Op_Add (Loc,
 856           Left_Opnd => Sum,
 857           Right_Opnd =>
 858            Make_Attribute_Reference (Loc,
 859              Attribute_Name => Name_Length,
 860              Prefix =>
 861                New_Occurrence_Of (Pref, Loc),
 862              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 863
 864       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
 865
 866       Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
 867
 868       --  Res (Pos) := '.';
 869
 870       Append_To (Stats,
 871          Make_Assignment_Statement (Loc,
 872            Name => Make_Indexed_Component (Loc,
 873               Prefix => New_Occurrence_Of (Res, Loc),
 874               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 875            Expression =>
 876              Make_Character_Literal (Loc,
 877                Chars => Name_Find,
 878                Char_Literal_Value =>
 879                  Char_Code (Character'Pos ('.')))));
 880
 881       Append_To (Stats,
 882         Make_Assignment_Statement (Loc,
 883           Name => New_Occurrence_Of (Pos, Loc),
 884           Expression =>
 885             Make_Op_Add (Loc,
 886               Left_Opnd => New_Occurrence_Of (Pos, Loc),
 887               Right_Opnd => Make_Integer_Literal (Loc, 1))));
 888
 889       --  Res (Pos .. Len) := Selector;
 890
 891       Append_To (Stats,
 892         Make_Assignment_Statement (Loc,
 893           Name => Make_Slice (Loc,
 894              Prefix => New_Occurrence_Of (Res, Loc),
 895              Discrete_Range  =>
 896                Make_Range (Loc,
 897                  Low_Bound  => New_Occurrence_Of (Pos, Loc),
 898                  High_Bound => New_Occurrence_Of (Len, Loc))),
 899           Expression => New_Occurrence_Of (Sel, Loc)));
 900
 901       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
 902    end Build_Task_Record_Image;
 903
 904    ----------------------------------
 905    -- Component_May_Be_Bit_Aligned --
 906    ----------------------------------
 907
 908    function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
 909    begin
 910       --  If no component clause, then everything is fine, since the
 911       --  back end never bit-misaligns by default, even if there is
 912       --  a pragma Packed for the record.
 913
 914       if No (Component_Clause (Comp)) then
 915          return False;
 916       end if;
 917
 918       --  It is only array and record types that cause trouble
 919
 920       if not Is_Record_Type (Etype (Comp))
 921         and then not Is_Array_Type (Etype (Comp))
 922       then
 923          return False;
 924
 925       --  If we know that we have a small (64 bits or less) record
 926       --  or bit-packed array, then everything is fine, since the
 927       --  back end can handle these cases correctly.
 928
 929       elsif Esize (Comp) <= 64
 930         and then (Is_Record_Type (Etype (Comp))
 931                    or else Is_Bit_Packed_Array (Etype (Comp)))
 932       then
 933          return False;
 934
 935       --  Otherwise if the component is not byte aligned, we
 936       --  know we have the nasty unaligned case.
 937
 938       elsif Normalized_First_Bit (Comp) /= Uint_0
 939         or else Esize (Comp) mod System_Storage_Unit /= Uint_0
 940       then
 941          return True;
 942
 943       --  If we are large and byte aligned, then OK at this level
 944
 945       else
 946          return False;
 947       end if;
 948    end Component_May_Be_Bit_Aligned;
 949
 950    -------------------------------
 951    -- Convert_To_Actual_Subtype --
 952    -------------------------------
 953
 954    procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
 955       Act_ST : Entity_Id;
 956
 957    begin
 958       Act_ST := Get_Actual_Subtype (Exp);
 959
 960       if Act_ST = Etype (Exp) then
 961          return;
 962
 963       else
 964          Rewrite (Exp,
 965            Convert_To (Act_ST, Relocate_Node (Exp)));
 966          Analyze_And_Resolve (Exp, Act_ST);
 967       end if;
 968    end Convert_To_Actual_Subtype;
 969
 970    -----------------------------------
 971    -- Current_Sem_Unit_Declarations --
 972    -----------------------------------
 973
 974    function Current_Sem_Unit_Declarations return List_Id is
 975       U     : Node_Id := Unit (Cunit (Current_Sem_Unit));
 976       Decls : List_Id;
 977
 978    begin
 979       --  If the current unit is a package body, locate the visible
 980       --  declarations of the package spec.
 981
 982       if Nkind (U) = N_Package_Body then
 983          U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
 984       end if;
 985
 986       if Nkind (U) = N_Package_Declaration then
 987          U := Specification (U);
 988          Decls := Visible_Declarations (U);
 989
 990          if No (Decls) then
 991             Decls := New_List;
 992             Set_Visible_Declarations (U, Decls);
 993          end if;
 994
 995       else
 996          Decls := Declarations (U);
 997
 998          if No (Decls) then
 999             Decls := New_List;
1000             Set_Declarations (U, Decls);
1001          end if;
1002       end if;
1003
1004       return Decls;
1005    end Current_Sem_Unit_Declarations;
1006
1007    -----------------------
1008    -- Duplicate_Subexpr --
1009    -----------------------
1010
1011    function Duplicate_Subexpr
1012      (Exp      : Node_Id;
1013       Name_Req : Boolean := False)
1014       return     Node_Id
1015    is
1016    begin
1017       Remove_Side_Effects (Exp, Name_Req);
1018       return New_Copy_Tree (Exp);
1019    end Duplicate_Subexpr;
1020
1021    ---------------------------------
1022    -- Duplicate_Subexpr_No_Checks --
1023    ---------------------------------
1024
1025    function Duplicate_Subexpr_No_Checks
1026      (Exp      : Node_Id;
1027       Name_Req : Boolean := False)
1028       return     Node_Id
1029    is
1030       New_Exp : Node_Id;
1031
1032    begin
1033       Remove_Side_Effects (Exp, Name_Req);
1034       New_Exp := New_Copy_Tree (Exp);
1035       Remove_Checks (New_Exp);
1036       return New_Exp;
1037    end Duplicate_Subexpr_No_Checks;
1038
1039    -----------------------------------
1040    -- Duplicate_Subexpr_Move_Checks --
1041    -----------------------------------
1042
1043    function Duplicate_Subexpr_Move_Checks
1044      (Exp      : Node_Id;
1045       Name_Req : Boolean := False)
1046       return     Node_Id
1047    is
1048       New_Exp : Node_Id;
1049
1050    begin
1051       Remove_Side_Effects (Exp, Name_Req);
1052       New_Exp := New_Copy_Tree (Exp);
1053       Remove_Checks (Exp);
1054       return New_Exp;
1055    end Duplicate_Subexpr_Move_Checks;
1056
1057    --------------------
1058    -- Ensure_Defined --
1059    --------------------
1060
1061    procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1062       IR : Node_Id;
1063       P  : Node_Id;
1064
1065    begin
1066       if Is_Itype (Typ) then
1067          IR := Make_Itype_Reference (Sloc (N));
1068          Set_Itype (IR, Typ);
1069
1070          if not In_Open_Scopes (Scope (Typ))
1071            and then Is_Subprogram (Current_Scope)
1072            and then Scope (Current_Scope) /= Standard_Standard
1073          then
1074             --  Insert node in front of subprogram, to avoid scope anomalies
1075             --  in gigi.
1076
1077             P := Parent (N);
1078
1079             while Present (P)
1080               and then Nkind (P) /= N_Subprogram_Body
1081             loop
1082                P := Parent (P);
1083             end loop;
1084
1085             if Present (P) then
1086                Insert_Action (P, IR);
1087             else
1088                Insert_Action (N, IR);
1089             end if;
1090
1091          else
1092             Insert_Action (N, IR);
1093          end if;
1094       end if;
1095    end Ensure_Defined;
1096
1097    ---------------------
1098    -- Evolve_And_Then --
1099    ---------------------
1100
1101    procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1102    begin
1103       if No (Cond) then
1104          Cond := Cond1;
1105       else
1106          Cond :=
1107            Make_And_Then (Sloc (Cond1),
1108              Left_Opnd  => Cond,
1109              Right_Opnd => Cond1);
1110       end if;
1111    end Evolve_And_Then;
1112
1113    --------------------
1114    -- Evolve_Or_Else --
1115    --------------------
1116
1117    procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1118    begin
1119       if No (Cond) then
1120          Cond := Cond1;
1121       else
1122          Cond :=
1123            Make_Or_Else (Sloc (Cond1),
1124              Left_Opnd  => Cond,
1125              Right_Opnd => Cond1);
1126       end if;
1127    end Evolve_Or_Else;
1128
1129    ------------------------------
1130    -- Expand_Subtype_From_Expr --
1131    ------------------------------
1132
1133    --  This function is applicable for both static and dynamic allocation of
1134    --  objects which are constrained by an initial expression. Basically it
1135    --  transforms an unconstrained subtype indication into a constrained one.
1136    --  The expression may also be transformed in certain cases in order to
1137    --  avoid multiple evaulation. In the static allocation case, the general
1138    --  scheme is :
1139
1140    --     Val : T := Expr;
1141
1142    --        is transformed into
1143
1144    --     Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1145    --
1146    --  Here are the main cases :
1147    --
1148    --  <if Expr is a Slice>
1149    --    Val : T ([Index_Subtype (Expr)]) := Expr;
1150    --
1151    --  <elsif Expr is a String Literal>
1152    --    Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1153    --
1154    --  <elsif Expr is Constrained>
1155    --    subtype T is Type_Of_Expr
1156    --    Val : T := Expr;
1157    --
1158    --  <elsif Expr is an entity_name>
1159    --    Val : T (constraints taken from Expr) := Expr;
1160    --
1161    --  <else>
1162    --    type Axxx is access all T;
1163    --    Rval : Axxx := Expr'ref;
1164    --    Val  : T (constraints taken from Rval) := Rval.all;
1165
1166    --    ??? note: when the Expression is allocated in the secondary stack
1167    --              we could use it directly instead of copying it by declaring
1168    --              Val : T (...) renames Rval.all
1169
1170    procedure Expand_Subtype_From_Expr
1171      (N             : Node_Id;
1172       Unc_Type      : Entity_Id;
1173       Subtype_Indic : Node_Id;
1174       Exp           : Node_Id)
1175    is
1176       Loc     : constant Source_Ptr := Sloc (N);
1177       Exp_Typ : constant Entity_Id  := Etype (Exp);
1178       T       : Entity_Id;
1179
1180    begin
1181       --  In general we cannot build the subtype if expansion is disabled,
1182       --  because internal entities may not have been defined. However, to
1183       --  avoid some cascaded errors, we try to continue when the expression
1184       --  is an array (or string), because it is safe to compute the bounds.
1185       --  It is in fact required to do so even in a generic context, because
1186       --  there may be constants that depend on bounds of string literal.
1187
1188       if not Expander_Active
1189         and then (No (Etype (Exp))
1190                    or else Base_Type (Etype (Exp)) /= Standard_String)
1191       then
1192          return;
1193       end if;
1194
1195       if Nkind (Exp) = N_Slice then
1196          declare
1197             Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1198
1199          begin
1200             Rewrite (Subtype_Indic,
1201               Make_Subtype_Indication (Loc,
1202                 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1203                 Constraint =>
1204                   Make_Index_Or_Discriminant_Constraint (Loc,
1205                     Constraints => New_List
1206                       (New_Reference_To (Slice_Type, Loc)))));
1207
1208             --  This subtype indication may be used later for contraint checks
1209             --  we better make sure that if a variable was used as a bound of
1210             --  of the original slice, its value is frozen.
1211
1212             Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1213             Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1214          end;
1215
1216       elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1217          Rewrite (Subtype_Indic,
1218            Make_Subtype_Indication (Loc,
1219              Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1220              Constraint =>
1221                Make_Index_Or_Discriminant_Constraint (Loc,
1222                  Constraints => New_List (
1223                    Make_Literal_Range (Loc,
1224                      Literal_Typ => Exp_Typ)))));
1225
1226       elsif Is_Constrained (Exp_Typ)
1227         and then not Is_Class_Wide_Type (Unc_Type)
1228       then
1229          if Is_Itype (Exp_Typ) then
1230
1231             --  No need to generate a new one.
1232
1233             T := Exp_Typ;
1234
1235          else
1236             T :=
1237               Make_Defining_Identifier (Loc,
1238                 Chars => New_Internal_Name ('T'));
1239
1240             Insert_Action (N,
1241               Make_Subtype_Declaration (Loc,
1242                 Defining_Identifier => T,
1243                 Subtype_Indication  => New_Reference_To (Exp_Typ, Loc)));
1244
1245             --  This type is marked as an itype even though it has an
1246             --  explicit declaration because otherwise it can be marked
1247             --  with Is_Generic_Actual_Type and generate spurious errors.
1248             --  (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1249
1250             Set_Is_Itype (T);
1251             Set_Associated_Node_For_Itype (T, Exp);
1252          end if;
1253
1254          Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1255
1256       --  nothing needs to be done for private types with unknown discriminants
1257       --  if the underlying type is not an unconstrained composite type.
1258
1259       elsif Is_Private_Type (Unc_Type)
1260         and then Has_Unknown_Discriminants (Unc_Type)
1261         and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1262                     or else Is_Constrained (Underlying_Type (Unc_Type)))
1263       then
1264          null;
1265
1266       else
1267          Remove_Side_Effects (Exp);
1268          Rewrite (Subtype_Indic,
1269            Make_Subtype_From_Expr (Exp, Unc_Type));
1270       end if;
1271    end Expand_Subtype_From_Expr;
1272
1273    ------------------
1274    -- Find_Prim_Op --
1275    ------------------
1276
1277    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1278       Prim : Elmt_Id;
1279       Typ  : Entity_Id := T;
1280
1281    begin
1282       if Is_Class_Wide_Type (Typ) then
1283          Typ := Root_Type (Typ);
1284       end if;
1285
1286       Typ := Underlying_Type (Typ);
1287
1288       Prim := First_Elmt (Primitive_Operations (Typ));
1289       while Chars (Node (Prim)) /= Name loop
1290          Next_Elmt (Prim);
1291          pragma Assert (Present (Prim));
1292       end loop;
1293
1294       return Node (Prim);
1295    end Find_Prim_Op;
1296
1297    function Find_Prim_Op
1298      (T    : Entity_Id;
1299       Name : TSS_Name_Type) return Entity_Id
1300    is
1301       Prim : Elmt_Id;
1302       Typ  : Entity_Id := T;
1303
1304    begin
1305       if Is_Class_Wide_Type (Typ) then
1306          Typ := Root_Type (Typ);
1307       end if;
1308
1309       Typ := Underlying_Type (Typ);
1310
1311       Prim := First_Elmt (Primitive_Operations (Typ));
1312       while not Is_TSS (Node (Prim), Name) loop
1313          Next_Elmt (Prim);
1314          pragma Assert (Present (Prim));
1315       end loop;
1316
1317       return Node (Prim);
1318    end Find_Prim_Op;
1319
1320    ----------------------
1321    -- Force_Evaluation --
1322    ----------------------
1323
1324    procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1325       Component_In_Lhs : Boolean := False;
1326       Par              : Node_Id;
1327
1328    begin
1329       --  Loop to determine whether there is a component reference in
1330       --  the left hand side if this appears on the left side of an
1331       --  assignment statement. Needed to determine if form of result
1332       --  must be a variable.
1333
1334       Par := Exp;
1335       while Present (Par)
1336         and then
1337          (Nkind (Par) = N_Selected_Component
1338             or else
1339           Nkind (Par) = N_Indexed_Component)
1340       loop
1341          if Nkind (Parent (Par)) = N_Assignment_Statement
1342            and then Par = Name (Parent (Par))
1343          then
1344             Component_In_Lhs := True;
1345             exit;
1346          else
1347             Par := Parent (Par);
1348          end if;
1349       end loop;
1350
1351       --  If the expression is a selected component, it is being evaluated
1352       --  as part of a discriminant check. If it is part of a left-hand
1353       --  side, this is the last use of its value and it is safe to create
1354       --  a renaming for it, rather than a temporary. In addition, if it
1355       --  is not an addressable field, creating a temporary may be a problem
1356       --  for gigi, or might drop the value of the assignment. Therefore,
1357       --  if the expression is on the lhs of an assignment, remove side
1358       --  effects without requiring a temporary, and create a renaming.
1359       --  (See remove_side_effects for details).
1360
1361       Remove_Side_Effects
1362         (Exp, Name_Req, Variable_Ref => not Component_In_Lhs);
1363    end Force_Evaluation;
1364
1365    ------------------------
1366    -- Generate_Poll_Call --
1367    ------------------------
1368
1369    procedure Generate_Poll_Call (N : Node_Id) is
1370    begin
1371       --  No poll call if polling not active
1372
1373       if not Polling_Required then
1374          return;
1375
1376       --  Otherwise generate require poll call
1377
1378       else
1379          Insert_Before_And_Analyze (N,
1380            Make_Procedure_Call_Statement (Sloc (N),
1381              Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1382       end if;
1383    end Generate_Poll_Call;
1384
1385    ---------------------------------
1386    -- Get_Current_Value_Condition --
1387    ---------------------------------
1388
1389    procedure Get_Current_Value_Condition
1390      (Var : Node_Id;
1391       Op  : out Node_Kind;
1392       Val : out Node_Id)
1393    is
1394       Loc  : constant Source_Ptr := Sloc (Var);
1395       CV   : constant Node_Id    := Current_Value (Entity (Var));
1396       Sens : Boolean;
1397       Stm  : Node_Id;
1398       Cond : Node_Id;
1399
1400    begin
1401       Op  := N_Empty;
1402       Val := Empty;
1403
1404       --  If statement. Condition is known true in THEN section, known False
1405       --  in any ELSIF or ELSE part, and unknown outside the IF statement.
1406
1407       if Nkind (CV) = N_If_Statement then
1408
1409          --  Before start of IF statement
1410
1411          if Loc < Sloc (CV) then
1412             return;
1413
1414          --  After end of IF statement
1415
1416          elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
1417             return;
1418          end if;
1419
1420          --  At this stage we know that we are within the IF statement, but
1421          --  unfortunately, the tree does not record the SLOC of the ELSE so
1422          --  we cannot use a simple SLOC comparison to distinguish between
1423          --  the then/else statements, so we have to climb the tree.
1424
1425          declare
1426             N : Node_Id;
1427
1428          begin
1429             N := Parent (Var);
1430             while Parent (N) /= CV loop
1431                N := Parent (N);
1432
1433                --  If we fall off the top of the tree, then that's odd, but
1434                --  perhaps it could occur in some error situation, and the
1435                --  safest response is simply to assume that the outcome of
1436                --  the condition is unknown. No point in bombing during an
1437                --  attempt to optimize things.
1438
1439                if No (N) then
1440                   return;
1441                end if;
1442             end loop;
1443
1444             --  Now we have N pointing to a node whose parent is the IF
1445             --  statement in question, so now we can tell if we are within
1446             --  the THEN statements.
1447
1448             if Is_List_Member (N)
1449               and then List_Containing (N) = Then_Statements (CV)
1450             then
1451                Sens := True;
1452
1453             --  Otherwise we must be in ELSIF or ELSE part
1454
1455             else
1456                Sens := False;
1457             end if;
1458          end;
1459
1460       --  ELSIF part. Condition is known true within the referenced
1461       --  ELSIF, known False in any subsequent ELSIF or ELSE part,
1462       --  and unknown before the ELSE part or after the IF statement.
1463
1464       elsif Nkind (CV) = N_Elsif_Part then
1465          Stm := Parent (CV);
1466
1467          --  Before start of ELSIF part
1468
1469          if Loc < Sloc (CV) then
1470             return;
1471
1472          --  After end of IF statement
1473
1474          elsif Loc >= Sloc (Stm) +
1475                         Text_Ptr (UI_To_Int (End_Span (Stm)))
1476          then
1477             return;
1478          end if;
1479
1480          --  Again we lack the SLOC of the ELSE, so we need to climb the
1481          --  tree to see if we are within the ELSIF part in question.
1482
1483          declare
1484             N : Node_Id;
1485
1486          begin
1487             N := Parent (Var);
1488             while Parent (N) /= Stm loop
1489                N := Parent (N);
1490
1491                --  If we fall off the top of the tree, then that's odd, but
1492                --  perhaps it could occur in some error situation, and the
1493                --  safest response is simply to assume that the outcome of
1494                --  the condition is unknown. No point in bombing during an
1495                --  attempt to optimize things.
1496
1497                if No (N) then
1498                   return;
1499                end if;
1500             end loop;
1501
1502             --  Now we have N pointing to a node whose parent is the IF
1503             --  statement in question, so see if is the ELSIF part we want.
1504             --  the THEN statements.
1505
1506             if N = CV then
1507                Sens := True;
1508
1509             --  Otherwise we must be in susbequent ELSIF or ELSE part
1510
1511             else
1512                Sens := False;
1513             end if;
1514          end;
1515
1516       --  All other cases of Current_Value settings
1517
1518       else
1519          return;
1520       end if;
1521
1522       --  If we fall through here, then we have a reportable
1523       --  condition, Sens is True if the condition is true and
1524       --  False if it needs inverting.
1525
1526       Cond := Condition (CV);
1527
1528       --  Deal with NOT operators, inverting sense
1529
1530       while Nkind (Cond) = N_Op_Not loop
1531          Cond := Right_Opnd (Cond);
1532          Sens := not Sens;
1533       end loop;
1534
1535       --  Now we must have a relational operator
1536
1537       pragma Assert (Entity (Var) = Entity (Left_Opnd (Cond)));
1538       Val := Right_Opnd (Cond);
1539       Op  := Nkind (Cond);
1540
1541       if Sens = False then
1542          case Op is
1543             when N_Op_Eq => Op := N_Op_Ne;
1544             when N_Op_Ne => Op := N_Op_Eq;
1545             when N_Op_Lt => Op := N_Op_Ge;
1546             when N_Op_Gt => Op := N_Op_Le;
1547             when N_Op_Le => Op := N_Op_Gt;
1548             when N_Op_Ge => Op := N_Op_Lt;
1549
1550             --  No other entry should be possible
1551
1552             when others =>
1553                raise Program_Error;
1554          end case;
1555       end if;
1556    end Get_Current_Value_Condition;
1557
1558    --------------------
1559    -- Homonym_Number --
1560    --------------------
1561
1562    function Homonym_Number (Subp : Entity_Id) return Nat is
1563       Count : Nat;
1564       Hom   : Entity_Id;
1565
1566    begin
1567       Count := 1;
1568       Hom := Homonym (Subp);
1569       while Present (Hom) loop
1570          if Scope (Hom) = Scope (Subp) then
1571             Count := Count + 1;
1572          end if;
1573
1574          Hom := Homonym (Hom);
1575       end loop;
1576
1577       return Count;
1578    end Homonym_Number;
1579
1580    ------------------------------
1581    -- In_Unconditional_Context --
1582    ------------------------------
1583
1584    function In_Unconditional_Context (Node : Node_Id) return Boolean is
1585       P : Node_Id;
1586
1587    begin
1588       P := Node;
1589       while Present (P) loop
1590          case Nkind (P) is
1591             when N_Subprogram_Body =>
1592                return True;
1593
1594             when N_If_Statement =>
1595                return False;
1596
1597             when N_Loop_Statement =>
1598                return False;
1599
1600             when N_Case_Statement =>
1601                return False;
1602
1603             when others =>
1604                P := Parent (P);
1605          end case;
1606       end loop;
1607
1608       return False;
1609    end In_Unconditional_Context;
1610
1611    -------------------
1612    -- Insert_Action --
1613    -------------------
1614
1615    procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
1616    begin
1617       if Present (Ins_Action) then
1618          Insert_Actions (Assoc_Node, New_List (Ins_Action));
1619       end if;
1620    end Insert_Action;
1621
1622    --  Version with check(s) suppressed
1623
1624    procedure Insert_Action
1625      (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
1626    is
1627    begin
1628       Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
1629    end Insert_Action;
1630
1631    --------------------
1632    -- Insert_Actions --
1633    --------------------
1634
1635    procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
1636       N : Node_Id;
1637       P : Node_Id;
1638
1639       Wrapped_Node : Node_Id := Empty;
1640
1641    begin
1642       if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
1643          return;
1644       end if;
1645
1646       --  Ignore insert of actions from inside default expression in the
1647       --  special preliminary analyze mode. Any insertions at this point
1648       --  have no relevance, since we are only doing the analyze to freeze
1649       --  the types of any static expressions. See section "Handling of
1650       --  Default Expressions" in the spec of package Sem for further details.
1651
1652       if In_Default_Expression then
1653          return;
1654       end if;
1655
1656       --  If the action derives from stuff inside a record, then the actions
1657       --  are attached to the current scope, to be inserted and analyzed on
1658       --  exit from the scope. The reason for this is that we may also
1659       --  be generating freeze actions at the same time, and they must
1660       --  eventually be elaborated in the correct order.
1661
1662       if Is_Record_Type (Current_Scope)
1663         and then not Is_Frozen (Current_Scope)
1664       then
1665          if No (Scope_Stack.Table
1666            (Scope_Stack.Last).Pending_Freeze_Actions)
1667          then
1668             Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
1669               Ins_Actions;
1670          else
1671             Append_List
1672               (Ins_Actions,
1673                Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
1674          end if;
1675
1676          return;
1677       end if;
1678
1679       --  We now intend to climb up the tree to find the right point to
1680       --  insert the actions. We start at Assoc_Node, unless this node is
1681       --  a subexpression in which case we start with its parent. We do this
1682       --  for two reasons. First it speeds things up. Second, if Assoc_Node
1683       --  is itself one of the special nodes like N_And_Then, then we assume
1684       --  that an initial request to insert actions for such a node does not
1685       --  expect the actions to get deposited in the node for later handling
1686       --  when the node is expanded, since clearly the node is being dealt
1687       --  with by the caller. Note that in the subexpression case, N is
1688       --  always the child we came from.
1689
1690       --  N_Raise_xxx_Error is an annoying special case, it is a statement
1691       --  if it has type Standard_Void_Type, and a subexpression otherwise.
1692       --  otherwise. Procedure attribute references are also statements.
1693
1694       if Nkind (Assoc_Node) in N_Subexpr
1695         and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
1696                    or else Etype (Assoc_Node) /= Standard_Void_Type)
1697         and then (Nkind (Assoc_Node) /= N_Attribute_Reference
1698                    or else
1699                      not Is_Procedure_Attribute_Name
1700                            (Attribute_Name (Assoc_Node)))
1701       then
1702          P := Assoc_Node;             -- ??? does not agree with above!
1703          N := Parent (Assoc_Node);
1704
1705       --  Non-subexpression case. Note that N is initially Empty in this
1706       --  case (N is only guaranteed Non-Empty in the subexpr case).
1707
1708       else
1709          P := Assoc_Node;
1710          N := Empty;
1711       end if;
1712
1713       --  Capture root of the transient scope
1714
1715       if Scope_Is_Transient then
1716          Wrapped_Node  := Node_To_Be_Wrapped;
1717       end if;
1718
1719       loop
1720          pragma Assert (Present (P));
1721
1722          case Nkind (P) is
1723
1724             --  Case of right operand of AND THEN or OR ELSE. Put the actions
1725             --  in the Actions field of the right operand. They will be moved
1726             --  out further when the AND THEN or OR ELSE operator is expanded.
1727             --  Nothing special needs to be done for the left operand since
1728             --  in that case the actions are executed unconditionally.
1729
1730             when N_And_Then | N_Or_Else =>
1731                if N = Right_Opnd (P) then
1732                   if Present (Actions (P)) then
1733                      Insert_List_After_And_Analyze
1734                       (Last (Actions (P)), Ins_Actions);
1735                   else
1736                      Set_Actions (P, Ins_Actions);
1737                      Analyze_List (Actions (P));
1738                   end if;
1739
1740                   return;
1741                end if;
1742
1743             --  Then or Else operand of conditional expression. Add actions to
1744             --  Then_Actions or Else_Actions field as appropriate. The actions
1745             --  will be moved further out when the conditional is expanded.
1746
1747             when N_Conditional_Expression =>
1748                declare
1749                   ThenX : constant Node_Id := Next (First (Expressions (P)));
1750                   ElseX : constant Node_Id := Next (ThenX);
1751
1752                begin
1753                   --  Actions belong to the then expression, temporarily
1754                   --  place them as Then_Actions of the conditional expr.
1755                   --  They will be moved to the proper place later when
1756                   --  the conditional expression is expanded.
1757
1758                   if N = ThenX then
1759                      if Present (Then_Actions (P)) then
1760                         Insert_List_After_And_Analyze
1761                           (Last (Then_Actions (P)), Ins_Actions);
1762                      else
1763                         Set_Then_Actions (P, Ins_Actions);
1764                         Analyze_List (Then_Actions (P));
1765                      end if;
1766
1767                      return;
1768
1769                   --  Actions belong to the else expression, temporarily
1770                   --  place them as Else_Actions of the conditional expr.
1771                   --  They will be moved to the proper place later when
1772                   --  the conditional expression is expanded.
1773
1774                   elsif N = ElseX then
1775                      if Present (Else_Actions (P)) then
1776                         Insert_List_After_And_Analyze
1777                           (Last (Else_Actions (P)), Ins_Actions);
1778                      else
1779                         Set_Else_Actions (P, Ins_Actions);
1780                         Analyze_List (Else_Actions (P));
1781                      end if;
1782
1783                      return;
1784
1785                   --  Actions belong to the condition. In this case they are
1786                   --  unconditionally executed, and so we can continue the
1787                   --  search for the proper insert point.
1788
1789                   else
1790                      null;
1791                   end if;
1792                end;
1793
1794             --  Case of appearing in the condition of a while expression or
1795             --  elsif. We insert the actions into the Condition_Actions field.
1796             --  They will be moved further out when the while loop or elsif
1797             --  is analyzed.
1798
1799             when N_Iteration_Scheme |
1800                  N_Elsif_Part
1801             =>
1802                if N = Condition (P) then
1803                   if Present (Condition_Actions (P)) then
1804                      Insert_List_After_And_Analyze
1805                        (Last (Condition_Actions (P)), Ins_Actions);
1806                   else
1807                      Set_Condition_Actions (P, Ins_Actions);
1808
1809                      --  Set the parent of the insert actions explicitly.
1810                      --  This is not a syntactic field, but we need the
1811                      --  parent field set, in particular so that freeze
1812                      --  can understand that it is dealing with condition
1813                      --  actions, and properly insert the freezing actions.
1814
1815                      Set_Parent (Ins_Actions, P);
1816                      Analyze_List (Condition_Actions (P));
1817                   end if;
1818
1819                   return;
1820                end if;
1821
1822             --  Statements, declarations, pragmas, representation clauses.
1823
1824             when
1825                --  Statements
1826
1827                N_Procedure_Call_Statement               |
1828                N_Statement_Other_Than_Procedure_Call    |
1829
1830                --  Pragmas
1831
1832                N_Pragma                                 |
1833
1834                --  Representation_Clause
1835
1836                N_At_Clause                              |
1837                N_Attribute_Definition_Clause            |
1838                N_Enumeration_Representation_Clause      |
1839                N_Record_Representation_Clause           |
1840
1841                --  Declarations
1842
1843                N_Abstract_Subprogram_Declaration        |
1844                N_Entry_Body                             |
1845                N_Exception_Declaration                  |
1846                N_Exception_Renaming_Declaration         |
1847                N_Formal_Object_Declaration              |
1848                N_Formal_Subprogram_Declaration          |
1849                N_Formal_Type_Declaration                |
1850                N_Full_Type_Declaration                  |
1851                N_Function_Instantiation                 |
1852                N_Generic_Function_Renaming_Declaration  |
1853                N_Generic_Package_Declaration            |
1854                N_Generic_Package_Renaming_Declaration   |
1855                N_Generic_Procedure_Renaming_Declaration |
1856                N_Generic_Subprogram_Declaration         |
1857                N_Implicit_Label_Declaration             |
1858                N_Incomplete_Type_Declaration            |
1859                N_Number_Declaration                     |
1860                N_Object_Declaration                     |
1861                N_Object_Renaming_Declaration            |
1862                N_Package_Body                           |
1863                N_Package_Body_Stub                      |
1864                N_Package_Declaration                    |
1865                N_Package_Instantiation                  |
1866                N_Package_Renaming_Declaration           |
1867                N_Private_Extension_Declaration          |
1868                N_Private_Type_Declaration               |
1869                N_Procedure_Instantiation                |
1870                N_Protected_Body_Stub                    |
1871                N_Protected_Type_Declaration             |
1872                N_Single_Task_Declaration                |
1873                N_Subprogram_Body                        |
1874                N_Subprogram_Body_Stub                   |
1875                N_Subprogram_Declaration                 |
1876                N_Subprogram_Renaming_Declaration        |
1877                N_Subtype_Declaration                    |
1878                N_Task_Body                              |
1879                N_Task_Body_Stub                         |
1880                N_Task_Type_Declaration                  |
1881
1882                --  Freeze entity behaves like a declaration or statement
1883
1884                N_Freeze_Entity
1885             =>
1886                --  Do not insert here if the item is not a list member (this
1887                --  happens for example with a triggering statement, and the
1888                --  proper approach is to insert before the entire select).
1889
1890                if not Is_List_Member (P) then
1891                   null;
1892
1893                --  Do not insert if parent of P is an N_Component_Association
1894                --  node (i.e. we are in the context of an N_Aggregate node.
1895                --  In this case we want to insert before the entire aggregate.
1896
1897                elsif Nkind (Parent (P)) = N_Component_Association then
1898                   null;
1899
1900                --  Do not insert if the parent of P is either an N_Variant
1901                --  node or an N_Record_Definition node, meaning in either
1902                --  case that P is a member of a component list, and that
1903                --  therefore the actions should be inserted outside the
1904                --  complete record declaration.
1905
1906                elsif Nkind (Parent (P)) = N_Variant
1907                  or else Nkind (Parent (P)) = N_Record_Definition
1908                then
1909                   null;
1910
1911                --  Do not insert freeze nodes within the loop generated for
1912                --  an aggregate, because they may be elaborated too late for
1913                --  subsequent use in the back end: within a package spec the
1914                --  loop is part of the elaboration procedure and is only
1915                --  elaborated during the second pass.
1916                --  If the loop comes from source, or the entity is local to
1917                --  the loop itself it must remain within.
1918
1919                elsif Nkind (Parent (P)) = N_Loop_Statement
1920                  and then not Comes_From_Source (Parent (P))
1921                  and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
1922                  and then
1923                    Scope (Entity (First (Ins_Actions))) /= Current_Scope
1924                then
1925                   null;
1926
1927                --  Otherwise we can go ahead and do the insertion
1928
1929                elsif  P = Wrapped_Node then
1930                   Store_Before_Actions_In_Scope (Ins_Actions);
1931                   return;
1932
1933                else
1934                   Insert_List_Before_And_Analyze (P, Ins_Actions);
1935                   return;
1936                end if;
1937
1938             --  A special case, N_Raise_xxx_Error can act either as a
1939             --  statement or a subexpression. We tell the difference
1940             --  by looking at the Etype. It is set to Standard_Void_Type
1941             --  in the statement case.
1942
1943             when
1944                N_Raise_xxx_Error =>
1945                   if Etype (P) = Standard_Void_Type then
1946                      if  P = Wrapped_Node then
1947                         Store_Before_Actions_In_Scope (Ins_Actions);
1948                      else
1949                         Insert_List_Before_And_Analyze (P, Ins_Actions);
1950                      end if;
1951
1952                      return;
1953
1954                   --  In the subexpression case, keep climbing
1955
1956                   else
1957                      null;
1958                   end if;
1959
1960             --  If a component association appears within a loop created for
1961             --  an array aggregate, attach the actions to the association so
1962             --  they can be subsequently inserted within the loop. For other
1963             --  component associations insert outside of the aggregate. For
1964             --  an association that will generate a loop, its Loop_Actions
1965             --  attribute is already initialized (see exp_aggr.adb).
1966
1967             --  The list of loop_actions can in turn generate additional ones,
1968             --  that are inserted before the associated node. If the associated
1969             --  node is outside the aggregate, the new actions are collected
1970             --  at the end of the loop actions, to respect the order in which
1971             --  they are to be elaborated.
1972
1973             when
1974                N_Component_Association =>
1975                   if Nkind (Parent (P)) = N_Aggregate
1976                     and then Present (Loop_Actions (P))
1977                   then
1978                      if Is_Empty_List (Loop_Actions (P)) then
1979                         Set_Loop_Actions (P, Ins_Actions);
1980                         Analyze_List (Ins_Actions);
1981
1982                      else
1983                         declare
1984                            Decl : Node_Id := Assoc_Node;
1985
1986                         begin
1987                            --  Check whether these actions were generated
1988                            --  by a declaration that is part of the loop_
1989                            --  actions for the component_association.
1990
1991                            while Present (Decl) loop
1992                               exit when Parent (Decl) = P
1993                                 and then Is_List_Member (Decl)
1994                                 and then
1995                                   List_Containing (Decl) = Loop_Actions (P);
1996                               Decl := Parent (Decl);
1997                            end loop;
1998
1999                            if Present (Decl) then
2000                               Insert_List_Before_And_Analyze
2001                                 (Decl, Ins_Actions);
2002                            else
2003                               Insert_List_After_And_Analyze
2004                                 (Last (Loop_Actions (P)), Ins_Actions);
2005                            end if;
2006                         end;
2007                      end if;
2008
2009                      return;
2010
2011                   else
2012                      null;
2013                   end if;
2014
2015             --  Another special case, an attribute denoting a procedure call
2016
2017             when
2018                N_Attribute_Reference =>
2019                   if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
2020                      if P = Wrapped_Node then
2021                         Store_Before_Actions_In_Scope (Ins_Actions);
2022                      else
2023                         Insert_List_Before_And_Analyze (P, Ins_Actions);
2024                      end if;
2025
2026                      return;
2027
2028                   --  In the subexpression case, keep climbing
2029
2030                   else
2031                      null;
2032                   end if;
2033
2034             --  For all other node types, keep climbing tree
2035
2036             when
2037                N_Abortable_Part                         |
2038                N_Accept_Alternative                     |
2039                N_Access_Definition                      |
2040                N_Access_Function_Definition             |
2041                N_Access_Procedure_Definition            |
2042                N_Access_To_Object_Definition            |
2043                N_Aggregate                              |
2044                N_Allocator                              |
2045                N_Case_Statement_Alternative             |
2046                N_Character_Literal                      |
2047                N_Compilation_Unit                       |
2048                N_Compilation_Unit_Aux                   |
2049                N_Component_Clause                       |
2050                N_Component_Declaration                  |
2051                N_Component_Definition                   |
2052                N_Component_List                         |
2053                N_Constrained_Array_Definition           |
2054                N_Decimal_Fixed_Point_Definition         |
2055                N_Defining_Character_Literal             |
2056                N_Defining_Identifier                    |
2057                N_Defining_Operator_Symbol               |
2058                N_Defining_Program_Unit_Name             |
2059                N_Delay_Alternative                      |
2060                N_Delta_Constraint                       |
2061                N_Derived_Type_Definition                |
2062                N_Designator                             |
2063                N_Digits_Constraint                      |
2064                N_Discriminant_Association               |
2065                N_Discriminant_Specification             |
2066                N_Empty                                  |
2067                N_Entry_Body_Formal_Part                 |
2068                N_Entry_Call_Alternative                 |
2069                N_Entry_Declaration                      |
2070                N_Entry_Index_Specification              |
2071                N_Enumeration_Type_Definition            |
2072                N_Error                                  |
2073                N_Exception_Handler                      |
2074                N_Expanded_Name                          |
2075                N_Explicit_Dereference                   |
2076                N_Extension_Aggregate                    |
2077                N_Floating_Point_Definition              |
2078                N_Formal_Decimal_Fixed_Point_Definition  |
2079                N_Formal_Derived_Type_Definition         |
2080                N_Formal_Discrete_Type_Definition        |
2081                N_Formal_Floating_Point_Definition       |
2082                N_Formal_Modular_Type_Definition         |
2083                N_Formal_Ordinary_Fixed_Point_Definition |
2084                N_Formal_Package_Declaration             |
2085                N_Formal_Private_Type_Definition         |
2086                N_Formal_Signed_Integer_Type_Definition  |
2087                N_Function_Call                          |
2088                N_Function_Specification                 |
2089                N_Generic_Association                    |
2090                N_Handled_Sequence_Of_Statements         |
2091                N_Identifier                             |
2092                N_In                                     |
2093                N_Index_Or_Discriminant_Constraint       |
2094                N_Indexed_Component                      |
2095                N_Integer_Literal                        |
2096                N_Itype_Reference                        |
2097                N_Label                                  |
2098                N_Loop_Parameter_Specification           |
2099                N_Mod_Clause                             |
2100                N_Modular_Type_Definition                |
2101                N_Not_In                                 |
2102                N_Null                                   |
2103                N_Op_Abs                                 |
2104                N_Op_Add                                 |
2105                N_Op_And                                 |
2106                N_Op_Concat                              |
2107                N_Op_Divide                              |
2108                N_Op_Eq                                  |
2109                N_Op_Expon                               |
2110                N_Op_Ge                                  |
2111                N_Op_Gt                                  |
2112                N_Op_Le                                  |
2113                N_Op_Lt                                  |
2114                N_Op_Minus                               |
2115                N_Op_Mod                                 |
2116                N_Op_Multiply                            |
2117                N_Op_Ne                                  |
2118                N_Op_Not                                 |
2119                N_Op_Or                                  |
2120                N_Op_Plus                                |
2121                N_Op_Rem                                 |
2122                N_Op_Rotate_Left                         |
2123                N_Op_Rotate_Right                        |
2124                N_Op_Shift_Left                          |
2125                N_Op_Shift_Right                         |
2126                N_Op_Shift_Right_Arithmetic              |
2127                N_Op_Subtract                            |
2128                N_Op_Xor                                 |
2129                N_Operator_Symbol                        |
2130                N_Ordinary_Fixed_Point_Definition        |
2131                N_Others_Choice                          |
2132                N_Package_Specification                  |
2133                N_Parameter_Association                  |
2134                N_Parameter_Specification                |
2135                N_Pragma_Argument_Association            |
2136                N_Procedure_Specification                |
2137                N_Protected_Body                         |
2138                N_Protected_Definition                   |
2139                N_Qualified_Expression                   |
2140                N_Range                                  |
2141                N_Range_Constraint                       |
2142                N_Real_Literal                           |
2143                N_Real_Range_Specification               |
2144                N_Record_Definition                      |
2145                N_Reference                              |
2146                N_Selected_Component                     |
2147                N_Signed_Integer_Type_Definition         |
2148                N_Single_Protected_Declaration           |
2149                N_Slice                                  |
2150                N_String_Literal                         |
2151                N_Subprogram_Info                        |
2152                N_Subtype_Indication                     |
2153                N_Subunit                                |
2154                N_Task_Definition                        |
2155                N_Terminate_Alternative                  |
2156                N_Triggering_Alternative                 |
2157                N_Type_Conversion                        |
2158                N_Unchecked_Expression                   |
2159                N_Unchecked_Type_Conversion              |
2160                N_Unconstrained_Array_Definition         |
2161                N_Unused_At_End                          |
2162                N_Unused_At_Start                        |
2163                N_Use_Package_Clause                     |
2164                N_Use_Type_Clause                        |
2165                N_Variant                                |
2166                N_Variant_Part                           |
2167                N_Validate_Unchecked_Conversion          |
2168                N_With_Clause                            |
2169                N_With_Type_Clause
2170             =>
2171                null;
2172
2173          end case;
2174
2175          --  Make sure that inserted actions stay in the transient scope
2176
2177          if P = Wrapped_Node then
2178             Store_Before_Actions_In_Scope (Ins_Actions);
2179             return;
2180          end if;
2181
2182          --  If we fall through above tests, keep climbing tree
2183
2184          N := P;
2185
2186          if Nkind (Parent (N)) = N_Subunit then
2187
2188             --  This is the proper body corresponding to a stub. Insertion
2189             --  must be done at the point of the stub, which is in the decla-
2190             --  tive part of the parent unit.
2191
2192             P := Corresponding_Stub (Parent (N));
2193
2194          else
2195             P := Parent (N);
2196          end if;
2197       end loop;
2198
2199    end Insert_Actions;
2200
2201    --  Version with check(s) suppressed
2202
2203    procedure Insert_Actions
2204      (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
2205    is
2206    begin
2207       if Suppress = All_Checks then
2208          declare
2209             Svg : constant Suppress_Array := Scope_Suppress;
2210
2211          begin
2212             Scope_Suppress := (others => True);
2213             Insert_Actions (Assoc_Node, Ins_Actions);
2214             Scope_Suppress := Svg;
2215          end;
2216
2217       else
2218          declare
2219             Svg : constant Boolean := Scope_Suppress (Suppress);
2220
2221          begin
2222             Scope_Suppress (Suppress) := True;
2223             Insert_Actions (Assoc_Node, Ins_Actions);
2224             Scope_Suppress (Suppress) := Svg;
2225          end;
2226       end if;
2227    end Insert_Actions;
2228
2229    --------------------------
2230    -- Insert_Actions_After --
2231    --------------------------
2232
2233    procedure Insert_Actions_After
2234      (Assoc_Node  : Node_Id;
2235       Ins_Actions : List_Id)
2236    is
2237    begin
2238       if Scope_Is_Transient
2239         and then Assoc_Node = Node_To_Be_Wrapped
2240       then
2241          Store_After_Actions_In_Scope (Ins_Actions);
2242       else
2243          Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
2244       end if;
2245    end Insert_Actions_After;
2246
2247    ---------------------------------
2248    -- Insert_Library_Level_Action --
2249    ---------------------------------
2250
2251    procedure Insert_Library_Level_Action (N : Node_Id) is
2252       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2253
2254    begin
2255       New_Scope (Cunit_Entity (Main_Unit));
2256
2257       if No (Actions (Aux)) then
2258          Set_Actions (Aux, New_List (N));
2259       else
2260          Append (N, Actions (Aux));
2261       end if;
2262
2263       Analyze (N);
2264       Pop_Scope;
2265    end Insert_Library_Level_Action;
2266
2267    ----------------------------------
2268    -- Insert_Library_Level_Actions --
2269    ----------------------------------
2270
2271    procedure Insert_Library_Level_Actions (L : List_Id) is
2272       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2273
2274    begin
2275       if Is_Non_Empty_List (L) then
2276          New_Scope (Cunit_Entity (Main_Unit));
2277
2278          if No (Actions (Aux)) then
2279             Set_Actions (Aux, L);
2280             Analyze_List (L);
2281          else
2282             Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2283          end if;
2284
2285          Pop_Scope;
2286       end if;
2287    end Insert_Library_Level_Actions;
2288
2289    ----------------------
2290    -- Inside_Init_Proc --
2291    ----------------------
2292
2293    function Inside_Init_Proc return Boolean is
2294       S : Entity_Id;
2295
2296    begin
2297       S := Current_Scope;
2298       while Present (S)
2299         and then S /= Standard_Standard
2300       loop
2301          if Is_Init_Proc (S) then
2302             return True;
2303          else
2304             S := Scope (S);
2305          end if;
2306       end loop;
2307
2308       return False;
2309    end Inside_Init_Proc;
2310
2311    ----------------------------
2312    -- Is_All_Null_Statements --
2313    ----------------------------
2314
2315    function Is_All_Null_Statements (L : List_Id) return Boolean is
2316       Stm : Node_Id;
2317
2318    begin
2319       Stm := First (L);
2320       while Present (Stm) loop
2321          if Nkind (Stm) /= N_Null_Statement then
2322             return False;
2323          end if;
2324
2325          Next (Stm);
2326       end loop;
2327
2328       return True;
2329    end Is_All_Null_Statements;
2330
2331    ----------------------------------
2332    -- Is_Possibly_Unaligned_Object --
2333    ----------------------------------
2334
2335    function Is_Possibly_Unaligned_Object (P : Node_Id) return Boolean is
2336    begin
2337       --  If target does not have strict alignment, result is always
2338       --  False, since correctness of code does no depend on alignment.
2339
2340       if not Target_Strict_Alignment then
2341          return False;
2342       end if;
2343
2344       --  If renamed object, apply test to underlying object
2345
2346       if Is_Entity_Name (P)
2347         and then Is_Object (Entity (P))
2348         and then Present (Renamed_Object (Entity (P)))
2349       then
2350          return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (P)));
2351       end if;
2352
2353       --  If this is an element of a packed array, may be unaligned
2354
2355       if Is_Ref_To_Bit_Packed_Array (P) then
2356          return True;
2357       end if;
2358
2359       --  Case of component reference
2360
2361       if Nkind (P) = N_Selected_Component then
2362
2363          --  If component reference is for a record that is bit packed
2364          --  or has a specified alignment (that might be too small) or
2365          --  the component reference has a component clause, then the
2366          --  object may be unaligned.
2367
2368          if Is_Packed (Etype (Prefix (P)))
2369            or else Known_Alignment (Etype (Prefix (P)))
2370            or else Present (Component_Clause (Entity (Selector_Name (P))))
2371          then
2372             return True;
2373
2374          --  Otherwise, for a component reference, test prefix
2375
2376          else
2377             return Is_Possibly_Unaligned_Object (Prefix (P));
2378          end if;
2379
2380       --  If not a component reference, must be aligned
2381
2382       else
2383          return False;
2384       end if;
2385    end Is_Possibly_Unaligned_Object;
2386
2387    ---------------------------------
2388    -- Is_Possibly_Unaligned_Slice --
2389    ---------------------------------
2390
2391    function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
2392    begin
2393       --  ??? GCC3 will eventually handle strings with arbitrary alignments,
2394       --  but for now the following check must be disabled.
2395
2396       --  if get_gcc_version >= 3 then
2397       --     return False;
2398       --  end if;
2399
2400       --  For renaming case, go to renamed object
2401
2402       if Is_Entity_Name (P)
2403         and then Is_Object (Entity (P))
2404         and then Present (Renamed_Object (Entity (P)))
2405       then
2406          return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (P)));
2407       end if;
2408
2409       --  The reference must be a slice
2410
2411       if Nkind (P) /= N_Slice then
2412          return False;
2413       end if;
2414
2415       --  Always assume the worst for a nested record component with a
2416       --  component clause, which gigi/gcc does not appear to handle well.
2417       --  It is not clear why this special test is needed at all ???
2418
2419       if Nkind (Prefix (P)) = N_Selected_Component
2420         and then Nkind (Prefix (Prefix (P))) = N_Selected_Component
2421         and then
2422           Present (Component_Clause (Entity (Selector_Name (Prefix (P)))))
2423       then
2424          return True;
2425       end if;
2426
2427       --  We only need to worry if the target has strict alignment
2428
2429       if not Target_Strict_Alignment then
2430          return False;
2431       end if;
2432
2433       --  If it is a slice, then look at the array type being sliced
2434
2435       declare
2436          Sarr : constant Node_Id := Prefix (P);
2437          --  Prefix of the slice, i.e. the array being sliced
2438
2439          Styp : constant Entity_Id := Etype (Prefix (P));
2440          --  Type of the array being sliced
2441
2442          Pref : Node_Id;
2443          Ptyp : Entity_Id;
2444
2445       begin
2446          --  The problems arise if the array object that is being sliced
2447          --  is a component of a record or array, and we cannot guarantee
2448          --  the alignment of the array within its containing object.
2449
2450          --  To investigate this, we look at successive prefixes to see
2451          --  if we have a worrisome indexed or selected component.
2452
2453          Pref := Sarr;
2454          loop
2455             --  Case of array is part of an indexed component reference
2456
2457             if Nkind (Pref) = N_Indexed_Component then
2458                Ptyp := Etype (Prefix (Pref));
2459
2460                --  The only problematic case is when the array is packed,
2461                --  in which case we really know nothing about the alignment
2462                --  of individual components.
2463
2464                if Is_Bit_Packed_Array (Ptyp) then
2465                   return True;
2466                end if;
2467
2468             --  Case of array is part of a selected component reference
2469
2470             elsif Nkind (Pref) = N_Selected_Component then
2471                Ptyp := Etype (Prefix (Pref));
2472
2473                --  We are definitely in trouble if the record in question
2474                --  has an alignment, and either we know this alignment is
2475                --  inconsistent with the alignment of the slice, or we
2476                --  don't know what the alignment of the slice should be.
2477
2478                if Known_Alignment (Ptyp)
2479                  and then (Unknown_Alignment (Styp)
2480                              or else Alignment (Styp) > Alignment (Ptyp))
2481                then
2482                   return True;
2483                end if;
2484
2485                --  We are in potential trouble if the record type is packed.
2486                --  We could special case when we know that the array is the
2487                --  first component, but that's not such a simple case ???
2488
2489                if Is_Packed (Ptyp) then
2490                   return True;
2491                end if;
2492
2493                --  We are in trouble if there is a component clause, and
2494                --  either we do not know the alignment of the slice, or
2495                --  the alignment of the slice is inconsistent with the
2496                --  bit position specified by the component clause.
2497
2498                declare
2499                   Field : constant Entity_Id := Entity (Selector_Name (Pref));
2500                begin
2501                   if Present (Component_Clause (Field))
2502                     and then
2503                       (Unknown_Alignment (Styp)
2504                         or else
2505                          (Component_Bit_Offset (Field) mod
2506                            (System_Storage_Unit * Alignment (Styp))) /= 0)
2507                   then
2508                      return True;
2509                   end if;
2510                end;
2511
2512             --  For cases other than selected or indexed components we
2513             --  know we are OK, since no issues arise over alignment.
2514
2515             else
2516                return False;
2517             end if;
2518
2519             --  We processed an indexed component or selected component
2520             --  reference that looked safe, so keep checking prefixes.
2521
2522             Pref := Prefix (Pref);
2523          end loop;
2524       end;
2525    end Is_Possibly_Unaligned_Slice;
2526
2527    --------------------------------
2528    -- Is_Ref_To_Bit_Packed_Array --
2529    --------------------------------
2530
2531    function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean is
2532       Result : Boolean;
2533       Expr   : Node_Id;
2534
2535    begin
2536       if Is_Entity_Name (P)
2537         and then Is_Object (Entity (P))
2538         and then Present (Renamed_Object (Entity (P)))
2539       then
2540          return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (P)));
2541       end if;
2542
2543       if Nkind (P) = N_Indexed_Component
2544            or else
2545          Nkind (P) = N_Selected_Component
2546       then
2547          if Is_Bit_Packed_Array (Etype (Prefix (P))) then
2548             Result := True;
2549          else
2550             Result := Is_Ref_To_Bit_Packed_Array (Prefix (P));
2551          end if;
2552
2553          if Result and then Nkind (P) = N_Indexed_Component then
2554             Expr := First (Expressions (P));
2555
2556             while Present (Expr) loop
2557                Force_Evaluation (Expr);
2558                Next (Expr);
2559             end loop;
2560          end if;
2561
2562          return Result;
2563
2564       else
2565          return False;
2566       end if;
2567    end Is_Ref_To_Bit_Packed_Array;
2568
2569    --------------------------------
2570    -- Is_Ref_To_Bit_Packed_Slice --
2571    --------------------------------
2572
2573    function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is
2574    begin
2575       if Is_Entity_Name (P)
2576         and then Is_Object (Entity (P))
2577         and then Present (Renamed_Object (Entity (P)))
2578       then
2579          return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (P)));
2580       end if;
2581
2582       if Nkind (P) = N_Slice
2583         and then Is_Bit_Packed_Array (Etype (Prefix (P)))
2584       then
2585          return True;
2586
2587       elsif Nkind (P) = N_Indexed_Component
2588            or else
2589          Nkind (P) = N_Selected_Component
2590       then
2591          return Is_Ref_To_Bit_Packed_Slice (Prefix (P));
2592
2593       else
2594          return False;
2595       end if;
2596    end Is_Ref_To_Bit_Packed_Slice;
2597
2598    -----------------------
2599    -- Is_Renamed_Object --
2600    -----------------------
2601
2602    function Is_Renamed_Object (N : Node_Id) return Boolean is
2603       Pnod : constant Node_Id   := Parent (N);
2604       Kind : constant Node_Kind := Nkind (Pnod);
2605
2606    begin
2607       if Kind = N_Object_Renaming_Declaration then
2608          return True;
2609
2610       elsif Kind = N_Indexed_Component
2611         or else Kind = N_Selected_Component
2612       then
2613          return Is_Renamed_Object (Pnod);
2614
2615       else
2616          return False;
2617       end if;
2618    end Is_Renamed_Object;
2619
2620    ----------------------------
2621    -- Is_Untagged_Derivation --
2622    ----------------------------
2623
2624    function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
2625    begin
2626       return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
2627                or else
2628              (Is_Private_Type (T) and then Present (Full_View (T))
2629                and then not Is_Tagged_Type (Full_View (T))
2630                and then Is_Derived_Type (Full_View (T))
2631                and then Etype (Full_View (T)) /= T);
2632
2633    end Is_Untagged_Derivation;
2634
2635    --------------------
2636    -- Kill_Dead_Code --
2637    --------------------
2638
2639    procedure Kill_Dead_Code (N : Node_Id) is
2640    begin
2641       if Present (N) then
2642          Remove_Handler_Entries (N);
2643          Remove_Warning_Messages (N);
2644
2645          --  Recurse into block statements and bodies to process declarations
2646          --  and statements
2647
2648          if Nkind (N) = N_Block_Statement
2649            or else Nkind (N) = N_Subprogram_Body
2650            or else Nkind (N) = N_Package_Body
2651          then
2652             Kill_Dead_Code (Declarations (N));
2653             Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
2654
2655             if Nkind (N) = N_Subprogram_Body then
2656                Set_Is_Eliminated (Defining_Entity (N));
2657             end if;
2658
2659          --  Recurse into composite statement to kill individual statements,
2660          --  in particular instantiations.
2661
2662          elsif Nkind (N) = N_If_Statement then
2663             Kill_Dead_Code (Then_Statements (N));
2664             Kill_Dead_Code (Elsif_Parts (N));
2665             Kill_Dead_Code (Else_Statements (N));
2666
2667          elsif Nkind (N) = N_Loop_Statement then
2668             Kill_Dead_Code (Statements (N));
2669
2670          elsif Nkind (N) = N_Case_Statement then
2671             declare
2672                Alt : Node_Id := First (Alternatives (N));
2673
2674             begin
2675                while Present (Alt) loop
2676                   Kill_Dead_Code (Statements (Alt));
2677                   Next (Alt);
2678                end loop;
2679             end;
2680
2681          elsif Nkind (N) = N_Case_Statement_Alternative then
2682             Kill_Dead_Code (Statements (N));
2683
2684          --  Deal with dead instances caused by deleting instantiations
2685
2686          elsif Nkind (N) in N_Generic_Instantiation then
2687             Remove_Dead_Instance (N);
2688          end if;
2689
2690          Delete_Tree (N);
2691       end if;
2692    end Kill_Dead_Code;
2693
2694    --  Case where argument is a list of nodes to be killed
2695
2696    procedure Kill_Dead_Code (L : List_Id) is
2697       N : Node_Id;
2698
2699    begin
2700       if Is_Non_Empty_List (L) then
2701          loop
2702             N := Remove_Head (L);
2703             exit when No (N);
2704             Kill_Dead_Code (N);
2705          end loop;
2706       end if;
2707    end Kill_Dead_Code;
2708
2709    ------------------------
2710    -- Known_Non_Negative --
2711    ------------------------
2712
2713    function Known_Non_Negative (Opnd : Node_Id) return Boolean is
2714    begin
2715       if Is_OK_Static_Expression (Opnd)
2716         and then Expr_Value (Opnd) >= 0
2717       then
2718          return True;
2719
2720       else
2721          declare
2722             Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
2723
2724          begin
2725             return
2726               Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
2727          end;
2728       end if;
2729    end Known_Non_Negative;
2730
2731    --------------------
2732    -- Known_Non_Null --
2733    --------------------
2734
2735    function Known_Non_Null (N : Node_Id) return Boolean is
2736    begin
2737       pragma Assert (Is_Access_Type (Underlying_Type (Etype (N))));
2738
2739       --  Case of entity for which Is_Known_Non_Null is True
2740
2741       if Is_Entity_Name (N) and then Is_Known_Non_Null (Entity (N)) then
2742
2743          --  If the entity is aliased or volatile, then we decide that
2744          --  we don't know it is really non-null even if the sequential
2745          --  flow indicates that it is, since such variables can be
2746          --  changed without us noticing.
2747
2748          if Is_Aliased (Entity (N))
2749            or else Treat_As_Volatile (Entity (N))
2750          then
2751             return False;
2752
2753          --  For all other cases, the flag is decisive
2754
2755          else
2756             return True;
2757          end if;
2758
2759       --  True if access attribute
2760
2761       elsif Nkind (N) = N_Attribute_Reference
2762         and then (Attribute_Name (N) = Name_Access
2763                     or else
2764                   Attribute_Name (N) = Name_Unchecked_Access
2765                     or else
2766                   Attribute_Name (N) = Name_Unrestricted_Access)
2767       then
2768          return True;
2769
2770       --  True if allocator
2771
2772       elsif Nkind (N) = N_Allocator then
2773          return True;
2774
2775       --  For a conversion, true if expression is known non-null
2776
2777       elsif Nkind (N) = N_Type_Conversion then
2778          return Known_Non_Null (Expression (N));
2779
2780       --  One more case is when Current_Value references a condition
2781       --  that ensures a non-null value.
2782
2783       elsif Is_Entity_Name (N) then
2784          declare
2785             Op  : Node_Kind;
2786             Val : Node_Id;
2787
2788          begin
2789             Get_Current_Value_Condition (N, Op, Val);
2790             return Op = N_Op_Ne and then Nkind (Val) = N_Null;
2791          end;
2792
2793       --  Above are all cases where the value could be determined to be
2794       --  non-null. In all other cases, we don't know, so return False.
2795
2796       else
2797          return False;
2798       end if;
2799    end Known_Non_Null;
2800
2801    -----------------------------
2802    -- Make_CW_Equivalent_Type --
2803    -----------------------------
2804
2805    --  Create a record type used as an equivalent of any member
2806    --  of the class which takes its size from exp.
2807
2808    --  Generate the following code:
2809
2810    --   type Equiv_T is record
2811    --     _parent :  T (List of discriminant constaints taken from Exp);
2812    --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
2813    --   end Equiv_T;
2814    --
2815    --   ??? Note that this type does not guarantee same alignment as all
2816    --   derived types
2817
2818    function Make_CW_Equivalent_Type
2819      (T    : Entity_Id;
2820       E    : Node_Id)
2821       return Entity_Id
2822    is
2823       Loc         : constant Source_Ptr := Sloc (E);
2824       Root_Typ    : constant Entity_Id  := Root_Type (T);
2825       List_Def    : constant List_Id    := Empty_List;
2826       Equiv_Type  : Entity_Id;
2827       Range_Type  : Entity_Id;
2828       Str_Type    : Entity_Id;
2829       Constr_Root : Entity_Id;
2830       Sizexpr     : Node_Id;
2831
2832    begin
2833       if not Has_Discriminants (Root_Typ) then
2834          Constr_Root := Root_Typ;
2835       else
2836          Constr_Root :=
2837            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2838
2839          --  subtype cstr__n is T (List of discr constraints taken from Exp)
2840
2841          Append_To (List_Def,
2842            Make_Subtype_Declaration (Loc,
2843              Defining_Identifier => Constr_Root,
2844                Subtype_Indication =>
2845                  Make_Subtype_From_Expr (E, Root_Typ)));
2846       end if;
2847
2848       --  subtype rg__xx is Storage_Offset range
2849       --                           (Expr'size - typ'size) / Storage_Unit
2850
2851       Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
2852
2853       Sizexpr :=
2854         Make_Op_Subtract (Loc,
2855           Left_Opnd =>
2856             Make_Attribute_Reference (Loc,
2857               Prefix =>
2858                 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
2859               Attribute_Name => Name_Size),
2860           Right_Opnd =>
2861             Make_Attribute_Reference (Loc,
2862               Prefix => New_Reference_To (Constr_Root, Loc),
2863               Attribute_Name => Name_Object_Size));
2864
2865       Set_Paren_Count (Sizexpr, 1);
2866
2867       Append_To (List_Def,
2868         Make_Subtype_Declaration (Loc,
2869           Defining_Identifier => Range_Type,
2870           Subtype_Indication =>
2871             Make_Subtype_Indication (Loc,
2872               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
2873               Constraint => Make_Range_Constraint (Loc,
2874                 Range_Expression =>
2875                   Make_Range (Loc,
2876                     Low_Bound => Make_Integer_Literal (Loc, 1),
2877                     High_Bound =>
2878                       Make_Op_Divide (Loc,
2879                         Left_Opnd => Sizexpr,
2880                         Right_Opnd => Make_Integer_Literal (Loc,
2881                             Intval => System_Storage_Unit)))))));
2882
2883       --  subtype str__nn is Storage_Array (rg__x);
2884
2885       Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2886       Append_To (List_Def,
2887         Make_Subtype_Declaration (Loc,
2888           Defining_Identifier => Str_Type,
2889           Subtype_Indication =>
2890             Make_Subtype_Indication (Loc,
2891               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
2892               Constraint =>
2893                 Make_Index_Or_Discriminant_Constraint (Loc,
2894                   Constraints =>
2895                     New_List (New_Reference_To (Range_Type, Loc))))));
2896
2897       --  type Equiv_T is record
2898       --    _parent : Tnn;
2899       --    E : Str_Type;
2900       --  end Equiv_T;
2901
2902       Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2903
2904       --  When the target requires front-end layout, it's necessary to allow
2905       --  the equivalent type to be frozen so that layout can occur (when the
2906       --  associated class-wide subtype is frozen, the equivalent type will
2907       --  be frozen, see freeze.adb). For other targets, Gigi wants to have
2908       --  the equivalent type marked as frozen and deals with this type itself.
2909       --  In the Gigi case this will also avoid the generation of an init
2910       --  procedure for the type.
2911
2912       if not Frontend_Layout_On_Target then
2913          Set_Is_Frozen (Equiv_Type);
2914       end if;
2915
2916       Set_Ekind (Equiv_Type, E_Record_Type);
2917       Set_Parent_Subtype (Equiv_Type, Constr_Root);
2918
2919       Append_To (List_Def,
2920         Make_Full_Type_Declaration (Loc,
2921           Defining_Identifier => Equiv_Type,
2922
2923           Type_Definition =>
2924             Make_Record_Definition (Loc,
2925               Component_List => Make_Component_List (Loc,
2926                 Component_Items => New_List (
2927                   Make_Component_Declaration (Loc,
2928                     Defining_Identifier =>
2929                       Make_Defining_Identifier (Loc, Name_uParent),
2930                     Component_Definition =>
2931                       Make_Component_Definition (Loc,
2932                         Aliased_Present    => False,
2933                         Subtype_Indication =>
2934                           New_Reference_To (Constr_Root, Loc))),
2935
2936                   Make_Component_Declaration (Loc,
2937                     Defining_Identifier =>
2938                       Make_Defining_Identifier (Loc,
2939                         Chars => New_Internal_Name ('C')),
2940                     Component_Definition =>
2941                       Make_Component_Definition (Loc,
2942                         Aliased_Present    => False,
2943                         Subtype_Indication =>
2944                           New_Reference_To (Str_Type, Loc)))),
2945
2946                 Variant_Part => Empty))));
2947
2948       Insert_Actions (E, List_Def);
2949       return Equiv_Type;
2950    end Make_CW_Equivalent_Type;
2951
2952    ------------------------
2953    -- Make_Literal_Range --
2954    ------------------------
2955
2956    function Make_Literal_Range
2957      (Loc         : Source_Ptr;
2958       Literal_Typ : Entity_Id)
2959       return        Node_Id
2960    is
2961       Lo : constant Node_Id :=
2962              New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
2963
2964    begin
2965       Set_Analyzed (Lo, False);
2966
2967          return
2968            Make_Range (Loc,
2969              Low_Bound => Lo,
2970
2971              High_Bound =>
2972                Make_Op_Subtract (Loc,
2973                   Left_Opnd =>
2974                     Make_Op_Add (Loc,
2975                       Left_Opnd  => New_Copy_Tree (Lo),
2976                       Right_Opnd =>
2977                         Make_Integer_Literal (Loc,
2978                           String_Literal_Length (Literal_Typ))),
2979                   Right_Opnd => Make_Integer_Literal (Loc, 1)));
2980    end Make_Literal_Range;
2981
2982    ----------------------------
2983    -- Make_Subtype_From_Expr --
2984    ----------------------------
2985
2986    --  1. If Expr is an uncontrained array expression, creates
2987    --    Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
2988
2989    --  2. If Expr is a unconstrained discriminated type expression, creates
2990    --    Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
2991
2992    --  3. If Expr is class-wide, creates an implicit class wide subtype
2993
2994    function Make_Subtype_From_Expr
2995      (E       : Node_Id;
2996       Unc_Typ : Entity_Id)
2997       return    Node_Id
2998    is
2999       Loc         : constant Source_Ptr := Sloc (E);
3000       List_Constr : constant List_Id    := New_List;
3001       D           : Entity_Id;
3002
3003       Full_Subtyp  : Entity_Id;
3004       Priv_Subtyp  : Entity_Id;
3005       Utyp         : Entity_Id;
3006       Full_Exp     : Node_Id;
3007
3008    begin
3009       if Is_Private_Type (Unc_Typ)
3010         and then Has_Unknown_Discriminants (Unc_Typ)
3011       then
3012          --  Prepare the subtype completion, Go to base type to
3013          --  find underlying type.
3014
3015          Utyp        := Underlying_Type (Base_Type (Unc_Typ));
3016          Full_Subtyp := Make_Defining_Identifier (Loc,
3017                           New_Internal_Name ('C'));
3018          Full_Exp    :=
3019            Unchecked_Convert_To
3020              (Utyp, Duplicate_Subexpr_No_Checks (E));
3021          Set_Parent (Full_Exp, Parent (E));
3022
3023          Priv_Subtyp :=
3024            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3025
3026          Insert_Action (E,
3027            Make_Subtype_Declaration (Loc,
3028              Defining_Identifier => Full_Subtyp,
3029              Subtype_Indication  => Make_Subtype_From_Expr (Full_Exp, Utyp)));
3030
3031          --  Define the dummy private subtype
3032
3033          Set_Ekind          (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
3034          Set_Etype          (Priv_Subtyp, Unc_Typ);
3035          Set_Scope          (Priv_Subtyp, Full_Subtyp);
3036          Set_Is_Constrained (Priv_Subtyp);
3037          Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
3038          Set_Is_Itype       (Priv_Subtyp);
3039          Set_Associated_Node_For_Itype (Priv_Subtyp, E);
3040
3041          if Is_Tagged_Type  (Priv_Subtyp) then
3042             Set_Class_Wide_Type
3043               (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
3044             Set_Primitive_Operations (Priv_Subtyp,
3045               Primitive_Operations (Unc_Typ));
3046          end if;
3047
3048          Set_Full_View (Priv_Subtyp, Full_Subtyp);
3049
3050          return New_Reference_To (Priv_Subtyp, Loc);
3051
3052       elsif Is_Array_Type (Unc_Typ) then
3053          for J in 1 .. Number_Dimensions (Unc_Typ) loop
3054             Append_To (List_Constr,
3055               Make_Range (Loc,
3056                 Low_Bound =>
3057                   Make_Attribute_Reference (Loc,
3058                     Prefix => Duplicate_Subexpr_No_Checks (E),
3059                     Attribute_Name => Name_First,
3060                     Expressions => New_List (
3061                       Make_Integer_Literal (Loc, J))),
3062
3063                 High_Bound =>
3064                   Make_Attribute_Reference (Loc,
3065                     Prefix         => Duplicate_Subexpr_No_Checks (E),
3066                     Attribute_Name => Name_Last,
3067                     Expressions    => New_List (
3068                       Make_Integer_Literal (Loc, J)))));
3069          end loop;
3070
3071       elsif Is_Class_Wide_Type (Unc_Typ) then
3072          declare
3073             CW_Subtype : Entity_Id;
3074             EQ_Typ     : Entity_Id := Empty;
3075
3076          begin
3077             --  A class-wide equivalent type is not needed when Java_VM
3078             --  because the JVM back end handles the class-wide object
3079             --  initialization itself (and doesn't need or want the
3080             --  additional intermediate type to handle the assignment).
3081
3082             if Expander_Active and then not Java_VM then
3083                EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
3084             end if;
3085
3086             CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
3087             Set_Equivalent_Type (CW_Subtype, EQ_Typ);
3088
3089             if Present (EQ_Typ) then
3090                Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
3091             end if;
3092
3093             Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
3094
3095             return New_Occurrence_Of (CW_Subtype, Loc);
3096          end;
3097
3098       --  Comment needed (what case is this ???)
3099
3100       else
3101          D := First_Discriminant (Unc_Typ);
3102          while Present (D) loop
3103             Append_To (List_Constr,
3104               Make_Selected_Component (Loc,
3105                 Prefix        => Duplicate_Subexpr_No_Checks (E),
3106                 Selector_Name => New_Reference_To (D, Loc)));
3107
3108             Next_Discriminant (D);
3109          end loop;
3110       end if;
3111
3112       return
3113         Make_Subtype_Indication (Loc,
3114           Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
3115           Constraint   =>
3116             Make_Index_Or_Discriminant_Constraint (Loc,
3117               Constraints => List_Constr));
3118    end Make_Subtype_From_Expr;
3119
3120    -----------------------------
3121    -- May_Generate_Large_Temp --
3122    -----------------------------
3123
3124    --  At the current time, the only types that we return False for (i.e.
3125    --  where we decide we know they cannot generate large temps) are ones
3126    --  where we know the size is 128 bits or less at compile time, and we
3127    --  are still not doing a thorough job on arrays and records ???
3128
3129    function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
3130    begin
3131       if not Size_Known_At_Compile_Time (Typ) then
3132          return False;
3133
3134       elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
3135          return False;
3136
3137       elsif Is_Array_Type (Typ)
3138         and then Present (Packed_Array_Type (Typ))
3139       then
3140          return May_Generate_Large_Temp (Packed_Array_Type (Typ));
3141
3142       --  We could do more here to find other small types ???
3143
3144       else
3145          return True;
3146       end if;
3147    end May_Generate_Large_Temp;
3148
3149    ----------------------------
3150    -- New_Class_Wide_Subtype --
3151    ----------------------------
3152
3153    function New_Class_Wide_Subtype
3154      (CW_Typ : Entity_Id;
3155       N      : Node_Id)
3156       return   Entity_Id
3157    is
3158       Res       : constant Entity_Id := Create_Itype (E_Void, N);
3159       Res_Name  : constant Name_Id   := Chars (Res);
3160       Res_Scope : constant Entity_Id := Scope (Res);
3161
3162    begin
3163       Copy_Node (CW_Typ, Res);
3164       Set_Sloc (Res, Sloc (N));
3165       Set_Is_Itype (Res);
3166       Set_Associated_Node_For_Itype (Res, N);
3167       Set_Is_Public (Res, False);   --  By default, may be changed below.
3168       Set_Public_Status (Res);
3169       Set_Chars (Res, Res_Name);
3170       Set_Scope (Res, Res_Scope);
3171       Set_Ekind (Res, E_Class_Wide_Subtype);
3172       Set_Next_Entity (Res, Empty);
3173       Set_Etype (Res, Base_Type (CW_Typ));
3174
3175       --  For targets where front-end layout is required, reset the Is_Frozen
3176       --  status of the subtype to False (it can be implicitly set to true
3177       --  from the copy of the class-wide type). For other targets, Gigi
3178       --  doesn't want the class-wide subtype to go through the freezing
3179       --  process (though it's unclear why that causes problems and it would
3180       --  be nice to allow freezing to occur normally for all targets ???).
3181
3182       if Frontend_Layout_On_Target then
3183          Set_Is_Frozen (Res, False);
3184       end if;
3185
3186       Set_Freeze_Node (Res, Empty);
3187       return (Res);
3188    end New_Class_Wide_Subtype;
3189
3190    -------------------------
3191    -- Remove_Side_Effects --
3192    -------------------------
3193
3194    procedure Remove_Side_Effects
3195      (Exp          : Node_Id;
3196       Name_Req     : Boolean := False;
3197       Variable_Ref : Boolean := False)
3198    is
3199       Loc          : constant Source_Ptr := Sloc (Exp);
3200       Exp_Type     : constant Entity_Id      := Etype (Exp);
3201       Svg_Suppress : constant Suppress_Array := Scope_Suppress;
3202       Def_Id       : Entity_Id;
3203       Ref_Type     : Entity_Id;
3204       Res          : Node_Id;
3205       Ptr_Typ_Decl : Node_Id;
3206       New_Exp      : Node_Id;
3207       E            : Node_Id;
3208
3209       function Side_Effect_Free (N : Node_Id) return Boolean;
3210       --  Determines if the tree N represents an expession that is known
3211       --  not to have side effects, and for which no processing is required.
3212
3213       function Side_Effect_Free (L : List_Id) return Boolean;
3214       --  Determines if all elements of the list L are side effect free
3215
3216       function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
3217       --  The argument N is a construct where the Prefix is dereferenced
3218       --  if it is a an access type and the result is a variable. The call
3219       --  returns True if the construct is side effect free (not considering
3220       --  side effects in other than the prefix which are to be tested by the
3221       --  caller).
3222
3223       function Within_In_Parameter (N : Node_Id) return Boolean;
3224       --  Determines if N is a subcomponent of a composite in-parameter.
3225       --  If so, N is not side-effect free when the actual is global and
3226       --  modifiable indirectly from within a subprogram, because it may
3227       --  be passed by reference. The front-end must be conservative here
3228       --  and assume that this may happen with any array or record type.
3229       --  On the other hand, we cannot create temporaries for all expressions
3230       --  for which this condition is true, for various reasons that might
3231       --  require clearing up ??? For example, descriminant references that
3232       --  appear out of place, or spurious type errors with class-wide
3233       --  expressions. As a result, we limit the transformation to loop
3234       --  bounds, which is so far the only case that requires it.
3235
3236       -----------------------------
3237       -- Safe_Prefixed_Reference --
3238       -----------------------------
3239
3240       function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
3241       begin
3242          --  If prefix is not side effect free, definitely not safe
3243
3244          if not Side_Effect_Free (Prefix (N)) then
3245             return False;
3246
3247          --  If the prefix is of an access type that is not access-to-constant,
3248          --  then this construct is a variable reference, which means it is to
3249          --  be considered to have side effects if Variable_Ref is set True
3250          --  Exception is an access to an entity that is a constant or an
3251          --  in-parameter which does not come from source, and is the result
3252          --  of a previous removal of side-effects.
3253
3254          elsif Is_Access_Type (Etype (Prefix (N)))
3255            and then not Is_Access_Constant (Etype (Prefix (N)))
3256            and then Variable_Ref
3257          then
3258             if not Is_Entity_Name (Prefix (N)) then
3259                return False;
3260             else
3261                return Ekind (Entity (Prefix (N))) = E_Constant
3262                  or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
3263             end if;
3264
3265          --  The following test is the simplest way of solving a complex
3266          --  problem uncovered by BB08-010: Side effect on loop bound that
3267          --  is a subcomponent of a global variable:
3268          --    If a loop bound is a subcomponent of a global variable, a
3269          --    modification of that variable within the loop may incorrectly
3270          --    affect the execution of the loop.
3271
3272          elsif not
3273            (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
3274               or else not Within_In_Parameter (Prefix (N)))
3275          then
3276             return False;
3277
3278          --  All other cases are side effect free
3279
3280          else
3281             return True;
3282          end if;
3283       end Safe_Prefixed_Reference;
3284
3285       ----------------------
3286       -- Side_Effect_Free --
3287       ----------------------
3288
3289       function Side_Effect_Free (N : Node_Id) return Boolean is
3290       begin
3291          --  Note on checks that could raise Constraint_Error. Strictly, if
3292          --  we take advantage of 11.6, these checks do not count as side
3293          --  effects. However, we would just as soon consider that they are
3294          --  side effects, since the backend CSE does not work very well on
3295          --  expressions which can raise Constraint_Error. On the other
3296          --  hand, if we do not consider them to be side effect free, then
3297          --  we get some awkward expansions in -gnato mode, resulting in
3298          --  code insertions at a point where we do not have a clear model
3299          --  for performing the insertions. See 4908-002/comment for details.
3300
3301          --  Special handling for entity names
3302
3303          if Is_Entity_Name (N) then
3304
3305             --  If the entity is a constant, it is definitely side effect
3306             --  free. Note that the test of Is_Variable (N) below might
3307             --  be expected to catch this case, but it does not, because
3308             --  this test goes to the original tree, and we may have
3309             --  already rewritten a variable node with a constant as
3310             --  a result of an earlier Force_Evaluation call.
3311
3312             if Ekind (Entity (N)) = E_Constant
3313               or else Ekind (Entity (N)) = E_In_Parameter
3314             then
3315                return True;
3316
3317             --  Functions are not side effect free
3318
3319             elsif Ekind (Entity (N)) = E_Function then
3320                return False;
3321
3322             --  Variables are considered to be a side effect if Variable_Ref
3323             --  is set or if we have a volatile variable and Name_Req is off.
3324             --  If Name_Req is True then we can't help returning a name which
3325             --  effectively allows multiple references in any case.
3326
3327             elsif Is_Variable (N) then
3328                return not Variable_Ref
3329                  and then (not Treat_As_Volatile (Entity (N))
3330                              or else Name_Req);
3331
3332             --  Any other entity (e.g. a subtype name) is definitely side
3333             --  effect free.
3334
3335             else
3336                return True;
3337             end if;
3338
3339          --  A value known at compile time is always side effect free
3340
3341          elsif Compile_Time_Known_Value (N) then
3342             return True;
3343          end if;
3344
3345          --  For other than entity names and compile time known values,
3346          --  check the node kind for special processing.
3347
3348          case Nkind (N) is
3349
3350             --  An attribute reference is side effect free if its expressions
3351             --  are side effect free and its prefix is side effect free or
3352             --  is an entity reference.
3353
3354             --  Is this right? what about x'first where x is a variable???
3355
3356             when N_Attribute_Reference =>
3357                return Side_Effect_Free (Expressions (N))
3358                  and then (Is_Entity_Name (Prefix (N))
3359                             or else Side_Effect_Free (Prefix (N)));
3360
3361             --  A binary operator is side effect free if and both operands
3362             --  are side effect free. For this purpose binary operators
3363             --  include membership tests and short circuit forms
3364
3365             when N_Binary_Op |
3366                  N_In        |
3367                  N_Not_In    |
3368                  N_And_Then  |
3369                  N_Or_Else   =>
3370                return Side_Effect_Free (Left_Opnd  (N))
3371                  and then Side_Effect_Free (Right_Opnd (N));
3372
3373             --  An explicit dereference is side effect free only if it is
3374             --  a side effect free prefixed reference.
3375
3376             when N_Explicit_Dereference =>
3377                return Safe_Prefixed_Reference (N);
3378
3379             --  A call to _rep_to_pos is side effect free, since we generate
3380             --  this pure function call ourselves. Moreover it is critically
3381             --  important to make this exception, since otherwise we can
3382             --  have discriminants in array components which don't look
3383             --  side effect free in the case of an array whose index type
3384             --  is an enumeration type with an enumeration rep clause.
3385
3386             --  All other function calls are not side effect free
3387
3388             when N_Function_Call =>
3389                return Nkind (Name (N)) = N_Identifier
3390                  and then Is_TSS (Name (N), TSS_Rep_To_Pos)
3391                  and then
3392                    Side_Effect_Free (First (Parameter_Associations (N)));
3393
3394             --  An indexed component is side effect free if it is a side
3395             --  effect free prefixed reference and all the indexing
3396             --  expressions are side effect free.
3397
3398             when N_Indexed_Component =>
3399                return Side_Effect_Free (Expressions (N))
3400                  and then Safe_Prefixed_Reference (N);
3401
3402             --  A type qualification is side effect free if the expression
3403             --  is side effect free.
3404
3405             when N_Qualified_Expression =>
3406                return Side_Effect_Free (Expression (N));
3407
3408             --  A selected component is side effect free only if it is a
3409             --  side effect free prefixed reference.
3410
3411             when N_Selected_Component =>
3412                return Safe_Prefixed_Reference (N);
3413
3414             --  A range is side effect free if the bounds are side effect free
3415
3416             when N_Range =>
3417                return Side_Effect_Free (Low_Bound (N))
3418                  and then Side_Effect_Free (High_Bound (N));
3419
3420             --  A slice is side effect free if it is a side effect free
3421             --  prefixed reference and the bounds are side effect free.
3422
3423             when N_Slice =>
3424                return Side_Effect_Free (Discrete_Range (N))
3425                  and then Safe_Prefixed_Reference (N);
3426
3427             --  A type conversion is side effect free if the expression
3428             --  to be converted is side effect free.
3429
3430             when N_Type_Conversion =>
3431                return Side_Effect_Free (Expression (N));
3432
3433             --  A unary operator is side effect free if the operand
3434             --  is side effect free.
3435
3436             when N_Unary_Op =>
3437                return Side_Effect_Free (Right_Opnd (N));
3438
3439             --  An unchecked type conversion is side effect free only if it
3440             --  is safe and its argument is side effect free.
3441
3442             when N_Unchecked_Type_Conversion =>
3443                return Safe_Unchecked_Type_Conversion (N)
3444                  and then Side_Effect_Free (Expression (N));
3445
3446             --  An unchecked expression is side effect free if its expression
3447             --  is side effect free.
3448
3449             when N_Unchecked_Expression =>
3450                return Side_Effect_Free (Expression (N));
3451
3452             --  A literal is side effect free
3453
3454             when N_Character_Literal    |
3455                  N_Integer_Literal      |
3456                  N_Real_Literal         |
3457                  N_String_Literal       =>
3458                return True;
3459
3460             --  We consider that anything else has side effects. This is a bit
3461             --  crude, but we are pretty close for most common cases, and we
3462             --  are certainly correct (i.e. we never return True when the
3463             --  answer should be False).
3464
3465             when others =>
3466                return False;
3467          end case;
3468       end Side_Effect_Free;
3469
3470       --  A list is side effect free if all elements of the list are
3471       --  side effect free.
3472
3473       function Side_Effect_Free (L : List_Id) return Boolean is
3474          N : Node_Id;
3475
3476       begin
3477          if L = No_List or else L = Error_List then
3478             return True;
3479
3480          else
3481             N := First (L);
3482
3483             while Present (N) loop
3484                if not Side_Effect_Free (N) then
3485                   return False;
3486                else
3487                   Next (N);
3488                end if;
3489             end loop;
3490
3491             return True;
3492          end if;
3493       end Side_Effect_Free;
3494
3495       -------------------------
3496       -- Within_In_Parameter --
3497       -------------------------
3498
3499       function Within_In_Parameter (N : Node_Id) return Boolean is
3500       begin
3501          if not Comes_From_Source (N) then
3502             return False;
3503
3504          elsif Is_Entity_Name (N) then
3505             return
3506               Ekind (Entity (N)) = E_In_Parameter;
3507
3508          elsif Nkind (N) = N_Indexed_Component
3509            or else Nkind (N) = N_Selected_Component
3510          then
3511             return Within_In_Parameter (Prefix (N));
3512          else
3513
3514             return False;
3515          end if;
3516       end Within_In_Parameter;
3517
3518    --  Start of processing for Remove_Side_Effects
3519
3520    begin
3521       --  If we are side effect free already or expansion is disabled,
3522       --  there is nothing to do.
3523
3524       if Side_Effect_Free (Exp) or else not Expander_Active then
3525          return;
3526       end if;
3527
3528       --  All this must not have any checks
3529
3530       Scope_Suppress := (others => True);
3531
3532       --  If the expression has the form v.all then we can just capture
3533       --  the pointer, and then do an explicit dereference on the result.
3534
3535       if Nkind (Exp) = N_Explicit_Dereference then
3536          Def_Id :=
3537            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3538          Res :=
3539            Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
3540
3541          Insert_Action (Exp,
3542            Make_Object_Declaration (Loc,
3543              Defining_Identifier => Def_Id,
3544              Object_Definition   =>
3545                New_Reference_To (Etype (Prefix (Exp)), Loc),
3546              Constant_Present    => True,
3547              Expression          => Relocate_Node (Prefix (Exp))));
3548
3549       --  Similar processing for an unchecked conversion of an expression
3550       --  of the form v.all, where we want the same kind of treatment.
3551
3552       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
3553         and then Nkind (Expression (Exp)) = N_Explicit_Dereference
3554       then
3555          Remove_Side_Effects (Expression (Exp), Variable_Ref);
3556          Scope_Suppress := Svg_Suppress;
3557          return;
3558
3559       --  If this is a type conversion, leave the type conversion and remove
3560       --  the side effects in the expression. This is important in several
3561       --  circumstances: for change of representations, and also when this
3562       --  is a view conversion to a smaller object, where gigi can end up
3563       --  its own temporary of the wrong size.
3564
3565       --  ??? this transformation is inhibited for elementary types that are
3566       --  not involved in a change of representation because it causes
3567       --  regressions that are not fully understood yet.
3568
3569       elsif Nkind (Exp) = N_Type_Conversion
3570         and then (not Is_Elementary_Type (Underlying_Type (Exp_Type))
3571                    or else Nkind (Parent (Exp)) = N_Assignment_Statement)
3572       then
3573          Remove_Side_Effects (Expression (Exp), Variable_Ref);
3574          Scope_Suppress := Svg_Suppress;
3575          return;
3576
3577       --  For expressions that denote objects, we can use a renaming scheme.
3578       --  We skip using this if we have a volatile variable and we do not
3579       --  have Nam_Req set true (see comments above for Side_Effect_Free).
3580       --  We also skip this scheme for class-wide expressions in order to
3581       --  avoid recursive expansion (see Expand_N_Object_Renaming_Declaration)
3582       --  If the object is a function call, we need to create a temporary and
3583       --  not a renaming.
3584
3585       --  Note that we could use ordinary object declarations in the case of
3586       --  expressions not appearing as lvalues. That is left as a possible
3587       --  optimization in the future but we prefer to generate renamings
3588       --  right now, since we may indeed be transforming an lvalue.
3589
3590       elsif Is_Object_Reference (Exp)
3591         and then Nkind (Exp) /= N_Function_Call
3592         and then not Variable_Ref
3593         and then (Name_Req
3594                    or else not Is_Entity_Name (Exp)
3595                    or else not Treat_As_Volatile (Entity (Exp)))
3596         and then not Is_Class_Wide_Type (Exp_Type)
3597       then
3598          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3599
3600          if Nkind (Exp) = N_Selected_Component
3601            and then Nkind (Prefix (Exp)) = N_Function_Call
3602            and then Is_Array_Type (Etype (Exp))
3603          then
3604             --  Avoid generating a variable-sized temporary, by generating
3605             --  the renaming declaration just for the function call. The
3606             --  transformation could be refined to apply only when the array
3607             --  component is constrained by a discriminant???
3608
3609             Res :=
3610               Make_Selected_Component (Loc,
3611                 Prefix => New_Occurrence_Of (Def_Id, Loc),
3612                 Selector_Name => Selector_Name (Exp));
3613
3614             Insert_Action (Exp,
3615               Make_Object_Renaming_Declaration (Loc,
3616                 Defining_Identifier => Def_Id,
3617                 Subtype_Mark        =>
3618                   New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
3619                 Name                => Relocate_Node (Prefix (Exp))));
3620
3621             --  The temporary must be elaborated by gigi, and is of course
3622             --  not to be replaced in-line by the expression it renames,
3623             --  which would defeat the purpose of removing the side-effect.
3624
3625             Set_Is_Renaming_Of_Object (Def_Id, False);
3626
3627          else
3628             Res := New_Reference_To (Def_Id, Loc);
3629
3630             Insert_Action (Exp,
3631               Make_Object_Renaming_Declaration (Loc,
3632                 Defining_Identifier => Def_Id,
3633                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
3634                 Name                => Relocate_Node (Exp)));
3635
3636             Set_Is_Renaming_Of_Object (Def_Id, False);
3637          end if;
3638
3639       --  If it is a scalar type, just make a copy.
3640
3641       elsif Is_Elementary_Type (Exp_Type) then
3642          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3643          Set_Etype (Def_Id, Exp_Type);
3644          Res := New_Reference_To (Def_Id, Loc);
3645
3646          E :=
3647            Make_Object_Declaration (Loc,
3648              Defining_Identifier => Def_Id,
3649              Object_Definition   => New_Reference_To (Exp_Type, Loc),
3650              Constant_Present    => True,
3651              Expression          => Relocate_Node (Exp));
3652
3653          Set_Assignment_OK (E);
3654          Insert_Action (Exp, E);
3655
3656       --  Always use a renaming for an unchecked conversion
3657       --  If this is an unchecked conversion that Gigi can't handle, make
3658       --  a copy or a use a renaming to capture the value.
3659
3660       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
3661         and then not Safe_Unchecked_Type_Conversion (Exp)
3662       then
3663          if Controlled_Type (Etype (Exp)) then
3664
3665             --  Use a renaming to capture the expression, rather than create
3666             --  a controlled temporary.
3667
3668             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3669             Res := New_Reference_To (Def_Id, Loc);
3670
3671             Insert_Action (Exp,
3672               Make_Object_Renaming_Declaration (Loc,
3673                 Defining_Identifier => Def_Id,
3674                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
3675                 Name                => Relocate_Node (Exp)));
3676
3677          else
3678             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3679             Set_Etype (Def_Id, Exp_Type);
3680             Res := New_Reference_To (Def_Id, Loc);
3681
3682             E :=
3683               Make_Object_Declaration (Loc,
3684                 Defining_Identifier => Def_Id,
3685                 Object_Definition   => New_Reference_To (Exp_Type, Loc),
3686                 Constant_Present    => not Is_Variable (Exp),
3687                 Expression          => Relocate_Node (Exp));
3688
3689             Set_Assignment_OK (E);
3690             Insert_Action (Exp, E);
3691          end if;
3692
3693       --  Otherwise we generate a reference to the value
3694
3695       else
3696          Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
3697
3698          Ptr_Typ_Decl :=
3699            Make_Full_Type_Declaration (Loc,
3700              Defining_Identifier => Ref_Type,
3701              Type_Definition =>
3702                Make_Access_To_Object_Definition (Loc,
3703                  All_Present => True,
3704                  Subtype_Indication =>
3705                    New_Reference_To (Exp_Type, Loc)));
3706
3707          E := Exp;
3708          Insert_Action (Exp, Ptr_Typ_Decl);
3709
3710          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3711          Set_Etype (Def_Id, Exp_Type);
3712
3713          Res :=
3714            Make_Explicit_Dereference (Loc,
3715              Prefix => New_Reference_To (Def_Id, Loc));
3716
3717          if Nkind (E) = N_Explicit_Dereference then
3718             New_Exp := Relocate_Node (Prefix (E));
3719          else
3720             E := Relocate_Node (E);
3721             New_Exp := Make_Reference (Loc, E);
3722          end if;
3723
3724          if Nkind (E) = N_Aggregate and then Expansion_Delayed (E) then
3725             Set_Expansion_Delayed (E, False);
3726             Set_Analyzed (E, False);
3727          end if;
3728
3729          Insert_Action (Exp,
3730            Make_Object_Declaration (Loc,
3731              Defining_Identifier => Def_Id,
3732              Object_Definition   => New_Reference_To (Ref_Type, Loc),
3733              Expression          => New_Exp));
3734       end if;
3735
3736       --  Preserve the Assignment_OK flag in all copies, since at least
3737       --  one copy may be used in a context where this flag must be set
3738       --  (otherwise why would the flag be set in the first place).
3739
3740       Set_Assignment_OK (Res, Assignment_OK (Exp));
3741
3742       --  Finally rewrite the original expression and we are done
3743
3744       Rewrite (Exp, Res);
3745       Analyze_And_Resolve (Exp, Exp_Type);
3746       Scope_Suppress := Svg_Suppress;
3747    end Remove_Side_Effects;
3748
3749    ------------------------------------
3750    -- Safe_Unchecked_Type_Conversion --
3751    ------------------------------------
3752
3753    --  Note: this function knows quite a bit about the exact requirements
3754    --  of Gigi with respect to unchecked type conversions, and its code
3755    --  must be coordinated with any changes in Gigi in this area.
3756
3757    --  The above requirements should be documented in Sinfo ???
3758
3759    function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
3760       Otyp   : Entity_Id;
3761       Ityp   : Entity_Id;
3762       Oalign : Uint;
3763       Ialign : Uint;
3764       Pexp   : constant Node_Id := Parent (Exp);
3765
3766    begin
3767       --  If the expression is the RHS of an assignment or object declaration
3768       --   we are always OK because there will always be a target.
3769
3770       --  Object renaming declarations, (generated for view conversions of
3771       --  actuals in inlined calls), like object declarations, provide an
3772       --  explicit type, and are safe as well.
3773
3774       if (Nkind (Pexp) = N_Assignment_Statement
3775            and then Expression (Pexp) = Exp)
3776         or else Nkind (Pexp) = N_Object_Declaration
3777         or else Nkind (Pexp) = N_Object_Renaming_Declaration
3778       then
3779          return True;
3780
3781       --  If the expression is the prefix of an N_Selected_Component
3782       --  we should also be OK because GCC knows to look inside the
3783       --  conversion except if the type is discriminated. We assume
3784       --  that we are OK anyway if the type is not set yet or if it is
3785       --  controlled since we can't afford to introduce a temporary in
3786       --  this case.
3787
3788       elsif Nkind (Pexp) = N_Selected_Component
3789          and then Prefix (Pexp) = Exp
3790       then
3791          if No (Etype (Pexp)) then
3792             return True;
3793          else
3794             return
3795               not Has_Discriminants (Etype (Pexp))
3796                 or else Is_Constrained (Etype (Pexp));
3797          end if;
3798       end if;
3799
3800       --  Set the output type, this comes from Etype if it is set, otherwise
3801       --  we take it from the subtype mark, which we assume was already
3802       --  fully analyzed.
3803
3804       if Present (Etype (Exp)) then
3805          Otyp := Etype (Exp);
3806       else
3807          Otyp := Entity (Subtype_Mark (Exp));
3808       end if;
3809
3810       --  The input type always comes from the expression, and we assume
3811       --  this is indeed always analyzed, so we can simply get the Etype.
3812
3813       Ityp := Etype (Expression (Exp));
3814
3815       --  Initialize alignments to unknown so far
3816
3817       Oalign := No_Uint;
3818       Ialign := No_Uint;
3819
3820       --  Replace a concurrent type by its corresponding record type
3821       --  and each type by its underlying type and do the tests on those.
3822       --  The original type may be a private type whose completion is a
3823       --  concurrent type, so find the underlying type first.
3824
3825       if Present (Underlying_Type (Otyp)) then
3826          Otyp := Underlying_Type (Otyp);
3827       end if;
3828
3829       if Present (Underlying_Type (Ityp)) then
3830          Ityp := Underlying_Type (Ityp);
3831       end if;
3832
3833       if Is_Concurrent_Type (Otyp) then
3834          Otyp := Corresponding_Record_Type (Otyp);
3835       end if;
3836
3837       if Is_Concurrent_Type (Ityp) then
3838          Ityp := Corresponding_Record_Type (Ityp);
3839       end if;
3840
3841       --  If the base types are the same, we know there is no problem since
3842       --  this conversion will be a noop.
3843
3844       if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
3845          return True;
3846
3847       --  If the size of output type is known at compile time, there is
3848       --  never a problem.  Note that unconstrained records are considered
3849       --  to be of known size, but we can't consider them that way here,
3850       --  because we are talking about the actual size of the object.
3851
3852       --  We also make sure that in addition to the size being known, we do
3853       --  not have a case which might generate an embarrassingly large temp
3854       --  in stack checking mode.
3855
3856       elsif Size_Known_At_Compile_Time (Otyp)
3857         and then
3858           (not Stack_Checking_Enabled
3859              or else not May_Generate_Large_Temp (Otyp))
3860         and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
3861       then
3862          return True;
3863
3864       --  If either type is tagged, then we know the alignment is OK so
3865       --  Gigi will be able to use pointer punning.
3866
3867       elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
3868          return True;
3869
3870       --  If either type is a limited record type, we cannot do a copy, so
3871       --  say safe since there's nothing else we can do.
3872
3873       elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
3874          return True;
3875
3876       --  Conversions to and from packed array types are always ignored and
3877       --  hence are safe.
3878
3879       elsif Is_Packed_Array_Type (Otyp)
3880         or else Is_Packed_Array_Type (Ityp)
3881       then
3882          return True;
3883       end if;
3884
3885       --  The only other cases known to be safe is if the input type's
3886       --  alignment is known to be at least the maximum alignment for the
3887       --  target or if both alignments are known and the output type's
3888       --  alignment is no stricter than the input's.  We can use the alignment
3889       --  of the component type of an array if a type is an unpacked
3890       --  array type.
3891
3892       if Present (Alignment_Clause (Otyp)) then
3893          Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
3894
3895       elsif Is_Array_Type (Otyp)
3896         and then Present (Alignment_Clause (Component_Type (Otyp)))
3897       then
3898          Oalign := Expr_Value (Expression (Alignment_Clause
3899                                            (Component_Type (Otyp))));
3900       end if;
3901
3902       if Present (Alignment_Clause (Ityp)) then
3903          Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
3904
3905       elsif Is_Array_Type (Ityp)
3906         and then Present (Alignment_Clause (Component_Type (Ityp)))
3907       then
3908          Ialign := Expr_Value (Expression (Alignment_Clause
3909                                            (Component_Type (Ityp))));
3910       end if;
3911
3912       if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
3913          return True;
3914
3915       elsif Ialign /= No_Uint and then Oalign /= No_Uint
3916         and then Ialign <= Oalign
3917       then
3918          return True;
3919
3920       --   Otherwise, Gigi cannot handle this and we must make a temporary.
3921
3922       else
3923          return False;
3924       end if;
3925
3926    end Safe_Unchecked_Type_Conversion;
3927
3928    --------------------------
3929    -- Set_Elaboration_Flag --
3930    --------------------------
3931
3932    procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
3933       Loc : constant Source_Ptr := Sloc (N);
3934       Ent : constant Entity_Id  := Elaboration_Entity (Spec_Id);
3935       Asn : Node_Id;
3936
3937    begin
3938       if Present (Ent) then
3939
3940          --  Nothing to do if at the compilation unit level, because in this
3941          --  case the flag is set by the binder generated elaboration routine.
3942
3943          if Nkind (Parent (N)) = N_Compilation_Unit then
3944             null;
3945
3946          --  Here we do need to generate an assignment statement
3947
3948          else
3949             Check_Restriction (No_Elaboration_Code, N);
3950             Asn :=
3951               Make_Assignment_Statement (Loc,
3952                 Name       => New_Occurrence_Of (Ent, Loc),
3953                 Expression => New_Occurrence_Of (Standard_True, Loc));
3954
3955             if Nkind (Parent (N)) = N_Subunit then
3956                Insert_After (Corresponding_Stub (Parent (N)), Asn);
3957             else
3958                Insert_After (N, Asn);
3959             end if;
3960
3961             Analyze (Asn);
3962
3963             --  Kill current value indication. This is necessary because
3964             --  the tests of this flag are inserted out of sequence and must
3965             --  not pick up bogus indications of the wrong constant value.
3966
3967             Set_Current_Value (Ent, Empty);
3968          end if;
3969       end if;
3970    end Set_Elaboration_Flag;
3971
3972    --------------------------
3973    -- Target_Has_Fixed_Ops --
3974    --------------------------
3975
3976    Integer_Sized_Small : Ureal;
3977    --  Set to 2.0 ** -(Integer'Size - 1) the first time that this
3978    --  function is called (we don't want to compute it more than once!)
3979
3980    Long_Integer_Sized_Small : Ureal;
3981    --  Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
3982    --  functoin is called (we don't want to compute it more than once)
3983
3984    First_Time_For_THFO : Boolean := True;
3985    --  Set to False after first call (if Fractional_Fixed_Ops_On_Target)
3986
3987    function Target_Has_Fixed_Ops
3988      (Left_Typ   : Entity_Id;
3989       Right_Typ  : Entity_Id;
3990       Result_Typ : Entity_Id)
3991       return       Boolean
3992    is
3993       function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
3994       --  Return True if the given type is a fixed-point type with a small
3995       --  value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
3996       --  an absolute value less than 1.0. This is currently limited
3997       --  to fixed-point types that map to Integer or Long_Integer.
3998
3999       ------------------------
4000       -- Is_Fractional_Type --
4001       ------------------------
4002
4003       function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
4004       begin
4005          if Esize (Typ) = Standard_Integer_Size then
4006             return Small_Value (Typ) = Integer_Sized_Small;
4007
4008          elsif Esize (Typ) = Standard_Long_Integer_Size then
4009             return Small_Value (Typ) = Long_Integer_Sized_Small;
4010
4011          else
4012             return False;
4013          end if;
4014       end Is_Fractional_Type;
4015
4016    --  Start of processing for Target_Has_Fixed_Ops
4017
4018    begin
4019       --  Return False if Fractional_Fixed_Ops_On_Target is false
4020
4021       if not Fractional_Fixed_Ops_On_Target then
4022          return False;
4023       end if;
4024
4025       --  Here the target has Fractional_Fixed_Ops, if first time, compute
4026       --  standard constants used by Is_Fractional_Type.
4027
4028       if First_Time_For_THFO then
4029          First_Time_For_THFO := False;
4030
4031          Integer_Sized_Small :=
4032            UR_From_Components
4033              (Num   => Uint_1,
4034               Den   => UI_From_Int (Standard_Integer_Size - 1),
4035               Rbase => 2);
4036
4037          Long_Integer_Sized_Small :=
4038            UR_From_Components
4039              (Num   => Uint_1,
4040               Den   => UI_From_Int (Standard_Long_Integer_Size - 1),
4041               Rbase => 2);
4042       end if;
4043
4044       --  Return True if target supports fixed-by-fixed multiply/divide
4045       --  for fractional fixed-point types (see Is_Fractional_Type) and
4046       --  the operand and result types are equivalent fractional types.
4047
4048       return Is_Fractional_Type (Base_Type (Left_Typ))
4049         and then Is_Fractional_Type (Base_Type (Right_Typ))
4050         and then Is_Fractional_Type (Base_Type (Result_Typ))
4051         and then Esize (Left_Typ) = Esize (Right_Typ)
4052         and then Esize (Left_Typ) = Esize (Result_Typ);
4053    end Target_Has_Fixed_Ops;
4054
4055    ------------------------------------------
4056    -- Type_May_Have_Bit_Aligned_Components --
4057    ------------------------------------------
4058
4059    function Type_May_Have_Bit_Aligned_Components
4060      (Typ : Entity_Id) return Boolean
4061    is
4062    begin
4063       --  Array type, check component type
4064
4065       if Is_Array_Type (Typ) then
4066          return
4067            Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
4068
4069       --  Record type, check components
4070
4071       elsif Is_Record_Type (Typ) then
4072          declare
4073             E : Entity_Id;
4074
4075          begin
4076             E := First_Entity (Typ);
4077             while Present (E) loop
4078                if Ekind (E) = E_Component
4079                  or else Ekind (E) = E_Discriminant
4080                then
4081                   if Component_May_Be_Bit_Aligned (E)
4082                     or else
4083                       Type_May_Have_Bit_Aligned_Components (Etype (E))
4084                   then
4085                      return True;
4086                   end if;
4087                end if;
4088
4089                Next_Entity (E);
4090             end loop;
4091
4092             return False;
4093          end;
4094
4095       --  Type other than array or record is always OK
4096
4097       else
4098          return False;
4099       end if;
4100    end Type_May_Have_Bit_Aligned_Components;
4101
4102    ----------------------------
4103    -- Wrap_Cleanup_Procedure --
4104    ----------------------------
4105
4106    procedure Wrap_Cleanup_Procedure (N : Node_Id) is
4107       Loc   : constant Source_Ptr := Sloc (N);
4108       Stseq : constant Node_Id    := Handled_Statement_Sequence (N);
4109       Stmts : constant List_Id    := Statements (Stseq);
4110
4111    begin
4112       if Abort_Allowed then
4113          Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
4114          Append_To  (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4115       end if;
4116    end Wrap_Cleanup_Procedure;
4117
4118 end Exp_Util;