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