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