gcc/ada/exp_util.adb

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