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