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