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_Init_Call --
1403    --------------------
1404
1405    function Find_Init_Call
1406      (Var        : Entity_Id;
1407       Rep_Clause : Node_Id) return Node_Id
1408    is
1409       Typ : constant Entity_Id := Etype (Var);
1410
1411       Init_Proc : Entity_Id;
1412       --  Initialization procedure for Typ
1413
1414       function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
1415       --  Look for init call for Var starting at From and scanning the
1416       --  enclosing list until Rep_Clause or the end of the list is reached.
1417
1418       ----------------------------
1419       -- Find_Init_Call_In_List --
1420       ----------------------------
1421
1422       function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
1423          Init_Call : Node_Id;
1424       begin
1425          Init_Call := From;
1426
1427          while Present (Init_Call) and then Init_Call /= Rep_Clause loop
1428             if Nkind (Init_Call) = N_Procedure_Call_Statement
1429                  and then Is_Entity_Name (Name (Init_Call))
1430                  and then Entity (Name (Init_Call)) = Init_Proc
1431             then
1432                return Init_Call;
1433             end if;
1434             Next (Init_Call);
1435          end loop;
1436
1437          return Empty;
1438       end Find_Init_Call_In_List;
1439
1440       Init_Call : Node_Id;
1441
1442    --  Start of processing for Find_Init_Call
1443
1444    begin
1445       if not Has_Non_Null_Base_Init_Proc (Typ) then
1446          --  No init proc for the type, so obviously no call to be found
1447
1448          return Empty;
1449       end if;
1450
1451       Init_Proc := Base_Init_Proc (Typ);
1452
1453       --  First scan the list containing the declaration of Var
1454
1455       Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
1456
1457       --  If not found, also look on Var's freeze actions list, if any, since
1458       --  the init call may have been moved there (case of an address clause
1459       --  applying to Var).
1460
1461       if No (Init_Call) and then Present (Freeze_Node (Var)) then
1462          Init_Call := Find_Init_Call_In_List
1463                         (First (Actions (Freeze_Node (Var))));
1464       end if;
1465
1466       return Init_Call;
1467    end Find_Init_Call;
1468
1469    ------------------------
1470    -- Find_Interface_ADT --
1471    ------------------------
1472
1473    function Find_Interface_ADT
1474      (T     : Entity_Id;
1475       Iface : Entity_Id) return Elmt_Id
1476    is
1477       ADT : Elmt_Id;
1478       Typ : Entity_Id := T;
1479
1480    begin
1481       pragma Assert (Is_Interface (Iface));
1482
1483       --  Handle private types
1484
1485       if Has_Private_Declaration (Typ)
1486         and then Present (Full_View (Typ))
1487       then
1488          Typ := Full_View (Typ);
1489       end if;
1490
1491       --  Handle access types
1492
1493       if Is_Access_Type (Typ) then
1494          Typ := Directly_Designated_Type (Typ);
1495       end if;
1496
1497       --  Handle task and protected types implementing interfaces
1498
1499       if Is_Concurrent_Type (Typ) then
1500          Typ := Corresponding_Record_Type (Typ);
1501       end if;
1502
1503       pragma Assert
1504         (not Is_Class_Wide_Type (Typ)
1505           and then Ekind (Typ) /= E_Incomplete_Type);
1506
1507       if Is_Ancestor (Iface, Typ) then
1508          return First_Elmt (Access_Disp_Table (Typ));
1509
1510       else
1511          ADT :=
1512            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
1513          while Present (ADT)
1514            and then Present (Related_Type (Node (ADT)))
1515            and then Related_Type (Node (ADT)) /= Iface
1516            and then not Is_Ancestor (Iface, Related_Type (Node (ADT)))
1517          loop
1518             Next_Elmt (ADT);
1519          end loop;
1520
1521          pragma Assert (Present (Related_Type (Node (ADT))));
1522          return ADT;
1523       end if;
1524    end Find_Interface_ADT;
1525
1526    ------------------------
1527    -- Find_Interface_Tag --
1528    ------------------------
1529
1530    function Find_Interface_Tag
1531      (T     : Entity_Id;
1532       Iface : Entity_Id) return Entity_Id
1533    is
1534       AI_Tag : Entity_Id;
1535       Found  : Boolean   := False;
1536       Typ    : Entity_Id := T;
1537
1538       procedure Find_Tag (Typ : Entity_Id);
1539       --  Internal subprogram used to recursively climb to the ancestors
1540
1541       --------------
1542       -- Find_Tag --
1543       --------------
1544
1545       procedure Find_Tag (Typ : Entity_Id) is
1546          AI_Elmt : Elmt_Id;
1547          AI      : Node_Id;
1548
1549       begin
1550          --  Check if the interface is an immediate ancestor of the type and
1551          --  therefore shares the main tag.
1552
1553          if Typ = Iface then
1554             pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1555             AI_Tag := First_Tag_Component (Typ);
1556             Found  := True;
1557             return;
1558          end if;
1559
1560          --  Climb to the root type handling private types
1561
1562          if Present (Full_View (Etype (Typ))) then
1563             if Full_View (Etype (Typ)) /= Typ then
1564                Find_Tag (Full_View (Etype (Typ)));
1565             end if;
1566
1567          elsif Etype (Typ) /= Typ then
1568             Find_Tag (Etype (Typ));
1569          end if;
1570
1571          --  Traverse the list of interfaces implemented by the type
1572
1573          if not Found
1574            and then Present (Interfaces (Typ))
1575            and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
1576          then
1577             --  Skip the tag associated with the primary table
1578
1579             pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1580             AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
1581             pragma Assert (Present (AI_Tag));
1582
1583             AI_Elmt := First_Elmt (Interfaces (Typ));
1584             while Present (AI_Elmt) loop
1585                AI := Node (AI_Elmt);
1586
1587                if AI = Iface or else Is_Ancestor (Iface, AI) then
1588                   Found := True;
1589                   return;
1590                end if;
1591
1592                AI_Tag := Next_Tag_Component (AI_Tag);
1593                Next_Elmt (AI_Elmt);
1594             end loop;
1595          end if;
1596       end Find_Tag;
1597
1598    --  Start of processing for Find_Interface_Tag
1599
1600    begin
1601       pragma Assert (Is_Interface (Iface));
1602
1603       --  Handle private types
1604
1605       if Has_Private_Declaration (Typ)
1606         and then Present (Full_View (Typ))
1607       then
1608          Typ := Full_View (Typ);
1609       end if;
1610
1611       --  Handle access types
1612
1613       if Is_Access_Type (Typ) then
1614          Typ := Directly_Designated_Type (Typ);
1615       end if;
1616
1617       --  Handle task and protected types implementing interfaces
1618
1619       if Is_Concurrent_Type (Typ) then
1620          Typ := Corresponding_Record_Type (Typ);
1621       end if;
1622
1623       if Is_Class_Wide_Type (Typ) then
1624          Typ := Etype (Typ);
1625       end if;
1626
1627       --  Handle entities from the limited view
1628
1629       if Ekind (Typ) = E_Incomplete_Type then
1630          pragma Assert (Present (Non_Limited_View (Typ)));
1631          Typ := Non_Limited_View (Typ);
1632       end if;
1633
1634       Find_Tag (Typ);
1635       pragma Assert (Found);
1636       return AI_Tag;
1637    end Find_Interface_Tag;
1638
1639    ------------------
1640    -- Find_Prim_Op --
1641    ------------------
1642
1643    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1644       Prim : Elmt_Id;
1645       Typ  : Entity_Id := T;
1646       Op   : Entity_Id;
1647
1648    begin
1649       if Is_Class_Wide_Type (Typ) then
1650          Typ := Root_Type (Typ);
1651       end if;
1652
1653       Typ := Underlying_Type (Typ);
1654
1655       --  Loop through primitive operations
1656
1657       Prim := First_Elmt (Primitive_Operations (Typ));
1658       while Present (Prim) loop
1659          Op := Node (Prim);
1660
1661          --  We can retrieve primitive operations by name if it is an internal
1662          --  name. For equality we must check that both of its operands have
1663          --  the same type, to avoid confusion with user-defined equalities
1664          --  than may have a non-symmetric signature.
1665
1666          exit when Chars (Op) = Name
1667            and then
1668              (Name /= Name_Op_Eq
1669                 or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op)));
1670
1671          Next_Elmt (Prim);
1672
1673          --  Raise Program_Error if no primitive found
1674
1675          if No (Prim) then
1676             raise Program_Error;
1677          end if;
1678       end loop;
1679
1680       return Node (Prim);
1681    end Find_Prim_Op;
1682
1683    ------------------
1684    -- Find_Prim_Op --
1685    ------------------
1686
1687    function Find_Prim_Op
1688      (T    : Entity_Id;
1689       Name : TSS_Name_Type) return Entity_Id
1690    is
1691       Prim : Elmt_Id;
1692       Typ  : Entity_Id := T;
1693
1694    begin
1695       if Is_Class_Wide_Type (Typ) then
1696          Typ := Root_Type (Typ);
1697       end if;
1698
1699       Typ := Underlying_Type (Typ);
1700
1701       Prim := First_Elmt (Primitive_Operations (Typ));
1702       while not Is_TSS (Node (Prim), Name) loop
1703          Next_Elmt (Prim);
1704
1705          --  Raise program error if no primitive found
1706
1707          if No (Prim) then
1708             raise Program_Error;
1709          end if;
1710       end loop;
1711
1712       return Node (Prim);
1713    end Find_Prim_Op;
1714
1715    ----------------------------
1716    -- Find_Protection_Object --
1717    ----------------------------
1718
1719    function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
1720       S : Entity_Id;
1721
1722    begin
1723       S := Scop;
1724       while Present (S) loop
1725          if (Ekind (S) = E_Entry
1726                or else Ekind (S) = E_Entry_Family
1727                or else Ekind (S) = E_Function
1728                or else Ekind (S) = E_Procedure)
1729            and then Present (Protection_Object (S))
1730          then
1731             return Protection_Object (S);
1732          end if;
1733
1734          S := Scope (S);
1735       end loop;
1736
1737       --  If we do not find a Protection object in the scope chain, then
1738       --  something has gone wrong, most likely the object was never created.
1739
1740       raise Program_Error;
1741    end Find_Protection_Object;
1742
1743    ----------------------
1744    -- Force_Evaluation --
1745    ----------------------
1746
1747    procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1748    begin
1749       Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
1750    end Force_Evaluation;
1751
1752    ------------------------
1753    -- Generate_Poll_Call --
1754    ------------------------
1755
1756    procedure Generate_Poll_Call (N : Node_Id) is
1757    begin
1758       --  No poll call if polling not active
1759
1760       if not Polling_Required then
1761          return;
1762
1763       --  Otherwise generate require poll call
1764
1765       else
1766          Insert_Before_And_Analyze (N,
1767            Make_Procedure_Call_Statement (Sloc (N),
1768              Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1769       end if;
1770    end Generate_Poll_Call;
1771
1772    ---------------------------------
1773    -- Get_Current_Value_Condition --
1774    ---------------------------------
1775
1776    --  Note: the implementation of this procedure is very closely tied to the
1777    --  implementation of Set_Current_Value_Condition. In the Get procedure, we
1778    --  interpret Current_Value fields set by the Set procedure, so the two
1779    --  procedures need to be closely coordinated.
1780
1781    procedure Get_Current_Value_Condition
1782      (Var : Node_Id;
1783       Op  : out Node_Kind;
1784       Val : out Node_Id)
1785    is
1786       Loc : constant Source_Ptr := Sloc (Var);
1787       Ent : constant Entity_Id  := Entity (Var);
1788
1789       procedure Process_Current_Value_Condition
1790         (N : Node_Id;
1791          S : Boolean);
1792       --  N is an expression which holds either True (S = True) or False (S =
1793       --  False) in the condition. This procedure digs out the expression and
1794       --  if it refers to Ent, sets Op and Val appropriately.
1795
1796       -------------------------------------
1797       -- Process_Current_Value_Condition --
1798       -------------------------------------
1799
1800       procedure Process_Current_Value_Condition
1801         (N : Node_Id;
1802          S : Boolean)
1803       is
1804          Cond : Node_Id;
1805          Sens : Boolean;
1806
1807       begin
1808          Cond := N;
1809          Sens := S;
1810
1811          --  Deal with NOT operators, inverting sense
1812
1813          while Nkind (Cond) = N_Op_Not loop
1814             Cond := Right_Opnd (Cond);
1815             Sens := not Sens;
1816          end loop;
1817
1818          --  Deal with AND THEN and AND cases
1819
1820          if Nkind (Cond) = N_And_Then
1821            or else Nkind (Cond) = N_Op_And
1822          then
1823             --  Don't ever try to invert a condition that is of the form
1824             --  of an AND or AND THEN (since we are not doing sufficiently
1825             --  general processing to allow this).
1826
1827             if Sens = False then
1828                Op  := N_Empty;
1829                Val := Empty;
1830                return;
1831             end if;
1832
1833             --  Recursively process AND and AND THEN branches
1834
1835             Process_Current_Value_Condition (Left_Opnd (Cond), True);
1836
1837             if Op /= N_Empty then
1838                return;
1839             end if;
1840
1841             Process_Current_Value_Condition (Right_Opnd (Cond), True);
1842             return;
1843
1844          --  Case of relational operator
1845
1846          elsif Nkind (Cond) in N_Op_Compare then
1847             Op := Nkind (Cond);
1848
1849             --  Invert sense of test if inverted test
1850
1851             if Sens = False then
1852                case Op is
1853                   when N_Op_Eq => Op := N_Op_Ne;
1854                   when N_Op_Ne => Op := N_Op_Eq;
1855                   when N_Op_Lt => Op := N_Op_Ge;
1856                   when N_Op_Gt => Op := N_Op_Le;
1857                   when N_Op_Le => Op := N_Op_Gt;
1858                   when N_Op_Ge => Op := N_Op_Lt;
1859                   when others  => raise Program_Error;
1860                end case;
1861             end if;
1862
1863             --  Case of entity op value
1864
1865             if Is_Entity_Name (Left_Opnd (Cond))
1866               and then Ent = Entity (Left_Opnd (Cond))
1867               and then Compile_Time_Known_Value (Right_Opnd (Cond))
1868             then
1869                Val := Right_Opnd (Cond);
1870
1871             --  Case of value op entity
1872
1873             elsif Is_Entity_Name (Right_Opnd (Cond))
1874               and then Ent = Entity (Right_Opnd (Cond))
1875               and then Compile_Time_Known_Value (Left_Opnd (Cond))
1876             then
1877                Val := Left_Opnd (Cond);
1878
1879                --  We are effectively swapping operands
1880
1881                case Op is
1882                   when N_Op_Eq => null;
1883                   when N_Op_Ne => null;
1884                   when N_Op_Lt => Op := N_Op_Gt;
1885                   when N_Op_Gt => Op := N_Op_Lt;
1886                   when N_Op_Le => Op := N_Op_Ge;
1887                   when N_Op_Ge => Op := N_Op_Le;
1888                   when others  => raise Program_Error;
1889                end case;
1890
1891             else
1892                Op := N_Empty;
1893             end if;
1894
1895             return;
1896
1897             --  Case of Boolean variable reference, return as though the
1898             --  reference had said var = True.
1899
1900          else
1901             if Is_Entity_Name (Cond)
1902               and then Ent = Entity (Cond)
1903             then
1904                Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
1905
1906                if Sens = False then
1907                   Op := N_Op_Ne;
1908                else
1909                   Op := N_Op_Eq;
1910                end if;
1911             end if;
1912          end if;
1913       end Process_Current_Value_Condition;
1914
1915    --  Start of processing for Get_Current_Value_Condition
1916
1917    begin
1918       Op  := N_Empty;
1919       Val := Empty;
1920
1921       --  Immediate return, nothing doing, if this is not an object
1922
1923       if Ekind (Ent) not in Object_Kind then
1924          return;
1925       end if;
1926
1927       --  Otherwise examine current value
1928
1929       declare
1930          CV   : constant Node_Id := Current_Value (Ent);
1931          Sens : Boolean;
1932          Stm  : Node_Id;
1933
1934       begin
1935          --  If statement. Condition is known true in THEN section, known False
1936          --  in any ELSIF or ELSE part, and unknown outside the IF statement.
1937
1938          if Nkind (CV) = N_If_Statement then
1939
1940             --  Before start of IF statement
1941
1942             if Loc < Sloc (CV) then
1943                return;
1944
1945                --  After end of IF statement
1946
1947             elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
1948                return;
1949             end if;
1950
1951             --  At this stage we know that we are within the IF statement, but
1952             --  unfortunately, the tree does not record the SLOC of the ELSE so
1953             --  we cannot use a simple SLOC comparison to distinguish between
1954             --  the then/else statements, so we have to climb the tree.
1955
1956             declare
1957                N : Node_Id;
1958
1959             begin
1960                N := Parent (Var);
1961                while Parent (N) /= CV 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 now we can tell if we are within
1977                --  the THEN statements.
1978
1979                if Is_List_Member (N)
1980                  and then List_Containing (N) = Then_Statements (CV)
1981                then
1982                   Sens := True;
1983
1984                --  If the variable reference does not come from source, we
1985                --  cannot reliably tell whether it appears in the else part.
1986                --  In particular, if it appears in generated code for a node
1987                --  that requires finalization, it may be attached to a list
1988                --  that has not been yet inserted into the code. For now,
1989                --  treat it as unknown.
1990
1991                elsif not Comes_From_Source (N) then
1992                   return;
1993
1994                --  Otherwise we must be in ELSIF or ELSE part
1995
1996                else
1997                   Sens := False;
1998                end if;
1999             end;
2000
2001             --  ELSIF part. Condition is known true within the referenced
2002             --  ELSIF, known False in any subsequent ELSIF or ELSE part, and
2003             --  unknown before the ELSE part or after the IF statement.
2004
2005          elsif Nkind (CV) = N_Elsif_Part then
2006             Stm := Parent (CV);
2007
2008             --  Before start of ELSIF part
2009
2010             if Loc < Sloc (CV) then
2011                return;
2012
2013                --  After end of IF statement
2014
2015             elsif Loc >= Sloc (Stm) +
2016               Text_Ptr (UI_To_Int (End_Span (Stm)))
2017             then
2018                return;
2019             end if;
2020
2021             --  Again we lack the SLOC of the ELSE, so we need to climb the
2022             --  tree to see if we are within the ELSIF part in question.
2023
2024             declare
2025                N : Node_Id;
2026
2027             begin
2028                N := Parent (Var);
2029                while Parent (N) /= Stm loop
2030                   N := Parent (N);
2031
2032                   --  If we fall off the top of the tree, then that's odd, but
2033                   --  perhaps it could occur in some error situation, and the
2034                   --  safest response is simply to assume that the outcome of
2035                   --  the condition is unknown. No point in bombing during an
2036                   --  attempt to optimize things.
2037
2038                   if No (N) then
2039                      return;
2040                   end if;
2041                end loop;
2042
2043                --  Now we have N pointing to a node whose parent is the IF
2044                --  statement in question, so see if is the ELSIF part we want.
2045                --  the THEN statements.
2046
2047                if N = CV then
2048                   Sens := True;
2049
2050                   --  Otherwise we must be in subsequent ELSIF or ELSE part
2051
2052                else
2053                   Sens := False;
2054                end if;
2055             end;
2056
2057          --  Iteration scheme of while loop. The condition is known to be
2058          --  true within the body of the loop.
2059
2060          elsif Nkind (CV) = N_Iteration_Scheme then
2061             declare
2062                Loop_Stmt : constant Node_Id := Parent (CV);
2063
2064             begin
2065                --  Before start of body of loop
2066
2067                if Loc < Sloc (Loop_Stmt) then
2068                   return;
2069
2070                --  After end of LOOP statement
2071
2072                elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
2073                   return;
2074
2075                --  We are within the body of the loop
2076
2077                else
2078                   Sens := True;
2079                end if;
2080             end;
2081
2082          --  All other cases of Current_Value settings
2083
2084          else
2085             return;
2086          end if;
2087
2088          --  If we fall through here, then we have a reportable condition, Sens
2089          --  is True if the condition is true and False if it needs inverting.
2090
2091          Process_Current_Value_Condition (Condition (CV), Sens);
2092       end;
2093    end Get_Current_Value_Condition;
2094
2095    ---------------------------------
2096    -- Has_Controlled_Coextensions --
2097    ---------------------------------
2098
2099    function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
2100       D_Typ : Entity_Id;
2101       Discr : Entity_Id;
2102
2103    begin
2104       --  Only consider record types
2105
2106       if Ekind (Typ) /= E_Record_Type
2107         and then Ekind (Typ) /= E_Record_Subtype
2108       then
2109          return False;
2110       end if;
2111
2112       if Has_Discriminants (Typ) then
2113          Discr := First_Discriminant (Typ);
2114          while Present (Discr) loop
2115             D_Typ := Etype (Discr);
2116
2117             if Ekind (D_Typ) = E_Anonymous_Access_Type
2118               and then
2119                 (Is_Controlled (Directly_Designated_Type (D_Typ))
2120                    or else
2121                  Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
2122             then
2123                return True;
2124             end if;
2125
2126             Next_Discriminant (Discr);
2127          end loop;
2128       end if;
2129
2130       return False;
2131    end Has_Controlled_Coextensions;
2132
2133    --------------------
2134    -- Homonym_Number --
2135    --------------------
2136
2137    function Homonym_Number (Subp : Entity_Id) return Nat is
2138       Count : Nat;
2139       Hom   : Entity_Id;
2140
2141    begin
2142       Count := 1;
2143       Hom := Homonym (Subp);
2144       while Present (Hom) loop
2145          if Scope (Hom) = Scope (Subp) then
2146             Count := Count + 1;
2147          end if;
2148
2149          Hom := Homonym (Hom);
2150       end loop;
2151
2152       return Count;
2153    end Homonym_Number;
2154
2155    ------------------------------
2156    -- In_Unconditional_Context --
2157    ------------------------------
2158
2159    function In_Unconditional_Context (Node : Node_Id) return Boolean is
2160       P : Node_Id;
2161
2162    begin
2163       P := Node;
2164       while Present (P) loop
2165          case Nkind (P) is
2166             when N_Subprogram_Body =>
2167                return True;
2168
2169             when N_If_Statement =>
2170                return False;
2171
2172             when N_Loop_Statement =>
2173                return False;
2174
2175             when N_Case_Statement =>
2176                return False;
2177
2178             when others =>
2179                P := Parent (P);
2180          end case;
2181       end loop;
2182
2183       return False;
2184    end In_Unconditional_Context;
2185
2186    -------------------
2187    -- Insert_Action --
2188    -------------------
2189
2190    procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
2191    begin
2192       if Present (Ins_Action) then
2193          Insert_Actions (Assoc_Node, New_List (Ins_Action));
2194       end if;
2195    end Insert_Action;
2196
2197    --  Version with check(s) suppressed
2198
2199    procedure Insert_Action
2200      (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
2201    is
2202    begin
2203       Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
2204    end Insert_Action;
2205
2206    --------------------
2207    -- Insert_Actions --
2208    --------------------
2209
2210    procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
2211       N : Node_Id;
2212       P : Node_Id;
2213
2214       Wrapped_Node : Node_Id := Empty;
2215
2216    begin
2217       if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
2218          return;
2219       end if;
2220
2221       --  Ignore insert of actions from inside default expression (or other
2222       --  similar "spec expression") in the special spec-expression analyze
2223       --  mode. Any insertions at this point have no relevance, since we are
2224       --  only doing the analyze to freeze the types of any static expressions.
2225       --  See section "Handling of Default Expressions" in the spec of package
2226       --  Sem for further details.
2227
2228       if In_Spec_Expression then
2229          return;
2230       end if;
2231
2232       --  If the action derives from stuff inside a record, then the actions
2233       --  are attached to the current scope, to be inserted and analyzed on
2234       --  exit from the scope. The reason for this is that we may also
2235       --  be generating freeze actions at the same time, and they must
2236       --  eventually be elaborated in the correct order.
2237
2238       if Is_Record_Type (Current_Scope)
2239         and then not Is_Frozen (Current_Scope)
2240       then
2241          if No (Scope_Stack.Table
2242            (Scope_Stack.Last).Pending_Freeze_Actions)
2243          then
2244             Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
2245               Ins_Actions;
2246          else
2247             Append_List
2248               (Ins_Actions,
2249                Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
2250          end if;
2251
2252          return;
2253       end if;
2254
2255       --  We now intend to climb up the tree to find the right point to
2256       --  insert the actions. We start at Assoc_Node, unless this node is
2257       --  a subexpression in which case we start with its parent. We do this
2258       --  for two reasons. First it speeds things up. Second, if Assoc_Node
2259       --  is itself one of the special nodes like N_And_Then, then we assume
2260       --  that an initial request to insert actions for such a node does not
2261       --  expect the actions to get deposited in the node for later handling
2262       --  when the node is expanded, since clearly the node is being dealt
2263       --  with by the caller. Note that in the subexpression case, N is
2264       --  always the child we came from.
2265
2266       --  N_Raise_xxx_Error is an annoying special case, it is a statement
2267       --  if it has type Standard_Void_Type, and a subexpression otherwise.
2268       --  otherwise. Procedure attribute references are also statements.
2269
2270       if Nkind (Assoc_Node) in N_Subexpr
2271         and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
2272                    or else Etype (Assoc_Node) /= Standard_Void_Type)
2273         and then (Nkind (Assoc_Node) /= N_Attribute_Reference
2274                    or else
2275                      not Is_Procedure_Attribute_Name
2276                            (Attribute_Name (Assoc_Node)))
2277       then
2278          P := Assoc_Node;             -- ??? does not agree with above!
2279          N := Parent (Assoc_Node);
2280
2281       --  Non-subexpression case. Note that N is initially Empty in this
2282       --  case (N is only guaranteed Non-Empty in the subexpr case).
2283
2284       else
2285          P := Assoc_Node;
2286          N := Empty;
2287       end if;
2288
2289       --  Capture root of the transient scope
2290
2291       if Scope_Is_Transient then
2292          Wrapped_Node := Node_To_Be_Wrapped;
2293       end if;
2294
2295       loop
2296          pragma Assert (Present (P));
2297
2298          case Nkind (P) is
2299
2300             --  Case of right operand of AND THEN or OR ELSE. Put the actions
2301             --  in the Actions field of the right operand. They will be moved
2302             --  out further when the AND THEN or OR ELSE operator is expanded.
2303             --  Nothing special needs to be done for the left operand since
2304             --  in that case the actions are executed unconditionally.
2305
2306             when N_And_Then | N_Or_Else =>
2307                if N = Right_Opnd (P) then
2308
2309                   --  We are now going to either append the actions to the
2310                   --  actions field of the short-circuit operation. We will
2311                   --  also analyze the actions now.
2312
2313                   --  This analysis is really too early, the proper thing would
2314                   --  be to just park them there now, and only analyze them if
2315                   --  we find we really need them, and to it at the proper
2316                   --  final insertion point. However attempting to this proved
2317                   --  tricky, so for now we just kill current values before and
2318                   --  after the analyze call to make sure we avoid peculiar
2319                   --  optimizations from this out of order insertion.
2320
2321                   Kill_Current_Values;
2322
2323                   if Present (Actions (P)) then
2324                      Insert_List_After_And_Analyze
2325                        (Last (Actions (P)), Ins_Actions);
2326                   else
2327                      Set_Actions (P, Ins_Actions);
2328                      Analyze_List (Actions (P));
2329                   end if;
2330
2331                   Kill_Current_Values;
2332
2333                   return;
2334                end if;
2335
2336             --  Then or Else operand of conditional expression. Add actions to
2337             --  Then_Actions or Else_Actions field as appropriate. The actions
2338             --  will be moved further out when the conditional is expanded.
2339
2340             when N_Conditional_Expression =>
2341                declare
2342                   ThenX : constant Node_Id := Next (First (Expressions (P)));
2343                   ElseX : constant Node_Id := Next (ThenX);
2344
2345                begin
2346                   --  Actions belong to the then expression, temporarily
2347                   --  place them as Then_Actions of the conditional expr.
2348                   --  They will be moved to the proper place later when
2349                   --  the conditional expression is expanded.
2350
2351                   if N = ThenX then
2352                      if Present (Then_Actions (P)) then
2353                         Insert_List_After_And_Analyze
2354                           (Last (Then_Actions (P)), Ins_Actions);
2355                      else
2356                         Set_Then_Actions (P, Ins_Actions);
2357                         Analyze_List (Then_Actions (P));
2358                      end if;
2359
2360                      return;
2361
2362                   --  Actions belong to the else expression, temporarily
2363                   --  place them as Else_Actions of the conditional expr.
2364                   --  They will be moved to the proper place later when
2365                   --  the conditional expression is expanded.
2366
2367                   elsif N = ElseX then
2368                      if Present (Else_Actions (P)) then
2369                         Insert_List_After_And_Analyze
2370                           (Last (Else_Actions (P)), Ins_Actions);
2371                      else
2372                         Set_Else_Actions (P, Ins_Actions);
2373                         Analyze_List (Else_Actions (P));
2374                      end if;
2375
2376                      return;
2377
2378                   --  Actions belong to the condition. In this case they are
2379                   --  unconditionally executed, and so we can continue the
2380                   --  search for the proper insert point.
2381
2382                   else
2383                      null;
2384                   end if;
2385                end;
2386
2387             --  Case of appearing in the condition of a while expression or
2388             --  elsif. We insert the actions into the Condition_Actions field.
2389             --  They will be moved further out when the while loop or elsif
2390             --  is analyzed.
2391
2392             when N_Iteration_Scheme |
2393                  N_Elsif_Part
2394             =>
2395                if N = Condition (P) then
2396                   if Present (Condition_Actions (P)) then
2397                      Insert_List_After_And_Analyze
2398                        (Last (Condition_Actions (P)), Ins_Actions);
2399                   else
2400                      Set_Condition_Actions (P, Ins_Actions);
2401
2402                      --  Set the parent of the insert actions explicitly.
2403                      --  This is not a syntactic field, but we need the
2404                      --  parent field set, in particular so that freeze
2405                      --  can understand that it is dealing with condition
2406                      --  actions, and properly insert the freezing actions.
2407
2408                      Set_Parent (Ins_Actions, P);
2409                      Analyze_List (Condition_Actions (P));
2410                   end if;
2411
2412                   return;
2413                end if;
2414
2415             --  Statements, declarations, pragmas, representation clauses
2416
2417             when
2418                --  Statements
2419
2420                N_Procedure_Call_Statement               |
2421                N_Statement_Other_Than_Procedure_Call    |
2422
2423                --  Pragmas
2424
2425                N_Pragma                                 |
2426
2427                --  Representation_Clause
2428
2429                N_At_Clause                              |
2430                N_Attribute_Definition_Clause            |
2431                N_Enumeration_Representation_Clause      |
2432                N_Record_Representation_Clause           |
2433
2434                --  Declarations
2435
2436                N_Abstract_Subprogram_Declaration        |
2437                N_Entry_Body                             |
2438                N_Exception_Declaration                  |
2439                N_Exception_Renaming_Declaration         |
2440                N_Formal_Abstract_Subprogram_Declaration |
2441                N_Formal_Concrete_Subprogram_Declaration |
2442                N_Formal_Object_Declaration              |
2443                N_Formal_Type_Declaration                |
2444                N_Full_Type_Declaration                  |
2445                N_Function_Instantiation                 |
2446                N_Generic_Function_Renaming_Declaration  |
2447                N_Generic_Package_Declaration            |
2448                N_Generic_Package_Renaming_Declaration   |
2449                N_Generic_Procedure_Renaming_Declaration |
2450                N_Generic_Subprogram_Declaration         |
2451                N_Implicit_Label_Declaration             |
2452                N_Incomplete_Type_Declaration            |
2453                N_Number_Declaration                     |
2454                N_Object_Declaration                     |
2455                N_Object_Renaming_Declaration            |
2456                N_Package_Body                           |
2457                N_Package_Body_Stub                      |
2458                N_Package_Declaration                    |
2459                N_Package_Instantiation                  |
2460                N_Package_Renaming_Declaration           |
2461                N_Private_Extension_Declaration          |
2462                N_Private_Type_Declaration               |
2463                N_Procedure_Instantiation                |
2464                N_Protected_Body                         |
2465                N_Protected_Body_Stub                    |
2466                N_Protected_Type_Declaration             |
2467                N_Single_Task_Declaration                |
2468                N_Subprogram_Body                        |
2469                N_Subprogram_Body_Stub                   |
2470                N_Subprogram_Declaration                 |
2471                N_Subprogram_Renaming_Declaration        |
2472                N_Subtype_Declaration                    |
2473                N_Task_Body                              |
2474                N_Task_Body_Stub                         |
2475                N_Task_Type_Declaration                  |
2476
2477                --  Freeze entity behaves like a declaration or statement
2478
2479                N_Freeze_Entity
2480             =>
2481                --  Do not insert here if the item is not a list member (this
2482                --  happens for example with a triggering statement, and the
2483                --  proper approach is to insert before the entire select).
2484
2485                if not Is_List_Member (P) then
2486                   null;
2487
2488                --  Do not insert if parent of P is an N_Component_Association
2489                --  node (i.e. we are in the context of an N_Aggregate or
2490                --  N_Extension_Aggregate node. In this case we want to insert
2491                --  before the entire aggregate.
2492
2493                elsif Nkind (Parent (P)) = N_Component_Association then
2494                   null;
2495
2496                --  Do not insert if the parent of P is either an N_Variant
2497                --  node or an N_Record_Definition node, meaning in either
2498                --  case that P is a member of a component list, and that
2499                --  therefore the actions should be inserted outside the
2500                --  complete record declaration.
2501
2502                elsif Nkind (Parent (P)) = N_Variant
2503                  or else Nkind (Parent (P)) = N_Record_Definition
2504                then
2505                   null;
2506
2507                --  Do not insert freeze nodes within the loop generated for
2508                --  an aggregate, because they may be elaborated too late for
2509                --  subsequent use in the back end: within a package spec the
2510                --  loop is part of the elaboration procedure and is only
2511                --  elaborated during the second pass.
2512                --  If the loop comes from source, or the entity is local to
2513                --  the loop itself it must remain within.
2514
2515                elsif Nkind (Parent (P)) = N_Loop_Statement
2516                  and then not Comes_From_Source (Parent (P))
2517                  and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
2518                  and then
2519                    Scope (Entity (First (Ins_Actions))) /= Current_Scope
2520                then
2521                   null;
2522
2523                --  Otherwise we can go ahead and do the insertion
2524
2525                elsif P = Wrapped_Node then
2526                   Store_Before_Actions_In_Scope (Ins_Actions);
2527                   return;
2528
2529                else
2530                   Insert_List_Before_And_Analyze (P, Ins_Actions);
2531                   return;
2532                end if;
2533
2534             --  A special case, N_Raise_xxx_Error can act either as a
2535             --  statement or a subexpression. We tell the difference
2536             --  by looking at the Etype. It is set to Standard_Void_Type
2537             --  in the statement case.
2538
2539             when
2540                N_Raise_xxx_Error =>
2541                   if Etype (P) = Standard_Void_Type then
2542                      if  P = Wrapped_Node then
2543                         Store_Before_Actions_In_Scope (Ins_Actions);
2544                      else
2545                         Insert_List_Before_And_Analyze (P, Ins_Actions);
2546                      end if;
2547
2548                      return;
2549
2550                   --  In the subexpression case, keep climbing
2551
2552                   else
2553                      null;
2554                   end if;
2555
2556             --  If a component association appears within a loop created for
2557             --  an array aggregate, attach the actions to the association so
2558             --  they can be subsequently inserted within the loop. For other
2559             --  component associations insert outside of the aggregate. For
2560             --  an association that will generate a loop, its Loop_Actions
2561             --  attribute is already initialized (see exp_aggr.adb).
2562
2563             --  The list of loop_actions can in turn generate additional ones,
2564             --  that are inserted before the associated node. If the associated
2565             --  node is outside the aggregate, the new actions are collected
2566             --  at the end of the loop actions, to respect the order in which
2567             --  they are to be elaborated.
2568
2569             when
2570                N_Component_Association =>
2571                   if Nkind (Parent (P)) = N_Aggregate
2572                     and then Present (Loop_Actions (P))
2573                   then
2574                      if Is_Empty_List (Loop_Actions (P)) then
2575                         Set_Loop_Actions (P, Ins_Actions);
2576                         Analyze_List (Ins_Actions);
2577
2578                      else
2579                         declare
2580                            Decl : Node_Id;
2581
2582                         begin
2583                            --  Check whether these actions were generated
2584                            --  by a declaration that is part of the loop_
2585                            --  actions for the component_association.
2586
2587                            Decl := Assoc_Node;
2588                            while Present (Decl) loop
2589                               exit when Parent (Decl) = P
2590                                 and then Is_List_Member (Decl)
2591                                 and then
2592                                   List_Containing (Decl) = Loop_Actions (P);
2593                               Decl := Parent (Decl);
2594                            end loop;
2595
2596                            if Present (Decl) then
2597                               Insert_List_Before_And_Analyze
2598                                 (Decl, Ins_Actions);
2599                            else
2600                               Insert_List_After_And_Analyze
2601                                 (Last (Loop_Actions (P)), Ins_Actions);
2602                            end if;
2603                         end;
2604                      end if;
2605
2606                      return;
2607
2608                   else
2609                      null;
2610                   end if;
2611
2612             --  Another special case, an attribute denoting a procedure call
2613
2614             when
2615                N_Attribute_Reference =>
2616                   if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
2617                      if P = Wrapped_Node then
2618                         Store_Before_Actions_In_Scope (Ins_Actions);
2619                      else
2620                         Insert_List_Before_And_Analyze (P, Ins_Actions);
2621                      end if;
2622
2623                      return;
2624
2625                   --  In the subexpression case, keep climbing
2626
2627                   else
2628                      null;
2629                   end if;
2630
2631             --  For all other node types, keep climbing tree
2632
2633             when
2634                N_Abortable_Part                         |
2635                N_Accept_Alternative                     |
2636                N_Access_Definition                      |
2637                N_Access_Function_Definition             |
2638                N_Access_Procedure_Definition            |
2639                N_Access_To_Object_Definition            |
2640                N_Aggregate                              |
2641                N_Allocator                              |
2642                N_Case_Statement_Alternative             |
2643                N_Character_Literal                      |
2644                N_Compilation_Unit                       |
2645                N_Compilation_Unit_Aux                   |
2646                N_Component_Clause                       |
2647                N_Component_Declaration                  |
2648                N_Component_Definition                   |
2649                N_Component_List                         |
2650                N_Constrained_Array_Definition           |
2651                N_Decimal_Fixed_Point_Definition         |
2652                N_Defining_Character_Literal             |
2653                N_Defining_Identifier                    |
2654                N_Defining_Operator_Symbol               |
2655                N_Defining_Program_Unit_Name             |
2656                N_Delay_Alternative                      |
2657                N_Delta_Constraint                       |
2658                N_Derived_Type_Definition                |
2659                N_Designator                             |
2660                N_Digits_Constraint                      |
2661                N_Discriminant_Association               |
2662                N_Discriminant_Specification             |
2663                N_Empty                                  |
2664                N_Entry_Body_Formal_Part                 |
2665                N_Entry_Call_Alternative                 |
2666                N_Entry_Declaration                      |
2667                N_Entry_Index_Specification              |
2668                N_Enumeration_Type_Definition            |
2669                N_Error                                  |
2670                N_Exception_Handler                      |
2671                N_Expanded_Name                          |
2672                N_Explicit_Dereference                   |
2673                N_Extension_Aggregate                    |
2674                N_Floating_Point_Definition              |
2675                N_Formal_Decimal_Fixed_Point_Definition  |
2676                N_Formal_Derived_Type_Definition         |
2677                N_Formal_Discrete_Type_Definition        |
2678                N_Formal_Floating_Point_Definition       |
2679                N_Formal_Modular_Type_Definition         |
2680                N_Formal_Ordinary_Fixed_Point_Definition |
2681                N_Formal_Package_Declaration             |
2682                N_Formal_Private_Type_Definition         |
2683                N_Formal_Signed_Integer_Type_Definition  |
2684                N_Function_Call                          |
2685                N_Function_Specification                 |
2686                N_Generic_Association                    |
2687                N_Handled_Sequence_Of_Statements         |
2688                N_Identifier                             |
2689                N_In                                     |
2690                N_Index_Or_Discriminant_Constraint       |
2691                N_Indexed_Component                      |
2692                N_Integer_Literal                        |
2693                N_Itype_Reference                        |
2694                N_Label                                  |
2695                N_Loop_Parameter_Specification           |
2696                N_Mod_Clause                             |
2697                N_Modular_Type_Definition                |
2698                N_Not_In                                 |
2699                N_Null                                   |
2700                N_Op_Abs                                 |
2701                N_Op_Add                                 |
2702                N_Op_And                                 |
2703                N_Op_Concat                              |
2704                N_Op_Divide                              |
2705                N_Op_Eq                                  |
2706                N_Op_Expon                               |
2707                N_Op_Ge                                  |
2708                N_Op_Gt                                  |
2709                N_Op_Le                                  |
2710                N_Op_Lt                                  |
2711                N_Op_Minus                               |
2712                N_Op_Mod                                 |
2713                N_Op_Multiply                            |
2714                N_Op_Ne                                  |
2715                N_Op_Not                                 |
2716                N_Op_Or                                  |
2717                N_Op_Plus                                |
2718                N_Op_Rem                                 |
2719                N_Op_Rotate_Left                         |
2720                N_Op_Rotate_Right                        |
2721                N_Op_Shift_Left                          |
2722                N_Op_Shift_Right                         |
2723                N_Op_Shift_Right_Arithmetic              |
2724                N_Op_Subtract                            |
2725                N_Op_Xor                                 |
2726                N_Operator_Symbol                        |
2727                N_Ordinary_Fixed_Point_Definition        |
2728                N_Others_Choice                          |
2729                N_Package_Specification                  |
2730                N_Parameter_Association                  |
2731                N_Parameter_Specification                |
2732                N_Pop_Constraint_Error_Label             |
2733                N_Pop_Program_Error_Label                |
2734                N_Pop_Storage_Error_Label                |
2735                N_Pragma_Argument_Association            |
2736                N_Procedure_Specification                |
2737                N_Protected_Definition                   |
2738                N_Push_Constraint_Error_Label            |
2739                N_Push_Program_Error_Label               |
2740                N_Push_Storage_Error_Label               |
2741                N_Qualified_Expression                   |
2742                N_Range                                  |
2743                N_Range_Constraint                       |
2744                N_Real_Literal                           |
2745                N_Real_Range_Specification               |
2746                N_Record_Definition                      |
2747                N_Reference                              |
2748                N_Selected_Component                     |
2749                N_Signed_Integer_Type_Definition         |
2750                N_Single_Protected_Declaration           |
2751                N_Slice                                  |
2752                N_String_Literal                         |
2753                N_Subprogram_Info                        |
2754                N_Subtype_Indication                     |
2755                N_Subunit                                |
2756                N_Task_Definition                        |
2757                N_Terminate_Alternative                  |
2758                N_Triggering_Alternative                 |
2759                N_Type_Conversion                        |
2760                N_Unchecked_Expression                   |
2761                N_Unchecked_Type_Conversion              |
2762                N_Unconstrained_Array_Definition         |
2763                N_Unused_At_End                          |
2764                N_Unused_At_Start                        |
2765                N_Use_Package_Clause                     |
2766                N_Use_Type_Clause                        |
2767                N_Variant                                |
2768                N_Variant_Part                           |
2769                N_Validate_Unchecked_Conversion          |
2770                N_With_Clause
2771             =>
2772                null;
2773
2774          end case;
2775
2776          --  Make sure that inserted actions stay in the transient scope
2777
2778          if P = Wrapped_Node then
2779             Store_Before_Actions_In_Scope (Ins_Actions);
2780             return;
2781          end if;
2782
2783          --  If we fall through above tests, keep climbing tree
2784
2785          N := P;
2786
2787          if Nkind (Parent (N)) = N_Subunit then
2788
2789             --  This is the proper body corresponding to a stub. Insertion
2790             --  must be done at the point of the stub, which is in the decla-
2791             --  rative part of the parent unit.
2792
2793             P := Corresponding_Stub (Parent (N));
2794
2795          else
2796             P := Parent (N);
2797          end if;
2798       end loop;
2799    end Insert_Actions;
2800
2801    --  Version with check(s) suppressed
2802
2803    procedure Insert_Actions
2804      (Assoc_Node  : Node_Id;
2805       Ins_Actions : List_Id;
2806       Suppress    : Check_Id)
2807    is
2808    begin
2809       if Suppress = All_Checks then
2810          declare
2811             Svg : constant Suppress_Array := Scope_Suppress;
2812          begin
2813             Scope_Suppress := (others => True);
2814             Insert_Actions (Assoc_Node, Ins_Actions);
2815             Scope_Suppress := Svg;
2816          end;
2817
2818       else
2819          declare
2820             Svg : constant Boolean := Scope_Suppress (Suppress);
2821          begin
2822             Scope_Suppress (Suppress) := True;
2823             Insert_Actions (Assoc_Node, Ins_Actions);
2824             Scope_Suppress (Suppress) := Svg;
2825          end;
2826       end if;
2827    end Insert_Actions;
2828
2829    --------------------------
2830    -- Insert_Actions_After --
2831    --------------------------
2832
2833    procedure Insert_Actions_After
2834      (Assoc_Node  : Node_Id;
2835       Ins_Actions : List_Id)
2836    is
2837    begin
2838       if Scope_Is_Transient
2839         and then Assoc_Node = Node_To_Be_Wrapped
2840       then
2841          Store_After_Actions_In_Scope (Ins_Actions);
2842       else
2843          Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
2844       end if;
2845    end Insert_Actions_After;
2846
2847    ---------------------------------
2848    -- Insert_Library_Level_Action --
2849    ---------------------------------
2850
2851    procedure Insert_Library_Level_Action (N : Node_Id) is
2852       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2853
2854    begin
2855       Push_Scope (Cunit_Entity (Main_Unit));
2856       --  ??? should this be Current_Sem_Unit instead of Main_Unit?
2857
2858       if No (Actions (Aux)) then
2859          Set_Actions (Aux, New_List (N));
2860       else
2861          Append (N, Actions (Aux));
2862       end if;
2863
2864       Analyze (N);
2865       Pop_Scope;
2866    end Insert_Library_Level_Action;
2867
2868    ----------------------------------
2869    -- Insert_Library_Level_Actions --
2870    ----------------------------------
2871
2872    procedure Insert_Library_Level_Actions (L : List_Id) is
2873       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2874
2875    begin
2876       if Is_Non_Empty_List (L) then
2877          Push_Scope (Cunit_Entity (Main_Unit));
2878          --  ??? should this be Current_Sem_Unit instead of Main_Unit?
2879
2880          if No (Actions (Aux)) then
2881             Set_Actions (Aux, L);
2882             Analyze_List (L);
2883          else
2884             Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2885          end if;
2886
2887          Pop_Scope;
2888       end if;
2889    end Insert_Library_Level_Actions;
2890
2891    ----------------------
2892    -- Inside_Init_Proc --
2893    ----------------------
2894
2895    function Inside_Init_Proc return Boolean is
2896       S : Entity_Id;
2897
2898    begin
2899       S := Current_Scope;
2900       while Present (S)
2901         and then S /= Standard_Standard
2902       loop
2903          if Is_Init_Proc (S) then
2904             return True;
2905          else
2906             S := Scope (S);
2907          end if;
2908       end loop;
2909
2910       return False;
2911    end Inside_Init_Proc;
2912
2913    ----------------------------
2914    -- Is_All_Null_Statements --
2915    ----------------------------
2916
2917    function Is_All_Null_Statements (L : List_Id) return Boolean is
2918       Stm : Node_Id;
2919
2920    begin
2921       Stm := First (L);
2922       while Present (Stm) loop
2923          if Nkind (Stm) /= N_Null_Statement then
2924             return False;
2925          end if;
2926
2927          Next (Stm);
2928       end loop;
2929
2930       return True;
2931    end Is_All_Null_Statements;
2932
2933    ----------------------------------
2934    -- Is_Library_Level_Tagged_Type --
2935    ----------------------------------
2936
2937    function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
2938    begin
2939       return Is_Tagged_Type (Typ)
2940         and then Is_Library_Level_Entity (Typ);
2941    end Is_Library_Level_Tagged_Type;
2942
2943    ----------------------------------
2944    -- Is_Possibly_Unaligned_Object --
2945    ----------------------------------
2946
2947    function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
2948       T  : constant Entity_Id := Etype (N);
2949
2950    begin
2951       --  If renamed object, apply test to underlying object
2952
2953       if Is_Entity_Name (N)
2954         and then Is_Object (Entity (N))
2955         and then Present (Renamed_Object (Entity (N)))
2956       then
2957          return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
2958       end if;
2959
2960       --  Tagged and controlled types and aliased types are always aligned,
2961       --  as are concurrent types.
2962
2963       if Is_Aliased (T)
2964         or else Has_Controlled_Component (T)
2965         or else Is_Concurrent_Type (T)
2966         or else Is_Tagged_Type (T)
2967         or else Is_Controlled (T)
2968       then
2969          return False;
2970       end if;
2971
2972       --  If this is an element of a packed array, may be unaligned
2973
2974       if Is_Ref_To_Bit_Packed_Array (N) then
2975          return True;
2976       end if;
2977
2978       --  Case of component reference
2979
2980       if Nkind (N) = N_Selected_Component then
2981          declare
2982             P : constant Node_Id   := Prefix (N);
2983             C : constant Entity_Id := Entity (Selector_Name (N));
2984             M : Nat;
2985             S : Nat;
2986
2987          begin
2988             --  If component reference is for an array with non-static bounds,
2989             --  then it is always aligned: we can only process unaligned
2990             --  arrays with static bounds (more accurately bounds known at
2991             --  compile time).
2992
2993             if Is_Array_Type (T)
2994               and then not Compile_Time_Known_Bounds (T)
2995             then
2996                return False;
2997             end if;
2998
2999             --  If component is aliased, it is definitely properly aligned
3000
3001             if Is_Aliased (C) then
3002                return False;
3003             end if;
3004
3005             --  If component is for a type implemented as a scalar, and the
3006             --  record is packed, and the component is other than the first
3007             --  component of the record, then the component may be unaligned.
3008
3009             if Is_Packed (Etype (P))
3010               and then Represented_As_Scalar (Etype (C))
3011               and then First_Entity (Scope (C)) /= C
3012             then
3013                return True;
3014             end if;
3015
3016             --  Compute maximum possible alignment for T
3017
3018             --  If alignment is known, then that settles things
3019
3020             if Known_Alignment (T) then
3021                M := UI_To_Int (Alignment (T));
3022
3023             --  If alignment is not known, tentatively set max alignment
3024
3025             else
3026                M := Ttypes.Maximum_Alignment;
3027
3028                --  We can reduce this if the Esize is known since the default
3029                --  alignment will never be more than the smallest power of 2
3030                --  that does not exceed this Esize value.
3031
3032                if Known_Esize (T) then
3033                   S := UI_To_Int (Esize (T));
3034
3035                   while (M / 2) >= S loop
3036                      M := M / 2;
3037                   end loop;
3038                end if;
3039             end if;
3040
3041             --  If the component reference is for a record that has a specified
3042             --  alignment, and we either know it is too small, or cannot tell,
3043             --  then the component may be unaligned
3044
3045             if Known_Alignment (Etype (P))
3046               and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
3047               and then M > Alignment (Etype (P))
3048             then
3049                return True;
3050             end if;
3051
3052             --  Case of component clause present which may specify an
3053             --  unaligned position.
3054
3055             if Present (Component_Clause (C)) then
3056
3057                --  Otherwise we can do a test to make sure that the actual
3058                --  start position in the record, and the length, are both
3059                --  consistent with the required alignment. If not, we know
3060                --  that we are unaligned.
3061
3062                declare
3063                   Align_In_Bits : constant Nat := M * System_Storage_Unit;
3064                begin
3065                   if Component_Bit_Offset (C) mod Align_In_Bits /= 0
3066                     or else Esize (C) mod Align_In_Bits /= 0
3067                   then
3068                      return True;
3069                   end if;
3070                end;
3071             end if;
3072
3073             --  Otherwise, for a component reference, test prefix
3074
3075             return Is_Possibly_Unaligned_Object (P);
3076          end;
3077
3078       --  If not a component reference, must be aligned
3079
3080       else
3081          return False;
3082       end if;
3083    end Is_Possibly_Unaligned_Object;
3084
3085    ---------------------------------
3086    -- Is_Possibly_Unaligned_Slice --
3087    ---------------------------------
3088
3089    function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
3090    begin
3091       --  Go to renamed object
3092
3093       if Is_Entity_Name (N)
3094         and then Is_Object (Entity (N))
3095         and then Present (Renamed_Object (Entity (N)))
3096       then
3097          return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
3098       end if;
3099
3100       --  The reference must be a slice
3101
3102       if Nkind (N) /= N_Slice then
3103          return False;
3104       end if;
3105
3106       --  Always assume the worst for a nested record component with a
3107       --  component clause, which gigi/gcc does not appear to handle well.
3108       --  It is not clear why this special test is needed at all ???
3109
3110       if Nkind (Prefix (N)) = N_Selected_Component
3111         and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
3112         and then
3113           Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
3114       then
3115          return True;
3116       end if;
3117
3118       --  We only need to worry if the target has strict alignment
3119
3120       if not Target_Strict_Alignment then
3121          return False;
3122       end if;
3123
3124       --  If it is a slice, then look at the array type being sliced
3125
3126       declare
3127          Sarr : constant Node_Id := Prefix (N);
3128          --  Prefix of the slice, i.e. the array being sliced
3129
3130          Styp : constant Entity_Id := Etype (Prefix (N));
3131          --  Type of the array being sliced
3132
3133          Pref : Node_Id;
3134          Ptyp : Entity_Id;
3135
3136       begin
3137          --  The problems arise if the array object that is being sliced
3138          --  is a component of a record or array, and we cannot guarantee
3139          --  the alignment of the array within its containing object.
3140
3141          --  To investigate this, we look at successive prefixes to see
3142          --  if we have a worrisome indexed or selected component.
3143
3144          Pref := Sarr;
3145          loop
3146             --  Case of array is part of an indexed component reference
3147
3148             if Nkind (Pref) = N_Indexed_Component then
3149                Ptyp := Etype (Prefix (Pref));
3150
3151                --  The only problematic case is when the array is packed,
3152                --  in which case we really know nothing about the alignment
3153                --  of individual components.
3154
3155                if Is_Bit_Packed_Array (Ptyp) then
3156                   return True;
3157                end if;
3158
3159             --  Case of array is part of a selected component reference
3160
3161             elsif Nkind (Pref) = N_Selected_Component then
3162                Ptyp := Etype (Prefix (Pref));
3163
3164                --  We are definitely in trouble if the record in question
3165                --  has an alignment, and either we know this alignment is
3166                --  inconsistent with the alignment of the slice, or we
3167                --  don't know what the alignment of the slice should be.
3168
3169                if Known_Alignment (Ptyp)
3170                  and then (Unknown_Alignment (Styp)
3171                              or else Alignment (Styp) > Alignment (Ptyp))
3172                then
3173                   return True;
3174                end if;
3175
3176                --  We are in potential trouble if the record type is packed.
3177                --  We could special case when we know that the array is the
3178                --  first component, but that's not such a simple case ???
3179
3180                if Is_Packed (Ptyp) then
3181                   return True;
3182                end if;
3183
3184                --  We are in trouble if there is a component clause, and
3185                --  either we do not know the alignment of the slice, or
3186                --  the alignment of the slice is inconsistent with the
3187                --  bit position specified by the component clause.
3188
3189                declare
3190                   Field : constant Entity_Id := Entity (Selector_Name (Pref));
3191                begin
3192                   if Present (Component_Clause (Field))
3193                     and then
3194                       (Unknown_Alignment (Styp)
3195                         or else
3196                          (Component_Bit_Offset (Field) mod
3197                            (System_Storage_Unit * Alignment (Styp))) /= 0)
3198                   then
3199                      return True;
3200                   end if;
3201                end;
3202
3203             --  For cases other than selected or indexed components we
3204             --  know we are OK, since no issues arise over alignment.
3205
3206             else
3207                return False;
3208             end if;
3209
3210             --  We processed an indexed component or selected component
3211             --  reference that looked safe, so keep checking prefixes.
3212
3213             Pref := Prefix (Pref);
3214          end loop;
3215       end;
3216    end Is_Possibly_Unaligned_Slice;
3217
3218    --------------------------------
3219    -- Is_Ref_To_Bit_Packed_Array --
3220    --------------------------------
3221
3222    function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
3223       Result : Boolean;
3224       Expr   : Node_Id;
3225
3226    begin
3227       if Is_Entity_Name (N)
3228         and then Is_Object (Entity (N))
3229         and then Present (Renamed_Object (Entity (N)))
3230       then
3231          return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
3232       end if;
3233
3234       if Nkind (N) = N_Indexed_Component
3235            or else
3236          Nkind (N) = N_Selected_Component
3237       then
3238          if Is_Bit_Packed_Array (Etype (Prefix (N))) then
3239             Result := True;
3240          else
3241             Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
3242          end if;
3243
3244          if Result and then Nkind (N) = N_Indexed_Component then
3245             Expr := First (Expressions (N));
3246             while Present (Expr) loop
3247                Force_Evaluation (Expr);
3248                Next (Expr);
3249             end loop;
3250          end if;
3251
3252          return Result;
3253
3254       else
3255          return False;
3256       end if;
3257    end Is_Ref_To_Bit_Packed_Array;
3258
3259    --------------------------------
3260    -- Is_Ref_To_Bit_Packed_Slice --
3261    --------------------------------
3262
3263    function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
3264    begin
3265       if Nkind (N) = N_Type_Conversion then
3266          return Is_Ref_To_Bit_Packed_Slice (Expression (N));
3267
3268       elsif Is_Entity_Name (N)
3269         and then Is_Object (Entity (N))
3270         and then Present (Renamed_Object (Entity (N)))
3271       then
3272          return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
3273
3274       elsif Nkind (N) = N_Slice
3275         and then Is_Bit_Packed_Array (Etype (Prefix (N)))
3276       then
3277          return True;
3278
3279       elsif Nkind (N) = N_Indexed_Component
3280            or else
3281          Nkind (N) = N_Selected_Component
3282       then
3283          return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
3284
3285       else
3286          return False;
3287       end if;
3288    end Is_Ref_To_Bit_Packed_Slice;
3289
3290    -----------------------
3291    -- Is_Renamed_Object --
3292    -----------------------
3293
3294    function Is_Renamed_Object (N : Node_Id) return Boolean is
3295       Pnod : constant Node_Id   := Parent (N);
3296       Kind : constant Node_Kind := Nkind (Pnod);
3297
3298    begin
3299       if Kind = N_Object_Renaming_Declaration then
3300          return True;
3301
3302       elsif Kind = N_Indexed_Component
3303         or else Kind = N_Selected_Component
3304       then
3305          return Is_Renamed_Object (Pnod);
3306
3307       else
3308          return False;
3309       end if;
3310    end Is_Renamed_Object;
3311
3312    ----------------------------
3313    -- Is_Untagged_Derivation --
3314    ----------------------------
3315
3316    function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
3317    begin
3318       return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
3319                or else
3320              (Is_Private_Type (T) and then Present (Full_View (T))
3321                and then not Is_Tagged_Type (Full_View (T))
3322                and then Is_Derived_Type (Full_View (T))
3323                and then Etype (Full_View (T)) /= T);
3324    end Is_Untagged_Derivation;
3325
3326    ---------------------------
3327    -- Is_Volatile_Reference --
3328    ---------------------------
3329
3330    function Is_Volatile_Reference (N : Node_Id) return Boolean is
3331    begin
3332       if Nkind (N) in N_Has_Etype
3333         and then Present (Etype (N))
3334         and then Treat_As_Volatile (Etype (N))
3335       then
3336          return True;
3337
3338       elsif Is_Entity_Name (N) then
3339          return Treat_As_Volatile (Entity (N));
3340
3341       elsif Nkind (N) = N_Slice then
3342          return Is_Volatile_Reference (Prefix (N));
3343
3344       elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
3345          if (Is_Entity_Name (Prefix (N))
3346                and then Has_Volatile_Components (Entity (Prefix (N))))
3347            or else (Present (Etype (Prefix (N)))
3348                       and then Has_Volatile_Components (Etype (Prefix (N))))
3349          then
3350             return True;
3351          else
3352             return Is_Volatile_Reference (Prefix (N));
3353          end if;
3354
3355       else
3356          return False;
3357       end if;
3358    end Is_Volatile_Reference;
3359
3360    --------------------
3361    -- Kill_Dead_Code --
3362    --------------------
3363
3364    procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
3365    begin
3366       if Present (N) then
3367          Remove_Warning_Messages (N);
3368
3369          if Warn then
3370             Error_Msg_F
3371               ("?this code can never be executed and has been deleted!", N);
3372          end if;
3373
3374          --  Recurse into block statements and bodies to process declarations
3375          --  and statements
3376
3377          if Nkind (N) = N_Block_Statement
3378            or else Nkind (N) = N_Subprogram_Body
3379            or else Nkind (N) = N_Package_Body
3380          then
3381             Kill_Dead_Code (Declarations (N), False);
3382             Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
3383
3384             if Nkind (N) = N_Subprogram_Body then
3385                Set_Is_Eliminated (Defining_Entity (N));
3386             end if;
3387
3388          elsif Nkind (N) = N_Package_Declaration then
3389             Kill_Dead_Code (Visible_Declarations (Specification (N)));
3390             Kill_Dead_Code (Private_Declarations (Specification (N)));
3391
3392             --  ??? After this point, Delete_Tree has been called on all
3393             --  declarations in Specification (N), so references to
3394             --  entities therein look suspicious.
3395
3396             declare
3397                E : Entity_Id := First_Entity (Defining_Entity (N));
3398             begin
3399                while Present (E) loop
3400                   if Ekind (E) = E_Operator then
3401                      Set_Is_Eliminated (E);
3402                   end if;
3403
3404                   Next_Entity (E);
3405                end loop;
3406             end;
3407
3408          --  Recurse into composite statement to kill individual statements,
3409          --  in particular instantiations.
3410
3411          elsif Nkind (N) = N_If_Statement then
3412             Kill_Dead_Code (Then_Statements (N));
3413             Kill_Dead_Code (Elsif_Parts (N));
3414             Kill_Dead_Code (Else_Statements (N));
3415
3416          elsif Nkind (N) = N_Loop_Statement then
3417             Kill_Dead_Code (Statements (N));
3418
3419          elsif Nkind (N) = N_Case_Statement then
3420             declare
3421                Alt : Node_Id;
3422             begin
3423                Alt := First (Alternatives (N));
3424                while Present (Alt) loop
3425                   Kill_Dead_Code (Statements (Alt));
3426                   Next (Alt);
3427                end loop;
3428             end;
3429
3430          elsif Nkind (N) = N_Case_Statement_Alternative then
3431             Kill_Dead_Code (Statements (N));
3432
3433          --  Deal with dead instances caused by deleting instantiations
3434
3435          elsif Nkind (N) in N_Generic_Instantiation then
3436             Remove_Dead_Instance (N);
3437          end if;
3438       end if;
3439    end Kill_Dead_Code;
3440
3441    --  Case where argument is a list of nodes to be killed
3442
3443    procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
3444       N : Node_Id;
3445       W : Boolean;
3446    begin
3447       W := Warn;
3448       if Is_Non_Empty_List (L) then
3449          N := First (L);
3450          while Present (N) loop
3451             Kill_Dead_Code (N, W);
3452             W := False;
3453             Next (N);
3454          end loop;
3455       end if;
3456    end Kill_Dead_Code;
3457
3458    ------------------------
3459    -- Known_Non_Negative --
3460    ------------------------
3461
3462    function Known_Non_Negative (Opnd : Node_Id) return Boolean is
3463    begin
3464       if Is_OK_Static_Expression (Opnd)
3465         and then Expr_Value (Opnd) >= 0
3466       then
3467          return True;
3468
3469       else
3470          declare
3471             Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
3472
3473          begin
3474             return
3475               Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
3476          end;
3477       end if;
3478    end Known_Non_Negative;
3479
3480    --------------------
3481    -- Known_Non_Null --
3482    --------------------
3483
3484    function Known_Non_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             --  First check if we are in decisive conditional
3496
3497             Get_Current_Value_Condition (N, Op, Val);
3498
3499             if Known_Null (Val) then
3500                if Op = N_Op_Eq then
3501                   return False;
3502                elsif Op = N_Op_Ne then
3503                   return True;
3504                end if;
3505             end if;
3506
3507             --  If OK to do replacement, test Is_Known_Non_Null flag
3508
3509             if OK_To_Do_Constant_Replacement (E) then
3510                return Is_Known_Non_Null (E);
3511
3512             --  Otherwise if not safe to do replacement, then say so
3513
3514             else
3515                return False;
3516             end if;
3517          end;
3518
3519       --  True if access attribute
3520
3521       elsif Nkind (N) = N_Attribute_Reference
3522         and then (Attribute_Name (N) = Name_Access
3523                     or else
3524                   Attribute_Name (N) = Name_Unchecked_Access
3525                     or else
3526                   Attribute_Name (N) = Name_Unrestricted_Access)
3527       then
3528          return True;
3529
3530       --  True if allocator
3531
3532       elsif Nkind (N) = N_Allocator then
3533          return True;
3534
3535       --  For a conversion, true if expression is known non-null
3536
3537       elsif Nkind (N) = N_Type_Conversion then
3538          return Known_Non_Null (Expression (N));
3539
3540       --  Above are all cases where the value could be determined to be
3541       --  non-null. In all other cases, we don't know, so return False.
3542
3543       else
3544          return False;
3545       end if;
3546    end Known_Non_Null;
3547
3548    ----------------
3549    -- Known_Null --
3550    ----------------
3551
3552    function Known_Null (N : Node_Id) return Boolean is
3553    begin
3554       --  Checks for case where N is an entity reference
3555
3556       if Is_Entity_Name (N) and then Present (Entity (N)) then
3557          declare
3558             E   : constant Entity_Id := Entity (N);
3559             Op  : Node_Kind;
3560             Val : Node_Id;
3561
3562          begin
3563             --  Constant null value is for sure null
3564
3565             if Ekind (E) = E_Constant
3566               and then Known_Null (Constant_Value (E))
3567             then
3568                return True;
3569             end if;
3570
3571             --  First check if we are in decisive conditional
3572
3573             Get_Current_Value_Condition (N, Op, Val);
3574
3575             if Known_Null (Val) then
3576                if Op = N_Op_Eq then
3577                   return True;
3578                elsif Op = N_Op_Ne then
3579                   return False;
3580                end if;
3581             end if;
3582
3583             --  If OK to do replacement, test Is_Known_Null flag
3584
3585             if OK_To_Do_Constant_Replacement (E) then
3586                return Is_Known_Null (E);
3587
3588             --  Otherwise if not safe to do replacement, then say so
3589
3590             else
3591                return False;
3592             end if;
3593          end;
3594
3595       --  True if explicit reference to null
3596
3597       elsif Nkind (N) = N_Null then
3598          return True;
3599
3600       --  For a conversion, true if expression is known null
3601
3602       elsif Nkind (N) = N_Type_Conversion then
3603          return Known_Null (Expression (N));
3604
3605       --  Above are all cases where the value could be determined to be null.
3606       --  In all other cases, we don't know, so return False.
3607
3608       else
3609          return False;
3610       end if;
3611    end Known_Null;
3612
3613    -----------------------------
3614    -- Make_CW_Equivalent_Type --
3615    -----------------------------
3616
3617    --  Create a record type used as an equivalent of any member
3618    --  of the class which takes its size from exp.
3619
3620    --  Generate the following code:
3621
3622    --   type Equiv_T is record
3623    --     _parent :  T (List of discriminant constraints taken from Exp);
3624    --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3625    --   end Equiv_T;
3626    --
3627    --   ??? Note that this type does not guarantee same alignment as all
3628    --   derived types
3629
3630    function Make_CW_Equivalent_Type
3631      (T : Entity_Id;
3632       E : Node_Id) return Entity_Id
3633    is
3634       Loc         : constant Source_Ptr := Sloc (E);
3635       Root_Typ    : constant Entity_Id  := Root_Type (T);
3636       List_Def    : constant List_Id    := Empty_List;
3637       Comp_List   : constant List_Id    := New_List;
3638       Equiv_Type  : Entity_Id;
3639       Range_Type  : Entity_Id;
3640       Str_Type    : Entity_Id;
3641       Constr_Root : Entity_Id;
3642       Sizexpr     : Node_Id;
3643
3644    begin
3645       if not Has_Discriminants (Root_Typ) then
3646          Constr_Root := Root_Typ;
3647       else
3648          Constr_Root :=
3649            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3650
3651          --  subtype cstr__n is T (List of discr constraints taken from Exp)
3652
3653          Append_To (List_Def,
3654            Make_Subtype_Declaration (Loc,
3655              Defining_Identifier => Constr_Root,
3656                Subtype_Indication =>
3657                  Make_Subtype_From_Expr (E, Root_Typ)));
3658       end if;
3659
3660       --  Generate the range subtype declaration
3661
3662       Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
3663
3664       if not Is_Interface (Root_Typ) then
3665          --  subtype rg__xx is
3666          --    Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
3667
3668          Sizexpr :=
3669            Make_Op_Subtract (Loc,
3670              Left_Opnd =>
3671                Make_Attribute_Reference (Loc,
3672                  Prefix =>
3673                    OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3674                  Attribute_Name => Name_Size),
3675              Right_Opnd =>
3676                Make_Attribute_Reference (Loc,
3677                  Prefix => New_Reference_To (Constr_Root, Loc),
3678                  Attribute_Name => Name_Object_Size));
3679       else
3680          --  subtype rg__xx is
3681          --    Storage_Offset range 1 .. Expr'size / Storage_Unit
3682
3683          Sizexpr :=
3684            Make_Attribute_Reference (Loc,
3685              Prefix =>
3686                OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3687              Attribute_Name => Name_Size);
3688       end if;
3689
3690       Set_Paren_Count (Sizexpr, 1);
3691
3692       Append_To (List_Def,
3693         Make_Subtype_Declaration (Loc,
3694           Defining_Identifier => Range_Type,
3695           Subtype_Indication =>
3696             Make_Subtype_Indication (Loc,
3697               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
3698               Constraint => Make_Range_Constraint (Loc,
3699                 Range_Expression =>
3700                   Make_Range (Loc,
3701                     Low_Bound => Make_Integer_Literal (Loc, 1),
3702                     High_Bound =>
3703                       Make_Op_Divide (Loc,
3704                         Left_Opnd => Sizexpr,
3705                         Right_Opnd => Make_Integer_Literal (Loc,
3706                             Intval => System_Storage_Unit)))))));
3707
3708       --  subtype str__nn is Storage_Array (rg__x);
3709
3710       Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3711       Append_To (List_Def,
3712         Make_Subtype_Declaration (Loc,
3713           Defining_Identifier => Str_Type,
3714           Subtype_Indication =>
3715             Make_Subtype_Indication (Loc,
3716               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
3717               Constraint =>
3718                 Make_Index_Or_Discriminant_Constraint (Loc,
3719                   Constraints =>
3720                     New_List (New_Reference_To (Range_Type, Loc))))));
3721
3722       --  type Equiv_T is record
3723       --    [ _parent : Tnn; ]
3724       --    E : Str_Type;
3725       --  end Equiv_T;
3726
3727       Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3728
3729       --  When the target requires front-end layout, it's necessary to allow
3730       --  the equivalent type to be frozen so that layout can occur (when the
3731       --  associated class-wide subtype is frozen, the equivalent type will
3732       --  be frozen, see freeze.adb). For other targets, Gigi wants to have
3733       --  the equivalent type marked as frozen and deals with this type itself.
3734       --  In the Gigi case this will also avoid the generation of an init
3735       --  procedure for the type.
3736
3737       if not Frontend_Layout_On_Target then
3738          Set_Is_Frozen (Equiv_Type);
3739       end if;
3740
3741       Set_Ekind (Equiv_Type, E_Record_Type);
3742       Set_Parent_Subtype (Equiv_Type, Constr_Root);
3743
3744       if not Is_Interface (Root_Typ) then
3745          Append_To (Comp_List,
3746            Make_Component_Declaration (Loc,
3747              Defining_Identifier =>
3748                Make_Defining_Identifier (Loc, Name_uParent),
3749              Component_Definition =>
3750                Make_Component_Definition (Loc,
3751                  Aliased_Present    => False,
3752                  Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
3753       end if;
3754
3755       Append_To (Comp_List,
3756         Make_Component_Declaration (Loc,
3757           Defining_Identifier =>
3758             Make_Defining_Identifier (Loc,
3759               Chars => New_Internal_Name ('C')),
3760           Component_Definition =>
3761             Make_Component_Definition (Loc,
3762               Aliased_Present    => False,
3763               Subtype_Indication => New_Reference_To (Str_Type, Loc))));
3764
3765       Append_To (List_Def,
3766         Make_Full_Type_Declaration (Loc,
3767           Defining_Identifier => Equiv_Type,
3768           Type_Definition =>
3769             Make_Record_Definition (Loc,
3770               Component_List =>
3771                 Make_Component_List (Loc,
3772                   Component_Items => Comp_List,
3773                   Variant_Part    => Empty))));
3774
3775       --  Suppress all checks during the analysis of the expanded code
3776       --  to avoid the generation of spurious warnings under ZFP run-time.
3777
3778       Insert_Actions (E, List_Def, Suppress => All_Checks);
3779       return Equiv_Type;
3780    end Make_CW_Equivalent_Type;
3781
3782    ------------------------
3783    -- Make_Literal_Range --
3784    ------------------------
3785
3786    function Make_Literal_Range
3787      (Loc         : Source_Ptr;
3788       Literal_Typ : Entity_Id) return Node_Id
3789    is
3790       Lo          : constant Node_Id :=
3791                       New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
3792       Index       : constant Entity_Id := Etype (Lo);
3793
3794       Hi          : Node_Id;
3795       Length_Expr : constant Node_Id :=
3796                       Make_Op_Subtract (Loc,
3797                         Left_Opnd =>
3798                           Make_Integer_Literal (Loc,
3799                             Intval => String_Literal_Length (Literal_Typ)),
3800                         Right_Opnd =>
3801                           Make_Integer_Literal (Loc, 1));
3802
3803    begin
3804       Set_Analyzed (Lo, False);
3805
3806          if Is_Integer_Type (Index) then
3807             Hi :=
3808               Make_Op_Add (Loc,
3809                 Left_Opnd  => New_Copy_Tree (Lo),
3810                 Right_Opnd => Length_Expr);
3811          else
3812             Hi :=
3813               Make_Attribute_Reference (Loc,
3814                 Attribute_Name => Name_Val,
3815                 Prefix => New_Occurrence_Of (Index, Loc),
3816                 Expressions => New_List (
3817                  Make_Op_Add (Loc,
3818                    Left_Opnd =>
3819                      Make_Attribute_Reference (Loc,
3820                        Attribute_Name => Name_Pos,
3821                        Prefix => New_Occurrence_Of (Index, Loc),
3822                        Expressions => New_List (New_Copy_Tree (Lo))),
3823                   Right_Opnd => Length_Expr)));
3824          end if;
3825
3826          return
3827            Make_Range (Loc,
3828              Low_Bound  => Lo,
3829              High_Bound => Hi);
3830    end Make_Literal_Range;
3831
3832    --------------------------
3833    -- Make_Non_Empty_Check --
3834    --------------------------
3835
3836    function Make_Non_Empty_Check
3837      (Loc : Source_Ptr;
3838       N   : Node_Id) return Node_Id
3839    is
3840    begin
3841       return
3842         Make_Op_Ne (Loc,
3843           Left_Opnd =>
3844             Make_Attribute_Reference (Loc,
3845               Attribute_Name => Name_Length,
3846               Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
3847           Right_Opnd =>
3848             Make_Integer_Literal (Loc, 0));
3849    end Make_Non_Empty_Check;
3850
3851    ----------------------------
3852    -- Make_Subtype_From_Expr --
3853    ----------------------------
3854
3855    --  1. If Expr is an unconstrained array expression, creates
3856    --    Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
3857
3858    --  2. If Expr is a unconstrained discriminated type expression, creates
3859    --    Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3860
3861    --  3. If Expr is class-wide, creates an implicit class wide subtype
3862
3863    function Make_Subtype_From_Expr
3864      (E       : Node_Id;
3865       Unc_Typ : Entity_Id) return Node_Id
3866    is
3867       Loc         : constant Source_Ptr := Sloc (E);
3868       List_Constr : constant List_Id    := New_List;
3869       D           : Entity_Id;
3870
3871       Full_Subtyp  : Entity_Id;
3872       Priv_Subtyp  : Entity_Id;
3873       Utyp         : Entity_Id;
3874       Full_Exp     : Node_Id;
3875
3876    begin
3877       if Is_Private_Type (Unc_Typ)
3878         and then Has_Unknown_Discriminants (Unc_Typ)
3879       then
3880          --  Prepare the subtype completion, Go to base type to
3881          --  find underlying type, because the type may be a generic
3882          --  actual or an explicit subtype.
3883
3884          Utyp        := Underlying_Type (Base_Type (Unc_Typ));
3885          Full_Subtyp := Make_Defining_Identifier (Loc,
3886                           New_Internal_Name ('C'));
3887          Full_Exp    :=
3888            Unchecked_Convert_To
3889              (Utyp, Duplicate_Subexpr_No_Checks (E));
3890          Set_Parent (Full_Exp, Parent (E));
3891
3892          Priv_Subtyp :=
3893            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3894
3895          Insert_Action (E,
3896            Make_Subtype_Declaration (Loc,
3897              Defining_Identifier => Full_Subtyp,
3898              Subtype_Indication  => Make_Subtype_From_Expr (Full_Exp, Utyp)));
3899
3900          --  Define the dummy private subtype
3901
3902          Set_Ekind          (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
3903          Set_Etype          (Priv_Subtyp, Base_Type (Unc_Typ));
3904          Set_Scope          (Priv_Subtyp, Full_Subtyp);
3905          Set_Is_Constrained (Priv_Subtyp);
3906          Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
3907          Set_Is_Itype       (Priv_Subtyp);
3908          Set_Associated_Node_For_Itype (Priv_Subtyp, E);
3909
3910          if Is_Tagged_Type  (Priv_Subtyp) then
3911             Set_Class_Wide_Type
3912               (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
3913             Set_Primitive_Operations (Priv_Subtyp,
3914               Primitive_Operations (Unc_Typ));
3915          end if;
3916
3917          Set_Full_View (Priv_Subtyp, Full_Subtyp);
3918
3919          return New_Reference_To (Priv_Subtyp, Loc);
3920
3921       elsif Is_Array_Type (Unc_Typ) then
3922          for J in 1 .. Number_Dimensions (Unc_Typ) loop
3923             Append_To (List_Constr,
3924               Make_Range (Loc,
3925                 Low_Bound =>
3926                   Make_Attribute_Reference (Loc,
3927                     Prefix => Duplicate_Subexpr_No_Checks (E),
3928                     Attribute_Name => Name_First,
3929                     Expressions => New_List (
3930                       Make_Integer_Literal (Loc, J))),
3931
3932                 High_Bound =>
3933                   Make_Attribute_Reference (Loc,
3934                     Prefix         => Duplicate_Subexpr_No_Checks (E),
3935                     Attribute_Name => Name_Last,
3936                     Expressions    => New_List (
3937                       Make_Integer_Literal (Loc, J)))));
3938          end loop;
3939
3940       elsif Is_Class_Wide_Type (Unc_Typ) then
3941          declare
3942             CW_Subtype : Entity_Id;
3943             EQ_Typ     : Entity_Id := Empty;
3944
3945          begin
3946             --  A class-wide equivalent type is not needed when VM_Target
3947             --  because the VM back-ends handle the class-wide object
3948             --  initialization itself (and doesn't need or want the
3949             --  additional intermediate type to handle the assignment).
3950
3951             if Expander_Active and then Tagged_Type_Expansion then
3952                EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
3953             end if;
3954
3955             CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
3956             Set_Equivalent_Type (CW_Subtype, EQ_Typ);
3957
3958             if Present (EQ_Typ) then
3959                Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
3960             end if;
3961
3962             Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
3963
3964             return New_Occurrence_Of (CW_Subtype, Loc);
3965          end;
3966
3967       --  Indefinite record type with discriminants
3968
3969       else
3970          D := First_Discriminant (Unc_Typ);
3971          while Present (D) loop
3972             Append_To (List_Constr,
3973               Make_Selected_Component (Loc,
3974                 Prefix        => Duplicate_Subexpr_No_Checks (E),
3975                 Selector_Name => New_Reference_To (D, Loc)));
3976
3977             Next_Discriminant (D);
3978          end loop;
3979       end if;
3980
3981       return
3982         Make_Subtype_Indication (Loc,
3983           Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
3984           Constraint   =>
3985             Make_Index_Or_Discriminant_Constraint (Loc,
3986               Constraints => List_Constr));
3987    end Make_Subtype_From_Expr;
3988
3989    -----------------------------
3990    -- May_Generate_Large_Temp --
3991    -----------------------------
3992
3993    --  At the current time, the only types that we return False for (i.e.
3994    --  where we decide we know they cannot generate large temps) are ones
3995    --  where we know the size is 256 bits or less at compile time, and we
3996    --  are still not doing a thorough job on arrays and records ???
3997
3998    function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
3999    begin
4000       if not Size_Known_At_Compile_Time (Typ) then
4001          return False;
4002
4003       elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
4004          return False;
4005
4006       elsif Is_Array_Type (Typ)
4007         and then Present (Packed_Array_Type (Typ))
4008       then
4009          return May_Generate_Large_Temp (Packed_Array_Type (Typ));
4010
4011       --  We could do more here to find other small types ???
4012
4013       else
4014          return True;
4015       end if;
4016    end May_Generate_Large_Temp;
4017
4018    ----------------------------
4019    -- New_Class_Wide_Subtype --
4020    ----------------------------
4021
4022    function New_Class_Wide_Subtype
4023      (CW_Typ : Entity_Id;
4024       N      : Node_Id) return Entity_Id
4025    is
4026       Res       : constant Entity_Id := Create_Itype (E_Void, N);
4027       Res_Name  : constant Name_Id   := Chars (Res);
4028       Res_Scope : constant Entity_Id := Scope (Res);
4029
4030    begin
4031       Copy_Node (CW_Typ, Res);
4032       Set_Comes_From_Source (Res, False);
4033       Set_Sloc (Res, Sloc (N));
4034       Set_Is_Itype (Res);
4035       Set_Associated_Node_For_Itype (Res, N);
4036       Set_Is_Public (Res, False);   --  By default, may be changed below.
4037       Set_Public_Status (Res);
4038       Set_Chars (Res, Res_Name);
4039       Set_Scope (Res, Res_Scope);
4040       Set_Ekind (Res, E_Class_Wide_Subtype);
4041       Set_Next_Entity (Res, Empty);
4042       Set_Etype (Res, Base_Type (CW_Typ));
4043
4044       --  For targets where front-end layout is required, reset the Is_Frozen
4045       --  status of the subtype to False (it can be implicitly set to true
4046       --  from the copy of the class-wide type). For other targets, Gigi
4047       --  doesn't want the class-wide subtype to go through the freezing
4048       --  process (though it's unclear why that causes problems and it would
4049       --  be nice to allow freezing to occur normally for all targets ???).
4050
4051       if Frontend_Layout_On_Target then
4052          Set_Is_Frozen (Res, False);
4053       end if;
4054
4055       Set_Freeze_Node (Res, Empty);
4056       return (Res);
4057    end New_Class_Wide_Subtype;
4058
4059    --------------------------------
4060    -- Non_Limited_Designated_Type --
4061    ---------------------------------
4062
4063    function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
4064       Desig : constant Entity_Id := Designated_Type (T);
4065    begin
4066       if Ekind (Desig) = E_Incomplete_Type
4067         and then Present (Non_Limited_View (Desig))
4068       then
4069          return Non_Limited_View (Desig);
4070       else
4071          return Desig;
4072       end if;
4073    end Non_Limited_Designated_Type;
4074
4075    -----------------------------------
4076    -- OK_To_Do_Constant_Replacement --
4077    -----------------------------------
4078
4079    function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
4080       ES : constant Entity_Id := Scope (E);
4081       CS : Entity_Id;
4082
4083    begin
4084       --  Do not replace statically allocated objects, because they may be
4085       --  modified outside the current scope.
4086
4087       if Is_Statically_Allocated (E) then
4088          return False;
4089
4090       --  Do not replace aliased or volatile objects, since we don't know what
4091       --  else might change the value.
4092
4093       elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
4094          return False;
4095
4096       --  Debug flag -gnatdM disconnects this optimization
4097
4098       elsif Debug_Flag_MM then
4099          return False;
4100
4101       --  Otherwise check scopes
4102
4103       else
4104          CS := Current_Scope;
4105
4106          loop
4107             --  If we are in right scope, replacement is safe
4108
4109             if CS = ES then
4110                return True;
4111
4112             --  Packages do not affect the determination of safety
4113
4114             elsif Ekind (CS) = E_Package then
4115                exit when CS = Standard_Standard;
4116                CS := Scope (CS);
4117
4118             --  Blocks do not affect the determination of safety
4119
4120             elsif Ekind (CS) = E_Block then
4121                CS := Scope (CS);
4122
4123             --  Loops do not affect the determination of safety. Note that we
4124             --  kill all current values on entry to a loop, so we are just
4125             --  talking about processing within a loop here.
4126
4127             elsif Ekind (CS) = E_Loop then
4128                CS := Scope (CS);
4129
4130             --  Otherwise, the reference is dubious, and we cannot be sure that
4131             --  it is safe to do the replacement.
4132
4133             else
4134                exit;
4135             end if;
4136          end loop;
4137
4138          return False;
4139       end if;
4140    end OK_To_Do_Constant_Replacement;
4141
4142    ------------------------------------
4143    -- Possible_Bit_Aligned_Component --
4144    ------------------------------------
4145
4146    function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
4147    begin
4148       case Nkind (N) is
4149
4150          --  Case of indexed component
4151
4152          when N_Indexed_Component =>
4153             declare
4154                P    : constant Node_Id   := Prefix (N);
4155                Ptyp : constant Entity_Id := Etype (P);
4156
4157             begin
4158                --  If we know the component size and it is less than 64, then
4159                --  we are definitely OK. The back end always does assignment of
4160                --  misaligned small objects correctly.
4161
4162                if Known_Static_Component_Size (Ptyp)
4163                  and then Component_Size (Ptyp) <= 64
4164                then
4165                   return False;
4166
4167                --  Otherwise, we need to test the prefix, to see if we are
4168                --  indexing from a possibly unaligned component.
4169
4170                else
4171                   return Possible_Bit_Aligned_Component (P);
4172                end if;
4173             end;
4174
4175          --  Case of selected component
4176
4177          when N_Selected_Component =>
4178             declare
4179                P    : constant Node_Id   := Prefix (N);
4180                Comp : constant Entity_Id := Entity (Selector_Name (N));
4181
4182             begin
4183                --  If there is no component clause, then we are in the clear
4184                --  since the back end will never misalign a large component
4185                --  unless it is forced to do so. In the clear means we need
4186                --  only the recursive test on the prefix.
4187
4188                if Component_May_Be_Bit_Aligned (Comp) then
4189                   return True;
4190                else
4191                   return Possible_Bit_Aligned_Component (P);
4192                end if;
4193             end;
4194
4195          --  For a slice, test the prefix, if that is possibly misaligned,
4196          --  then for sure the slice is!
4197
4198          when N_Slice =>
4199             return Possible_Bit_Aligned_Component (Prefix (N));
4200
4201          --  If we have none of the above, it means that we have fallen off the
4202          --  top testing prefixes recursively, and we now have a stand alone
4203          --  object, where we don't have a problem.
4204
4205          when others =>
4206             return False;
4207
4208       end case;
4209    end Possible_Bit_Aligned_Component;
4210
4211    -------------------------
4212    -- Remove_Side_Effects --
4213    -------------------------
4214
4215    procedure Remove_Side_Effects
4216      (Exp          : Node_Id;
4217       Name_Req     : Boolean := False;
4218       Variable_Ref : Boolean := False)
4219    is
4220       Loc          : constant Source_Ptr     := Sloc (Exp);
4221       Exp_Type     : constant Entity_Id      := Etype (Exp);
4222       Svg_Suppress : constant Suppress_Array := Scope_Suppress;
4223       Def_Id       : Entity_Id;
4224       Ref_Type     : Entity_Id;
4225       Res          : Node_Id;
4226       Ptr_Typ_Decl : Node_Id;
4227       New_Exp      : Node_Id;
4228       E            : Node_Id;
4229
4230       function Side_Effect_Free (N : Node_Id) return Boolean;
4231       --  Determines if the tree N represents an expression that is known not
4232       --  to have side effects, and for which no processing is required.
4233
4234       function Side_Effect_Free (L : List_Id) return Boolean;
4235       --  Determines if all elements of the list L are side effect free
4236
4237       function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
4238       --  The argument N is a construct where the Prefix is dereferenced if it
4239       --  is an access type and the result is a variable. The call returns True
4240       --  if the construct is side effect free (not considering side effects in
4241       --  other than the prefix which are to be tested by the caller).
4242
4243       function Within_In_Parameter (N : Node_Id) return Boolean;
4244       --  Determines if N is a subcomponent of a composite in-parameter. If so,
4245       --  N is not side-effect free when the actual is global and modifiable
4246       --  indirectly from within a subprogram, because it may be passed by
4247       --  reference. The front-end must be conservative here and assume that
4248       --  this may happen with any array or record type. On the other hand, we
4249       --  cannot create temporaries for all expressions for which this
4250       --  condition is true, for various reasons that might require clearing up
4251       --  ??? For example, discriminant references that appear out of place, or
4252       --  spurious type errors with class-wide expressions. As a result, we
4253       --  limit the transformation to loop bounds, which is so far the only
4254       --  case that requires it.
4255
4256       -----------------------------
4257       -- Safe_Prefixed_Reference --
4258       -----------------------------
4259
4260       function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
4261       begin
4262          --  If prefix is not side effect free, definitely not safe
4263
4264          if not Side_Effect_Free (Prefix (N)) then
4265             return False;
4266
4267          --  If the prefix is of an access type that is not access-to-constant,
4268          --  then this construct is a variable reference, which means it is to
4269          --  be considered to have side effects if Variable_Ref is set True
4270          --  Exception is an access to an entity that is a constant or an
4271          --  in-parameter which does not come from source, and is the result
4272          --  of a previous removal of side-effects.
4273
4274          elsif Is_Access_Type (Etype (Prefix (N)))
4275            and then not Is_Access_Constant (Etype (Prefix (N)))
4276            and then Variable_Ref
4277          then
4278             if not Is_Entity_Name (Prefix (N)) then
4279                return False;
4280             else
4281                return Ekind (Entity (Prefix (N))) = E_Constant
4282                  or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
4283             end if;
4284
4285          --  The following test is the simplest way of solving a complex
4286          --  problem uncovered by BB08-010: Side effect on loop bound that
4287          --  is a subcomponent of a global variable:
4288          --    If a loop bound is a subcomponent of a global variable, a
4289          --    modification of that variable within the loop may incorrectly
4290          --    affect the execution of the loop.
4291
4292          elsif not
4293            (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
4294               or else not Within_In_Parameter (Prefix (N)))
4295          then
4296             return False;
4297
4298          --  All other cases are side effect free
4299
4300          else
4301             return True;
4302          end if;
4303       end Safe_Prefixed_Reference;
4304
4305       ----------------------
4306       -- Side_Effect_Free --
4307       ----------------------
4308
4309       function Side_Effect_Free (N : Node_Id) return Boolean is
4310       begin
4311          --  Note on checks that could raise Constraint_Error. Strictly, if
4312          --  we take advantage of 11.6, these checks do not count as side
4313          --  effects. However, we would just as soon consider that they are
4314          --  side effects, since the backend CSE does not work very well on
4315          --  expressions which can raise Constraint_Error. On the other
4316          --  hand, if we do not consider them to be side effect free, then
4317          --  we get some awkward expansions in -gnato mode, resulting in
4318          --  code insertions at a point where we do not have a clear model
4319          --  for performing the insertions.
4320
4321          --  Special handling for entity names
4322
4323          if Is_Entity_Name (N) then
4324
4325             --  If the entity is a constant, it is definitely side effect
4326             --  free. Note that the test of Is_Variable (N) below might
4327             --  be expected to catch this case, but it does not, because
4328             --  this test goes to the original tree, and we may have
4329             --  already rewritten a variable node with a constant as
4330             --  a result of an earlier Force_Evaluation call.
4331
4332             if Ekind (Entity (N)) = E_Constant
4333               or else Ekind (Entity (N)) = E_In_Parameter
4334             then
4335                return True;
4336
4337             --  Functions are not side effect free
4338
4339             elsif Ekind (Entity (N)) = E_Function then
4340                return False;
4341
4342             --  Variables are considered to be a side effect if Variable_Ref
4343             --  is set or if we have a volatile reference and Name_Req is off.
4344             --  If Name_Req is True then we can't help returning a name which
4345             --  effectively allows multiple references in any case.
4346
4347             elsif Is_Variable (N) then
4348                return not Variable_Ref
4349                  and then (not Is_Volatile_Reference (N) or else Name_Req);
4350
4351             --  Any other entity (e.g. a subtype name) is definitely side
4352             --  effect free.
4353
4354             else
4355                return True;
4356             end if;
4357
4358          --  A value known at compile time is always side effect free
4359
4360          elsif Compile_Time_Known_Value (N) then
4361             return True;
4362
4363          --  A variable renaming is not side-effect free, because the
4364          --  renaming will function like a macro in the front-end in
4365          --  some cases, and an assignment can modify the component
4366          --  designated by N, so we need to create a temporary for it.
4367
4368          elsif Is_Entity_Name (Original_Node (N))
4369            and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
4370            and then Ekind (Entity (Original_Node (N))) /= E_Constant
4371          then
4372             return False;
4373          end if;
4374
4375          --  For other than entity names and compile time known values,
4376          --  check the node kind for special processing.
4377
4378          case Nkind (N) is
4379
4380             --  An attribute reference is side effect free if its expressions
4381             --  are side effect free and its prefix is side effect free or
4382             --  is an entity reference.
4383
4384             --  Is this right? what about x'first where x is a variable???
4385
4386             when N_Attribute_Reference =>
4387                return Side_Effect_Free (Expressions (N))
4388                  and then Attribute_Name (N) /= Name_Input
4389                  and then (Is_Entity_Name (Prefix (N))
4390                             or else Side_Effect_Free (Prefix (N)));
4391
4392             --  A binary operator is side effect free if and both operands
4393             --  are side effect free. For this purpose binary operators
4394             --  include membership tests and short circuit forms
4395
4396             when N_Binary_Op       |
4397                  N_Membership_Test |
4398                  N_And_Then        |
4399                  N_Or_Else         =>
4400                return Side_Effect_Free (Left_Opnd  (N))
4401                  and then Side_Effect_Free (Right_Opnd (N));
4402
4403             --  An explicit dereference is side effect free only if it is
4404             --  a side effect free prefixed reference.
4405
4406             when N_Explicit_Dereference =>
4407                return Safe_Prefixed_Reference (N);
4408
4409             --  A call to _rep_to_pos is side effect free, since we generate
4410             --  this pure function call ourselves. Moreover it is critically
4411             --  important to make this exception, since otherwise we can
4412             --  have discriminants in array components which don't look
4413             --  side effect free in the case of an array whose index type
4414             --  is an enumeration type with an enumeration rep clause.
4415
4416             --  All other function calls are not side effect free
4417
4418             when N_Function_Call =>
4419                return Nkind (Name (N)) = N_Identifier
4420                  and then Is_TSS (Name (N), TSS_Rep_To_Pos)
4421                  and then
4422                    Side_Effect_Free (First (Parameter_Associations (N)));
4423
4424             --  An indexed component is side effect free if it is a side
4425             --  effect free prefixed reference and all the indexing
4426             --  expressions are side effect free.
4427
4428             when N_Indexed_Component =>
4429                return Side_Effect_Free (Expressions (N))
4430                  and then Safe_Prefixed_Reference (N);
4431
4432             --  A type qualification is side effect free if the expression
4433             --  is side effect free.
4434
4435             when N_Qualified_Expression =>
4436                return Side_Effect_Free (Expression (N));
4437
4438             --  A selected component is side effect free only if it is a
4439             --  side effect free prefixed reference. If it designates a
4440             --  component with a rep. clause it must be treated has having
4441             --  a potential side effect, because it may be modified through
4442             --  a renaming, and a subsequent use of the renaming as a macro
4443             --  will yield the wrong value. This complex interaction between
4444             --  renaming and removing side effects is a reminder that the
4445             --  latter has become a headache to maintain, and that it should
4446             --  be removed in favor of the gcc mechanism to capture values ???
4447
4448             when N_Selected_Component =>
4449                if Nkind (Parent (N)) = N_Explicit_Dereference
4450                  and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
4451                then
4452                   return False;
4453                else
4454                   return Safe_Prefixed_Reference (N);
4455                end if;
4456
4457             --  A range is side effect free if the bounds are side effect free
4458
4459             when N_Range =>
4460                return Side_Effect_Free (Low_Bound (N))
4461                  and then Side_Effect_Free (High_Bound (N));
4462
4463             --  A slice is side effect free if it is a side effect free
4464             --  prefixed reference and the bounds are side effect free.
4465
4466             when N_Slice =>
4467                return Side_Effect_Free (Discrete_Range (N))
4468                  and then Safe_Prefixed_Reference (N);
4469
4470             --  A type conversion is side effect free if the expression to be
4471             --  converted is side effect free.
4472
4473             when N_Type_Conversion =>
4474                return Side_Effect_Free (Expression (N));
4475
4476             --  A unary operator is side effect free if the operand
4477             --  is side effect free.
4478
4479             when N_Unary_Op =>
4480                return Side_Effect_Free (Right_Opnd (N));
4481
4482             --  An unchecked type conversion is side effect free only if it
4483             --  is safe and its argument is side effect free.
4484
4485             when N_Unchecked_Type_Conversion =>
4486                return Safe_Unchecked_Type_Conversion (N)
4487                  and then Side_Effect_Free (Expression (N));
4488
4489             --  An unchecked expression is side effect free if its expression
4490             --  is side effect free.
4491
4492             when N_Unchecked_Expression =>
4493                return Side_Effect_Free (Expression (N));
4494
4495             --  A literal is side effect free
4496
4497             when N_Character_Literal    |
4498                  N_Integer_Literal      |
4499                  N_Real_Literal         |
4500                  N_String_Literal       =>
4501                return True;
4502
4503             --  We consider that anything else has side effects. This is a bit
4504             --  crude, but we are pretty close for most common cases, and we
4505             --  are certainly correct (i.e. we never return True when the
4506             --  answer should be False).
4507
4508             when others =>
4509                return False;
4510          end case;
4511       end Side_Effect_Free;
4512
4513       --  A list is side effect free if all elements of the list are
4514       --  side effect free.
4515
4516       function Side_Effect_Free (L : List_Id) return Boolean is
4517          N : Node_Id;
4518
4519       begin
4520          if L = No_List or else L = Error_List then
4521             return True;
4522
4523          else
4524             N := First (L);
4525             while Present (N) loop
4526                if not Side_Effect_Free (N) then
4527                   return False;
4528                else
4529                   Next (N);
4530                end if;
4531             end loop;
4532
4533             return True;
4534          end if;
4535       end Side_Effect_Free;
4536
4537       -------------------------
4538       -- Within_In_Parameter --
4539       -------------------------
4540
4541       function Within_In_Parameter (N : Node_Id) return Boolean is
4542       begin
4543          if not Comes_From_Source (N) then
4544             return False;
4545
4546          elsif Is_Entity_Name (N) then
4547             return Ekind (Entity (N)) = E_In_Parameter;
4548
4549          elsif Nkind (N) = N_Indexed_Component
4550            or else Nkind (N) = N_Selected_Component
4551          then
4552             return Within_In_Parameter (Prefix (N));
4553          else
4554
4555             return False;
4556          end if;
4557       end Within_In_Parameter;
4558
4559    --  Start of processing for Remove_Side_Effects
4560
4561    begin
4562       --  If we are side effect free already or expansion is disabled,
4563       --  there is nothing to do.
4564
4565       if Side_Effect_Free (Exp) or else not Expander_Active then
4566          return;
4567       end if;
4568
4569       --  All this must not have any checks
4570
4571       Scope_Suppress := (others => True);
4572
4573       --  If it is a scalar type and we need to capture the value, just make
4574       --  a copy. Likewise for a function call, an attribute reference or an
4575       --  operator. And if we have a volatile reference and Name_Req is not
4576       --  set (see comments above for Side_Effect_Free).
4577
4578       if Is_Elementary_Type (Exp_Type)
4579         and then (Variable_Ref
4580                    or else Nkind (Exp) = N_Function_Call
4581                    or else Nkind (Exp) = N_Attribute_Reference
4582                    or else Nkind (Exp) in N_Op
4583                    or else (not Name_Req and then Is_Volatile_Reference (Exp)))
4584       then
4585          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4586          Set_Etype (Def_Id, Exp_Type);
4587          Res := New_Reference_To (Def_Id, Loc);
4588
4589          E :=
4590            Make_Object_Declaration (Loc,
4591              Defining_Identifier => Def_Id,
4592              Object_Definition   => New_Reference_To (Exp_Type, Loc),
4593              Constant_Present    => True,
4594              Expression          => Relocate_Node (Exp));
4595
4596          Set_Assignment_OK (E);
4597          Insert_Action (Exp, E);
4598          Set_Related_Expression (Def_Id, Exp);
4599
4600       --  If the expression has the form v.all then we can just capture
4601       --  the pointer, and then do an explicit dereference on the result.
4602
4603       elsif Nkind (Exp) = N_Explicit_Dereference then
4604          Def_Id :=
4605            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4606          Res :=
4607            Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
4608
4609          Insert_Action (Exp,
4610            Make_Object_Declaration (Loc,
4611              Defining_Identifier => Def_Id,
4612              Object_Definition   =>
4613                New_Reference_To (Etype (Prefix (Exp)), Loc),
4614              Constant_Present    => True,
4615              Expression          => Relocate_Node (Prefix (Exp))));
4616          Set_Related_Expression (Def_Id, Exp);
4617
4618       --  Similar processing for an unchecked conversion of an expression
4619       --  of the form v.all, where we want the same kind of treatment.
4620
4621       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4622         and then Nkind (Expression (Exp)) = N_Explicit_Dereference
4623       then
4624          Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
4625          Scope_Suppress := Svg_Suppress;
4626          return;
4627
4628       --  If this is a type conversion, leave the type conversion and remove
4629       --  the side effects in the expression. This is important in several
4630       --  circumstances: for change of representations, and also when this is
4631       --  a view conversion to a smaller object, where gigi can end up creating
4632       --  its own temporary of the wrong size.
4633
4634       elsif Nkind (Exp) = N_Type_Conversion then
4635          Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
4636          Scope_Suppress := Svg_Suppress;
4637          return;
4638
4639       --  If this is an unchecked conversion that Gigi can't handle, make
4640       --  a copy or a use a renaming to capture the value.
4641
4642       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4643         and then not Safe_Unchecked_Type_Conversion (Exp)
4644       then
4645          if CW_Or_Has_Controlled_Part (Exp_Type) then
4646
4647             --  Use a renaming to capture the expression, rather than create
4648             --  a controlled temporary.
4649
4650             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4651             Res := New_Reference_To (Def_Id, Loc);
4652
4653             Insert_Action (Exp,
4654               Make_Object_Renaming_Declaration (Loc,
4655                 Defining_Identifier => Def_Id,
4656                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
4657                 Name                => Relocate_Node (Exp)));
4658             Set_Related_Expression (Def_Id, Exp);
4659
4660          else
4661             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4662             Set_Etype (Def_Id, Exp_Type);
4663             Res := New_Reference_To (Def_Id, Loc);
4664
4665             E :=
4666               Make_Object_Declaration (Loc,
4667                 Defining_Identifier => Def_Id,
4668                 Object_Definition   => New_Reference_To (Exp_Type, Loc),
4669                 Constant_Present    => not Is_Variable (Exp),
4670                 Expression          => Relocate_Node (Exp));
4671
4672             Set_Assignment_OK (E);
4673             Insert_Action (Exp, E);
4674             Set_Related_Expression (Def_Id, Exp);
4675          end if;
4676
4677       --  For expressions that denote objects, we can use a renaming scheme.
4678       --  We skip using this if we have a volatile reference and we do not
4679       --  have Name_Req set true (see comments above for Side_Effect_Free).
4680
4681       elsif Is_Object_Reference (Exp)
4682         and then Nkind (Exp) /= N_Function_Call
4683         and then (Name_Req or else not Is_Volatile_Reference (Exp))
4684       then
4685          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4686
4687          if Nkind (Exp) = N_Selected_Component
4688            and then Nkind (Prefix (Exp)) = N_Function_Call
4689            and then Is_Array_Type (Exp_Type)
4690          then
4691             --  Avoid generating a variable-sized temporary, by generating
4692             --  the renaming declaration just for the function call. The
4693             --  transformation could be refined to apply only when the array
4694             --  component is constrained by a discriminant???
4695
4696             Res :=
4697               Make_Selected_Component (Loc,
4698                 Prefix => New_Occurrence_Of (Def_Id, Loc),
4699                 Selector_Name => Selector_Name (Exp));
4700
4701             Insert_Action (Exp,
4702               Make_Object_Renaming_Declaration (Loc,
4703                 Defining_Identifier => Def_Id,
4704                 Subtype_Mark        =>
4705                   New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
4706                 Name                => Relocate_Node (Prefix (Exp))));
4707
4708          else
4709             Res := New_Reference_To (Def_Id, Loc);
4710
4711             Insert_Action (Exp,
4712               Make_Object_Renaming_Declaration (Loc,
4713                 Defining_Identifier => Def_Id,
4714                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
4715                 Name                => Relocate_Node (Exp)));
4716          end if;
4717
4718          Set_Related_Expression (Def_Id, Exp);
4719
4720          --  If this is a packed reference, or a selected component with a
4721          --  non-standard representation, a reference to the temporary will
4722          --  be replaced by a copy of the original expression (see
4723          --  Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
4724          --  elaborated by gigi, and is of course not to be replaced in-line
4725          --  by the expression it renames, which would defeat the purpose of
4726          --  removing the side-effect.
4727
4728          if (Nkind (Exp) = N_Selected_Component
4729               or else Nkind (Exp) = N_Indexed_Component)
4730            and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
4731          then
4732             null;
4733          else
4734             Set_Is_Renaming_Of_Object (Def_Id, False);
4735          end if;
4736
4737       --  Otherwise we generate a reference to the value
4738
4739       else
4740          --  Special processing for function calls that return a task. We need
4741          --  to build a declaration that will enable build-in-place expansion
4742          --  of the call.
4743
4744          --  This is relevant only in Ada 2005 mode. In Ada 95 programs we have
4745          --  to accommodate functions returning limited objects by reference.
4746
4747          if Nkind (Exp) = N_Function_Call
4748            and then Is_Task_Type (Etype (Exp))
4749            and then Ada_Version >= Ada_05
4750          then
4751             declare
4752                Obj  : constant Entity_Id :=
4753                         Make_Defining_Identifier (Loc,
4754                           Chars => New_Internal_Name ('F'));
4755                Decl : Node_Id;
4756
4757             begin
4758                Decl :=
4759                  Make_Object_Declaration (Loc,
4760                    Defining_Identifier => Obj,
4761                    Object_Definition   => New_Occurrence_Of (Exp_Type, Loc),
4762                    Expression          => Relocate_Node (Exp));
4763                Insert_Action (Exp, Decl);
4764                Set_Etype (Obj, Exp_Type);
4765                Set_Related_Expression (Obj, Exp);
4766                Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
4767                return;
4768             end;
4769          end if;
4770
4771          Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4772
4773          Ptr_Typ_Decl :=
4774            Make_Full_Type_Declaration (Loc,
4775              Defining_Identifier => Ref_Type,
4776              Type_Definition =>
4777                Make_Access_To_Object_Definition (Loc,
4778                  All_Present => True,
4779                  Subtype_Indication =>
4780                    New_Reference_To (Exp_Type, Loc)));
4781
4782          E := Exp;
4783          Insert_Action (Exp, Ptr_Typ_Decl);
4784
4785          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4786          Set_Etype (Def_Id, Exp_Type);
4787
4788          Res :=
4789            Make_Explicit_Dereference (Loc,
4790              Prefix => New_Reference_To (Def_Id, Loc));
4791
4792          if Nkind (E) = N_Explicit_Dereference then
4793             New_Exp := Relocate_Node (Prefix (E));
4794          else
4795             E := Relocate_Node (E);
4796             New_Exp := Make_Reference (Loc, E);
4797          end if;
4798
4799          if Is_Delayed_Aggregate (E) then
4800
4801             --  The expansion of nested aggregates is delayed until the
4802             --  enclosing aggregate is expanded. As aggregates are often
4803             --  qualified, the predicate applies to qualified expressions
4804             --  as well, indicating that the enclosing aggregate has not
4805             --  been expanded yet. At this point the aggregate is part of
4806             --  a stand-alone declaration, and must be fully expanded.
4807
4808             if Nkind (E) = N_Qualified_Expression then
4809                Set_Expansion_Delayed (Expression (E), False);
4810                Set_Analyzed (Expression (E), False);
4811             else
4812                Set_Expansion_Delayed (E, False);
4813             end if;
4814
4815             Set_Analyzed (E, False);
4816          end if;
4817
4818          Insert_Action (Exp,
4819            Make_Object_Declaration (Loc,
4820              Defining_Identifier => Def_Id,
4821              Object_Definition   => New_Reference_To (Ref_Type, Loc),
4822              Expression          => New_Exp));
4823          Set_Related_Expression (Def_Id, Exp);
4824       end if;
4825
4826       --  Preserve the Assignment_OK flag in all copies, since at least
4827       --  one copy may be used in a context where this flag must be set
4828       --  (otherwise why would the flag be set in the first place).
4829
4830       Set_Assignment_OK (Res, Assignment_OK (Exp));
4831
4832       --  Finally rewrite the original expression and we are done
4833
4834       Rewrite (Exp, Res);
4835       Analyze_And_Resolve (Exp, Exp_Type);
4836       Scope_Suppress := Svg_Suppress;
4837    end Remove_Side_Effects;
4838
4839    ---------------------------
4840    -- Represented_As_Scalar --
4841    ---------------------------
4842
4843    function Represented_As_Scalar (T : Entity_Id) return Boolean is
4844       UT : constant Entity_Id := Underlying_Type (T);
4845    begin
4846       return Is_Scalar_Type (UT)
4847         or else (Is_Bit_Packed_Array (UT)
4848                    and then Is_Scalar_Type (Packed_Array_Type (UT)));
4849    end Represented_As_Scalar;
4850
4851    ------------------------------------
4852    -- Safe_Unchecked_Type_Conversion --
4853    ------------------------------------
4854
4855    --  Note: this function knows quite a bit about the exact requirements
4856    --  of Gigi with respect to unchecked type conversions, and its code
4857    --  must be coordinated with any changes in Gigi in this area.
4858
4859    --  The above requirements should be documented in Sinfo ???
4860
4861    function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
4862       Otyp   : Entity_Id;
4863       Ityp   : Entity_Id;
4864       Oalign : Uint;
4865       Ialign : Uint;
4866       Pexp   : constant Node_Id := Parent (Exp);
4867
4868    begin
4869       --  If the expression is the RHS of an assignment or object declaration
4870       --   we are always OK because there will always be a target.
4871
4872       --  Object renaming declarations, (generated for view conversions of
4873       --  actuals in inlined calls), like object declarations, provide an
4874       --  explicit type, and are safe as well.
4875
4876       if (Nkind (Pexp) = N_Assignment_Statement
4877            and then Expression (Pexp) = Exp)
4878         or else Nkind (Pexp) = N_Object_Declaration
4879         or else Nkind (Pexp) = N_Object_Renaming_Declaration
4880       then
4881          return True;
4882
4883       --  If the expression is the prefix of an N_Selected_Component
4884       --  we should also be OK because GCC knows to look inside the
4885       --  conversion except if the type is discriminated. We assume
4886       --  that we are OK anyway if the type is not set yet or if it is
4887       --  controlled since we can't afford to introduce a temporary in
4888       --  this case.
4889
4890       elsif Nkind (Pexp) = N_Selected_Component
4891          and then Prefix (Pexp) = Exp
4892       then
4893          if No (Etype (Pexp)) then
4894             return True;
4895          else
4896             return
4897               not Has_Discriminants (Etype (Pexp))
4898                 or else Is_Constrained (Etype (Pexp));
4899          end if;
4900       end if;
4901
4902       --  Set the output type, this comes from Etype if it is set, otherwise
4903       --  we take it from the subtype mark, which we assume was already
4904       --  fully analyzed.
4905
4906       if Present (Etype (Exp)) then
4907          Otyp := Etype (Exp);
4908       else
4909          Otyp := Entity (Subtype_Mark (Exp));
4910       end if;
4911
4912       --  The input type always comes from the expression, and we assume
4913       --  this is indeed always analyzed, so we can simply get the Etype.
4914
4915       Ityp := Etype (Expression (Exp));
4916
4917       --  Initialize alignments to unknown so far
4918
4919       Oalign := No_Uint;
4920       Ialign := No_Uint;
4921
4922       --  Replace a concurrent type by its corresponding record type
4923       --  and each type by its underlying type and do the tests on those.
4924       --  The original type may be a private type whose completion is a
4925       --  concurrent type, so find the underlying type first.
4926
4927       if Present (Underlying_Type (Otyp)) then
4928          Otyp := Underlying_Type (Otyp);
4929       end if;
4930
4931       if Present (Underlying_Type (Ityp)) then
4932          Ityp := Underlying_Type (Ityp);
4933       end if;
4934
4935       if Is_Concurrent_Type (Otyp) then
4936          Otyp := Corresponding_Record_Type (Otyp);
4937       end if;
4938
4939       if Is_Concurrent_Type (Ityp) then
4940          Ityp := Corresponding_Record_Type (Ityp);
4941       end if;
4942
4943       --  If the base types are the same, we know there is no problem since
4944       --  this conversion will be a noop.
4945
4946       if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
4947          return True;
4948
4949       --  Same if this is an upwards conversion of an untagged type, and there
4950       --  are no constraints involved (could be more general???)
4951
4952       elsif Etype (Ityp) = Otyp
4953         and then not Is_Tagged_Type (Ityp)
4954         and then not Has_Discriminants (Ityp)
4955         and then No (First_Rep_Item (Base_Type (Ityp)))
4956       then
4957          return True;
4958
4959       --  If the expression has an access type (object or subprogram) we
4960       --  assume that the conversion is safe, because the size of the target
4961       --  is safe, even if it is a record (which might be treated as having
4962       --  unknown size at this point).
4963
4964       elsif Is_Access_Type (Ityp) then
4965          return True;
4966
4967       --  If the size of output type is known at compile time, there is
4968       --  never a problem.  Note that unconstrained records are considered
4969       --  to be of known size, but we can't consider them that way here,
4970       --  because we are talking about the actual size of the object.
4971
4972       --  We also make sure that in addition to the size being known, we do
4973       --  not have a case which might generate an embarrassingly large temp
4974       --  in stack checking mode.
4975
4976       elsif Size_Known_At_Compile_Time (Otyp)
4977         and then
4978           (not Stack_Checking_Enabled
4979              or else not May_Generate_Large_Temp (Otyp))
4980         and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
4981       then
4982          return True;
4983
4984       --  If either type is tagged, then we know the alignment is OK so
4985       --  Gigi will be able to use pointer punning.
4986
4987       elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
4988          return True;
4989
4990       --  If either type is a limited record type, we cannot do a copy, so
4991       --  say safe since there's nothing else we can do.
4992
4993       elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
4994          return True;
4995
4996       --  Conversions to and from packed array types are always ignored and
4997       --  hence are safe.
4998
4999       elsif Is_Packed_Array_Type (Otyp)
5000         or else Is_Packed_Array_Type (Ityp)
5001       then
5002          return True;
5003       end if;
5004
5005       --  The only other cases known to be safe is if the input type's
5006       --  alignment is known to be at least the maximum alignment for the
5007       --  target or if both alignments are known and the output type's
5008       --  alignment is no stricter than the input's.  We can use the alignment
5009       --  of the component type of an array if a type is an unpacked
5010       --  array type.
5011
5012       if Present (Alignment_Clause (Otyp)) then
5013          Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
5014
5015       elsif Is_Array_Type (Otyp)
5016         and then Present (Alignment_Clause (Component_Type (Otyp)))
5017       then
5018          Oalign := Expr_Value (Expression (Alignment_Clause
5019                                            (Component_Type (Otyp))));
5020       end if;
5021
5022       if Present (Alignment_Clause (Ityp)) then
5023          Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
5024
5025       elsif Is_Array_Type (Ityp)
5026         and then Present (Alignment_Clause (Component_Type (Ityp)))
5027       then
5028          Ialign := Expr_Value (Expression (Alignment_Clause
5029                                            (Component_Type (Ityp))));
5030       end if;
5031
5032       if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
5033          return True;
5034
5035       elsif Ialign /= No_Uint and then Oalign /= No_Uint
5036         and then Ialign <= Oalign
5037       then
5038          return True;
5039
5040       --   Otherwise, Gigi cannot handle this and we must make a temporary
5041
5042       else
5043          return False;
5044       end if;
5045    end Safe_Unchecked_Type_Conversion;
5046
5047    ---------------------------------
5048    -- Set_Current_Value_Condition --
5049    ---------------------------------
5050
5051    --  Note: the implementation of this procedure is very closely tied to the
5052    --  implementation of Get_Current_Value_Condition. Here we set required
5053    --  Current_Value fields, and in Get_Current_Value_Condition, we interpret
5054    --  them, so they must have a consistent view.
5055
5056    procedure Set_Current_Value_Condition (Cnode : Node_Id) is
5057
5058       procedure Set_Entity_Current_Value (N : Node_Id);
5059       --  If N is an entity reference, where the entity is of an appropriate
5060       --  kind, then set the current value of this entity to Cnode, unless
5061       --  there is already a definite value set there.
5062
5063       procedure Set_Expression_Current_Value (N : Node_Id);
5064       --  If N is of an appropriate form, sets an appropriate entry in current
5065       --  value fields of relevant entities. Multiple entities can be affected
5066       --  in the case of an AND or AND THEN.
5067
5068       ------------------------------
5069       -- Set_Entity_Current_Value --
5070       ------------------------------
5071
5072       procedure Set_Entity_Current_Value (N : Node_Id) is
5073       begin
5074          if Is_Entity_Name (N) then
5075             declare
5076                Ent : constant Entity_Id := Entity (N);
5077
5078             begin
5079                --  Don't capture if not safe to do so
5080
5081                if not Safe_To_Capture_Value (N, Ent, Cond => True) then
5082                   return;
5083                end if;
5084
5085                --  Here we have a case where the Current_Value field may
5086                --  need to be set. We set it if it is not already set to a
5087                --  compile time expression value.
5088
5089                --  Note that this represents a decision that one condition
5090                --  blots out another previous one. That's certainly right
5091                --  if they occur at the same level. If the second one is
5092                --  nested, then the decision is neither right nor wrong (it
5093                --  would be equally OK to leave the outer one in place, or
5094                --  take the new inner one. Really we should record both, but
5095                --  our data structures are not that elaborate.
5096
5097                if Nkind (Current_Value (Ent)) not in N_Subexpr then
5098                   Set_Current_Value (Ent, Cnode);
5099                end if;
5100             end;
5101          end if;
5102       end Set_Entity_Current_Value;
5103
5104       ----------------------------------
5105       -- Set_Expression_Current_Value --
5106       ----------------------------------
5107
5108       procedure Set_Expression_Current_Value (N : Node_Id) is
5109          Cond : Node_Id;
5110
5111       begin
5112          Cond := N;
5113
5114          --  Loop to deal with (ignore for now) any NOT operators present. The
5115          --  presence of NOT operators will be handled properly when we call
5116          --  Get_Current_Value_Condition.
5117
5118          while Nkind (Cond) = N_Op_Not loop
5119             Cond := Right_Opnd (Cond);
5120          end loop;
5121
5122          --  For an AND or AND THEN, recursively process operands
5123
5124          if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
5125             Set_Expression_Current_Value (Left_Opnd (Cond));
5126             Set_Expression_Current_Value (Right_Opnd (Cond));
5127             return;
5128          end if;
5129
5130          --  Check possible relational operator
5131
5132          if Nkind (Cond) in N_Op_Compare then
5133             if Compile_Time_Known_Value (Right_Opnd (Cond)) then
5134                Set_Entity_Current_Value (Left_Opnd (Cond));
5135             elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
5136                Set_Entity_Current_Value (Right_Opnd (Cond));
5137             end if;
5138
5139             --  Check possible boolean variable reference
5140
5141          else
5142             Set_Entity_Current_Value (Cond);
5143          end if;
5144       end Set_Expression_Current_Value;
5145
5146    --  Start of processing for Set_Current_Value_Condition
5147
5148    begin
5149       Set_Expression_Current_Value (Condition (Cnode));
5150    end Set_Current_Value_Condition;
5151
5152    --------------------------
5153    -- Set_Elaboration_Flag --
5154    --------------------------
5155
5156    procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
5157       Loc : constant Source_Ptr := Sloc (N);
5158       Ent : constant Entity_Id  := Elaboration_Entity (Spec_Id);
5159       Asn : Node_Id;
5160
5161    begin
5162       if Present (Ent) then
5163
5164          --  Nothing to do if at the compilation unit level, because in this
5165          --  case the flag is set by the binder generated elaboration routine.
5166
5167          if Nkind (Parent (N)) = N_Compilation_Unit then
5168             null;
5169
5170          --  Here we do need to generate an assignment statement
5171
5172          else
5173             Check_Restriction (No_Elaboration_Code, N);
5174             Asn :=
5175               Make_Assignment_Statement (Loc,
5176                 Name       => New_Occurrence_Of (Ent, Loc),
5177                 Expression => New_Occurrence_Of (Standard_True, Loc));
5178
5179             if Nkind (Parent (N)) = N_Subunit then
5180                Insert_After (Corresponding_Stub (Parent (N)), Asn);
5181             else
5182                Insert_After (N, Asn);
5183             end if;
5184
5185             Analyze (Asn);
5186
5187             --  Kill current value indication. This is necessary because the
5188             --  tests of this flag are inserted out of sequence and must not
5189             --  pick up bogus indications of the wrong constant value.
5190
5191             Set_Current_Value (Ent, Empty);
5192          end if;
5193       end if;
5194    end Set_Elaboration_Flag;
5195
5196    ----------------------------
5197    -- Set_Renamed_Subprogram --
5198    ----------------------------
5199
5200    procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
5201    begin
5202       --  If input node is an identifier, we can just reset it
5203
5204       if Nkind (N) = N_Identifier then
5205          Set_Chars  (N, Chars (E));
5206          Set_Entity (N, E);
5207
5208          --  Otherwise we have to do a rewrite, preserving Comes_From_Source
5209
5210       else
5211          declare
5212             CS : constant Boolean := Comes_From_Source (N);
5213          begin
5214             Rewrite (N, Make_Identifier (Sloc (N), Chars => Chars (E)));
5215             Set_Entity (N, E);
5216             Set_Comes_From_Source (N, CS);
5217             Set_Analyzed (N, True);
5218          end;
5219       end if;
5220    end Set_Renamed_Subprogram;
5221
5222    ----------------------------------
5223    -- Silly_Boolean_Array_Not_Test --
5224    ----------------------------------
5225
5226    --  This procedure implements an odd and silly test. We explicitly check
5227    --  for the case where the 'First of the component type is equal to the
5228    --  'Last of this component type, and if this is the case, we make sure
5229    --  that constraint error is raised. The reason is that the NOT is bound
5230    --  to cause CE in this case, and we will not otherwise catch it.
5231
5232    --  No such check is required for AND and OR, since for both these cases
5233    --  False op False = False, and True op True = True. For the XOR case,
5234    --  see Silly_Boolean_Array_Xor_Test.
5235
5236    --  Believe it or not, this was reported as a bug. Note that nearly
5237    --  always, the test will evaluate statically to False, so the code will
5238    --  be statically removed, and no extra overhead caused.
5239
5240    procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
5241       Loc : constant Source_Ptr := Sloc (N);
5242       CT  : constant Entity_Id  := Component_Type (T);
5243
5244    begin
5245       --  The check we install is
5246
5247       --    constraint_error when
5248       --      component_type'first = component_type'last
5249       --        and then array_type'Length /= 0)
5250
5251       --  We need the last guard because we don't want to raise CE for empty
5252       --  arrays since no out of range values result. (Empty arrays with a
5253       --  component type of True .. True -- very useful -- even the ACATS
5254       --  does not test that marginal case!)
5255
5256       Insert_Action (N,
5257         Make_Raise_Constraint_Error (Loc,
5258           Condition =>
5259             Make_And_Then (Loc,
5260               Left_Opnd =>
5261                 Make_Op_Eq (Loc,
5262                   Left_Opnd =>
5263                     Make_Attribute_Reference (Loc,
5264                       Prefix         => New_Occurrence_Of (CT, Loc),
5265                       Attribute_Name => Name_First),
5266
5267                   Right_Opnd =>
5268                     Make_Attribute_Reference (Loc,
5269                       Prefix         => New_Occurrence_Of (CT, Loc),
5270                       Attribute_Name => Name_Last)),
5271
5272               Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
5273           Reason => CE_Range_Check_Failed));
5274    end Silly_Boolean_Array_Not_Test;
5275
5276    ----------------------------------
5277    -- Silly_Boolean_Array_Xor_Test --
5278    ----------------------------------
5279
5280    --  This procedure implements an odd and silly test. We explicitly check
5281    --  for the XOR case where the component type is True .. True, since this
5282    --  will raise constraint error. A special check is required since CE
5283    --  will not be generated otherwise (cf Expand_Packed_Not).
5284
5285    --  No such check is required for AND and OR, since for both these cases
5286    --  False op False = False, and True op True = True, and no check is
5287    --  required for the case of False .. False, since False xor False = False.
5288    --  See also Silly_Boolean_Array_Not_Test
5289
5290    procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
5291       Loc : constant Source_Ptr := Sloc (N);
5292       CT  : constant Entity_Id  := Component_Type (T);
5293
5294    begin
5295       --  The check we install is
5296
5297       --    constraint_error when
5298       --      Boolean (component_type'First)
5299       --        and then Boolean (component_type'Last)
5300       --        and then array_type'Length /= 0)
5301
5302       --  We need the last guard because we don't want to raise CE for empty
5303       --  arrays since no out of range values result (Empty arrays with a
5304       --  component type of True .. True -- very useful -- even the ACATS
5305       --  does not test that marginal case!).
5306
5307       Insert_Action (N,
5308         Make_Raise_Constraint_Error (Loc,
5309           Condition =>
5310             Make_And_Then (Loc,
5311               Left_Opnd =>
5312                 Make_And_Then (Loc,
5313                   Left_Opnd =>
5314                     Convert_To (Standard_Boolean,
5315                       Make_Attribute_Reference (Loc,
5316                         Prefix         => New_Occurrence_Of (CT, Loc),
5317                         Attribute_Name => Name_First)),
5318
5319                   Right_Opnd =>
5320                     Convert_To (Standard_Boolean,
5321                       Make_Attribute_Reference (Loc,
5322                         Prefix         => New_Occurrence_Of (CT, Loc),
5323                         Attribute_Name => Name_Last))),
5324
5325               Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
5326           Reason => CE_Range_Check_Failed));
5327    end Silly_Boolean_Array_Xor_Test;
5328
5329    --------------------------
5330    -- Target_Has_Fixed_Ops --
5331    --------------------------
5332
5333    Integer_Sized_Small : Ureal;
5334    --  Set to 2.0 ** -(Integer'Size - 1) the first time that this
5335    --  function is called (we don't want to compute it more than once!)
5336
5337    Long_Integer_Sized_Small : Ureal;
5338    --  Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
5339    --  function is called (we don't want to compute it more than once)
5340
5341    First_Time_For_THFO : Boolean := True;
5342    --  Set to False after first call (if Fractional_Fixed_Ops_On_Target)
5343
5344    function Target_Has_Fixed_Ops
5345      (Left_Typ   : Entity_Id;
5346       Right_Typ  : Entity_Id;
5347       Result_Typ : Entity_Id) return Boolean
5348    is
5349       function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
5350       --  Return True if the given type is a fixed-point type with a small
5351       --  value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
5352       --  an absolute value less than 1.0. This is currently limited
5353       --  to fixed-point types that map to Integer or Long_Integer.
5354
5355       ------------------------
5356       -- Is_Fractional_Type --
5357       ------------------------
5358
5359       function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
5360       begin
5361          if Esize (Typ) = Standard_Integer_Size then
5362             return Small_Value (Typ) = Integer_Sized_Small;
5363
5364          elsif Esize (Typ) = Standard_Long_Integer_Size then
5365             return Small_Value (Typ) = Long_Integer_Sized_Small;
5366
5367          else
5368             return False;
5369          end if;
5370       end Is_Fractional_Type;
5371
5372    --  Start of processing for Target_Has_Fixed_Ops
5373
5374    begin
5375       --  Return False if Fractional_Fixed_Ops_On_Target is false
5376
5377       if not Fractional_Fixed_Ops_On_Target then
5378          return False;
5379       end if;
5380
5381       --  Here the target has Fractional_Fixed_Ops, if first time, compute
5382       --  standard constants used by Is_Fractional_Type.
5383
5384       if First_Time_For_THFO then
5385          First_Time_For_THFO := False;
5386
5387          Integer_Sized_Small :=
5388            UR_From_Components
5389              (Num   => Uint_1,
5390               Den   => UI_From_Int (Standard_Integer_Size - 1),
5391               Rbase => 2);
5392
5393          Long_Integer_Sized_Small :=
5394            UR_From_Components
5395              (Num   => Uint_1,
5396               Den   => UI_From_Int (Standard_Long_Integer_Size - 1),
5397               Rbase => 2);
5398       end if;
5399
5400       --  Return True if target supports fixed-by-fixed multiply/divide
5401       --  for fractional fixed-point types (see Is_Fractional_Type) and
5402       --  the operand and result types are equivalent fractional types.
5403
5404       return Is_Fractional_Type (Base_Type (Left_Typ))
5405         and then Is_Fractional_Type (Base_Type (Right_Typ))
5406         and then Is_Fractional_Type (Base_Type (Result_Typ))
5407         and then Esize (Left_Typ) = Esize (Right_Typ)
5408         and then Esize (Left_Typ) = Esize (Result_Typ);
5409    end Target_Has_Fixed_Ops;
5410
5411    ------------------------------------------
5412    -- Type_May_Have_Bit_Aligned_Components --
5413    ------------------------------------------
5414
5415    function Type_May_Have_Bit_Aligned_Components
5416      (Typ : Entity_Id) return Boolean
5417    is
5418    begin
5419       --  Array type, check component type
5420
5421       if Is_Array_Type (Typ) then
5422          return
5423            Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
5424
5425       --  Record type, check components
5426
5427       elsif Is_Record_Type (Typ) then
5428          declare
5429             E : Entity_Id;
5430
5431          begin
5432             E := First_Component_Or_Discriminant (Typ);
5433             while Present (E) loop
5434                if Component_May_Be_Bit_Aligned (E)
5435                  or else Type_May_Have_Bit_Aligned_Components (Etype (E))
5436                then
5437                   return True;
5438                end if;
5439
5440                Next_Component_Or_Discriminant (E);
5441             end loop;
5442
5443             return False;
5444          end;
5445
5446       --  Type other than array or record is always OK
5447
5448       else
5449          return False;
5450       end if;
5451    end Type_May_Have_Bit_Aligned_Components;
5452
5453    ----------------------------
5454    -- Wrap_Cleanup_Procedure --
5455    ----------------------------
5456
5457    procedure Wrap_Cleanup_Procedure (N : Node_Id) is
5458       Loc   : constant Source_Ptr := Sloc (N);
5459       Stseq : constant Node_Id    := Handled_Statement_Sequence (N);
5460       Stmts : constant List_Id    := Statements (Stseq);
5461
5462    begin
5463       if Abort_Allowed then
5464          Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
5465          Append_To  (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
5466       end if;
5467    end Wrap_Cleanup_Procedure;
5468
5469 end Exp_Util;