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