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