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