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