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