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