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-2011, 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 Casing;   use Casing;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Aggr; use Exp_Aggr;
  34 with Exp_Ch6;  use Exp_Ch6;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Inline;   use Inline;
  37 with Itypes;   use Itypes;
  38 with Lib;      use Lib;
  39 with Nlists;   use Nlists;
  40 with Nmake;    use Nmake;
  41 with Opt;      use Opt;
  42 with Restrict; use Restrict;
  43 with Rident;   use Rident;
  44 with Sem;      use Sem;
  45 with Sem_Aux;  use Sem_Aux;
  46 with Sem_Ch8;  use Sem_Ch8;
  47 with Sem_Eval; use Sem_Eval;
  48 with Sem_Prag; use Sem_Prag;
  49 with Sem_Res;  use Sem_Res;
  50 with Sem_Type; use Sem_Type;
  51 with Sem_Util; use Sem_Util;
  52 with Snames;   use Snames;
  53 with Stand;    use Stand;
  54 with Stringt;  use Stringt;
  55 with Targparm; use Targparm;
  56 with Tbuild;   use Tbuild;
  57 with Ttypes;   use Ttypes;
  58 with Urealp;   use Urealp;
  59 with Validsw;  use Validsw;
  60
  61 package body Exp_Util is
  62
  63    -----------------------
  64    -- Local Subprograms --
  65    -----------------------
  66
  67    function Build_Task_Array_Image
  68      (Loc    : Source_Ptr;
  69       Id_Ref : Node_Id;
  70       A_Type : Entity_Id;
  71       Dyn    : Boolean := False) return Node_Id;
  72    --  Build function to generate the image string for a task that is an array
  73    --  component, concatenating the images of each index. To avoid storage
  74    --  leaks, the string is built with successive slice assignments. The flag
  75    --  Dyn indicates whether this is called for the initialization procedure of
  76    --  an array of tasks, or for the name of a dynamically created task that is
  77    --  assigned to an indexed component.
  78
  79    function Build_Task_Image_Function
  80      (Loc   : Source_Ptr;
  81       Decls : List_Id;
  82       Stats : List_Id;
  83       Res   : Entity_Id) return Node_Id;
  84    --  Common processing for Task_Array_Image and Task_Record_Image. Build
  85    --  function body that computes image.
  86
  87    procedure Build_Task_Image_Prefix
  88       (Loc    : Source_Ptr;
  89        Len    : out Entity_Id;
  90        Res    : out Entity_Id;
  91        Pos    : out Entity_Id;
  92        Prefix : Entity_Id;
  93        Sum    : Node_Id;
  94        Decls  : List_Id;
  95        Stats  : List_Id);
  96    --  Common processing for Task_Array_Image and Task_Record_Image. Create
  97    --  local variables and assign prefix of name to result string.
  98
  99    function Build_Task_Record_Image
 100      (Loc    : Source_Ptr;
 101       Id_Ref : Node_Id;
 102       Dyn    : Boolean := False) return Node_Id;
 103    --  Build function to generate the image string for a task that is a record
 104    --  component. Concatenate name of variable with that of selector. The flag
 105    --  Dyn indicates whether this is called for the initialization procedure of
 106    --  record with task components, or for a dynamically created task that is
 107    --  assigned to a selected component.
 108
 109    function Make_CW_Equivalent_Type
 110      (T : Entity_Id;
 111       E : Node_Id) return Entity_Id;
 112    --  T is a class-wide type entity, E is the initial expression node that
 113    --  constrains T in case such as: " X: T := E" or "new T'(E)". This function
 114    --  returns the entity of the Equivalent type and inserts on the fly the
 115    --  necessary declaration such as:
 116    --
 117    --    type anon is record
 118    --       _parent : Root_Type (T); constrained with E discriminants (if any)
 119    --       Extension : String (1 .. expr to match size of E);
 120    --    end record;
 121    --
 122    --  This record is compatible with any object of the class of T thanks to
 123    --  the first field and has the same size as E thanks to the second.
 124
 125    function Make_Literal_Range
 126      (Loc         : Source_Ptr;
 127       Literal_Typ : Entity_Id) return Node_Id;
 128    --  Produce a Range node whose bounds are:
 129    --    Low_Bound (Literal_Type) ..
 130    --        Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
 131    --  this is used for expanding declarations like X : String := "sdfgdfg";
 132    --
 133    --  If the index type of the target array is not integer, we generate:
 134    --     Low_Bound (Literal_Type) ..
 135    --        Literal_Type'Val
 136    --          (Literal_Type'Pos (Low_Bound (Literal_Type))
 137    --             + (Length (Literal_Typ) -1))
 138
 139    function Make_Non_Empty_Check
 140      (Loc : Source_Ptr;
 141       N   : Node_Id) return Node_Id;
 142    --  Produce a boolean expression checking that the unidimensional array
 143    --  node N is not empty.
 144
 145    function New_Class_Wide_Subtype
 146      (CW_Typ : Entity_Id;
 147       N      : Node_Id) return Entity_Id;
 148    --  Create an implicit subtype of CW_Typ attached to node N
 149
 150    function Requires_Cleanup_Actions
 151      (L                 : List_Id;
 152       For_Package       : Boolean;
 153       Nested_Constructs : Boolean) return Boolean;
 154    --  Given a list L, determine whether it contains one of the following:
 155    --
 156    --    1) controlled objects
 157    --    2) library-level tagged types
 158    --
 159    --  Flag For_Package should be set when the list comes from a package spec
 160    --  or body. Flag Nested_Constructs should be set when any nested packages
 161    --  declared in L must be processed.
 162
 163    ----------------------
 164    -- Adjust_Condition --
 165    ----------------------
 166
 167    procedure Adjust_Condition (N : Node_Id) is
 168    begin
 169       if No (N) then
 170          return;
 171       end if;
 172
 173       declare
 174          Loc : constant Source_Ptr := Sloc (N);
 175          T   : constant Entity_Id  := Etype (N);
 176          Ti  : Entity_Id;
 177
 178       begin
 179          --  Defend against a call where the argument has no type, or has a
 180          --  type that is not Boolean. This can occur because of prior errors.
 181
 182          if No (T) or else not Is_Boolean_Type (T) then
 183             return;
 184          end if;
 185
 186          --  Apply validity checking if needed
 187
 188          if Validity_Checks_On and Validity_Check_Tests then
 189             Ensure_Valid (N);
 190          end if;
 191
 192          --  Immediate return if standard boolean, the most common case,
 193          --  where nothing needs to be done.
 194
 195          if Base_Type (T) = Standard_Boolean then
 196             return;
 197          end if;
 198
 199          --  Case of zero/non-zero semantics or non-standard enumeration
 200          --  representation. In each case, we rewrite the node as:
 201
 202          --      ityp!(N) /= False'Enum_Rep
 203
 204          --  where ityp is an integer type with large enough size to hold any
 205          --  value of type T.
 206
 207          if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
 208             if Esize (T) <= Esize (Standard_Integer) then
 209                Ti := Standard_Integer;
 210             else
 211                Ti := Standard_Long_Long_Integer;
 212             end if;
 213
 214             Rewrite (N,
 215               Make_Op_Ne (Loc,
 216                 Left_Opnd  => Unchecked_Convert_To (Ti, N),
 217                 Right_Opnd =>
 218                   Make_Attribute_Reference (Loc,
 219                     Attribute_Name => Name_Enum_Rep,
 220                     Prefix         =>
 221                       New_Occurrence_Of (First_Literal (T), Loc))));
 222             Analyze_And_Resolve (N, Standard_Boolean);
 223
 224          else
 225             Rewrite (N, Convert_To (Standard_Boolean, N));
 226             Analyze_And_Resolve (N, Standard_Boolean);
 227          end if;
 228       end;
 229    end Adjust_Condition;
 230
 231    ------------------------
 232    -- Adjust_Result_Type --
 233    ------------------------
 234
 235    procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
 236    begin
 237       --  Ignore call if current type is not Standard.Boolean
 238
 239       if Etype (N) /= Standard_Boolean then
 240          return;
 241       end if;
 242
 243       --  If result is already of correct type, nothing to do. Note that
 244       --  this will get the most common case where everything has a type
 245       --  of Standard.Boolean.
 246
 247       if Base_Type (T) = Standard_Boolean then
 248          return;
 249
 250       else
 251          declare
 252             KP : constant Node_Kind := Nkind (Parent (N));
 253
 254          begin
 255             --  If result is to be used as a Condition in the syntax, no need
 256             --  to convert it back, since if it was changed to Standard.Boolean
 257             --  using Adjust_Condition, that is just fine for this usage.
 258
 259             if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
 260                return;
 261
 262             --  If result is an operand of another logical operation, no need
 263             --  to reset its type, since Standard.Boolean is just fine, and
 264             --  such operations always do Adjust_Condition on their operands.
 265
 266             elsif     KP in N_Op_Boolean
 267               or else KP in N_Short_Circuit
 268               or else KP = N_Op_Not
 269             then
 270                return;
 271
 272             --  Otherwise we perform a conversion from the current type, which
 273             --  must be Standard.Boolean, to the desired type.
 274
 275             else
 276                Set_Analyzed (N);
 277                Rewrite (N, Convert_To (T, N));
 278                Analyze_And_Resolve (N, T);
 279             end if;
 280          end;
 281       end if;
 282    end Adjust_Result_Type;
 283
 284    --------------------------
 285    -- Append_Freeze_Action --
 286    --------------------------
 287
 288    procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
 289       Fnode : Node_Id;
 290
 291    begin
 292       Ensure_Freeze_Node (T);
 293       Fnode := Freeze_Node (T);
 294
 295       if No (Actions (Fnode)) then
 296          Set_Actions (Fnode, New_List);
 297       end if;
 298
 299       Append (N, Actions (Fnode));
 300    end Append_Freeze_Action;
 301
 302    ---------------------------
 303    -- Append_Freeze_Actions --
 304    ---------------------------
 305
 306    procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
 307       Fnode : constant Node_Id := Freeze_Node (T);
 308
 309    begin
 310       if No (L) then
 311          return;
 312
 313       else
 314          if No (Actions (Fnode)) then
 315             Set_Actions (Fnode, L);
 316          else
 317             Append_List (L, Actions (Fnode));
 318          end if;
 319       end if;
 320    end Append_Freeze_Actions;
 321
 322    ------------------------------------
 323    -- Build_Allocate_Deallocate_Proc --
 324    ------------------------------------
 325
 326    procedure Build_Allocate_Deallocate_Proc
 327      (N           : Node_Id;
 328       Is_Allocate : Boolean)
 329    is
 330       Desig_Typ    : Entity_Id;
 331       Expr         : Node_Id;
 332       Pool_Id      : Entity_Id;
 333       Proc_To_Call : Node_Id := Empty;
 334       Ptr_Typ      : Entity_Id;
 335
 336       function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
 337       --  Locate TSS primitive Finalize_Address in type Typ
 338
 339       function Find_Object (E : Node_Id) return Node_Id;
 340       --  Given an arbitrary expression of an allocator, try to find an object
 341       --  reference in it, otherwise return the original expression.
 342
 343       function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
 344       --  Determine whether subprogram Subp denotes a custom allocate or
 345       --  deallocate.
 346
 347       ---------------------------
 348       -- Find_Finalize_Address --
 349       ---------------------------
 350
 351       function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
 352          Utyp : Entity_Id := Typ;
 353
 354       begin
 355          --  Handle protected class-wide or task class-wide types
 356
 357          if Is_Class_Wide_Type (Utyp) then
 358             if Is_Concurrent_Type (Root_Type (Utyp)) then
 359                Utyp := Root_Type (Utyp);
 360
 361             elsif Is_Private_Type (Root_Type (Utyp))
 362               and then Present (Full_View (Root_Type (Utyp)))
 363               and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
 364             then
 365                Utyp := Full_View (Root_Type (Utyp));
 366             end if;
 367          end if;
 368
 369          --  Handle private types
 370
 371          if Is_Private_Type (Utyp)
 372            and then Present (Full_View (Utyp))
 373          then
 374             Utyp := Full_View (Utyp);
 375          end if;
 376
 377          --  Handle protected and task types
 378
 379          if Is_Concurrent_Type (Utyp)
 380            and then Present (Corresponding_Record_Type (Utyp))
 381          then
 382             Utyp := Corresponding_Record_Type (Utyp);
 383          end if;
 384
 385          Utyp := Underlying_Type (Base_Type (Utyp));
 386
 387          --  Deal with non-tagged derivation of private views. If the parent is
 388          --  now known to be protected, the finalization routine is the one
 389          --  defined on the corresponding record of the ancestor (corresponding
 390          --  records do not automatically inherit operations, but maybe they
 391          --  should???)
 392
 393          if Is_Untagged_Derivation (Typ) then
 394             if Is_Protected_Type (Typ) then
 395                Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
 396             else
 397                Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
 398
 399                if Is_Protected_Type (Utyp) then
 400                   Utyp := Corresponding_Record_Type (Utyp);
 401                end if;
 402             end if;
 403          end if;
 404
 405          --  If the underlying_type is a subtype, we are dealing with the
 406          --  completion of a private type. We need to access the base type and
 407          --  generate a conversion to it.
 408
 409          if Utyp /= Base_Type (Utyp) then
 410             pragma Assert (Is_Private_Type (Typ));
 411
 412             Utyp := Base_Type (Utyp);
 413          end if;
 414
 415          return TSS (Utyp, TSS_Finalize_Address);
 416       end Find_Finalize_Address;
 417
 418       -----------------
 419       -- Find_Object --
 420       -----------------
 421
 422       function Find_Object (E : Node_Id) return Node_Id is
 423          Expr : Node_Id;
 424
 425       begin
 426          pragma Assert (Is_Allocate);
 427
 428          Expr := E;
 429          loop
 430             if Nkind_In (Expr, N_Qualified_Expression,
 431                                N_Unchecked_Type_Conversion)
 432             then
 433                Expr := Expression (Expr);
 434
 435             elsif Nkind (Expr) = N_Explicit_Dereference then
 436                Expr := Prefix (Expr);
 437
 438             else
 439                exit;
 440             end if;
 441          end loop;
 442
 443          return Expr;
 444       end Find_Object;
 445
 446       ---------------------------------
 447       -- Is_Allocate_Deallocate_Proc --
 448       ---------------------------------
 449
 450       function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
 451       begin
 452          --  Look for a subprogram body with only one statement which is a
 453          --  call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
 454
 455          if Ekind (Subp) = E_Procedure
 456            and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
 457          then
 458             declare
 459                HSS  : constant Node_Id :=
 460                         Handled_Statement_Sequence (Parent (Parent (Subp)));
 461                Proc : Entity_Id;
 462
 463             begin
 464                if Present (Statements (HSS))
 465                  and then Nkind (First (Statements (HSS))) =
 466                             N_Procedure_Call_Statement
 467                then
 468                   Proc := Entity (Name (First (Statements (HSS))));
 469
 470                   return
 471                     Is_RTE (Proc, RE_Allocate_Any_Controlled)
 472                       or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
 473                end if;
 474             end;
 475          end if;
 476
 477          return False;
 478       end Is_Allocate_Deallocate_Proc;
 479
 480    --  Start of processing for Build_Allocate_Deallocate_Proc
 481
 482    begin
 483       --  Do not perform this expansion in Alfa mode because it is not
 484       --  necessary.
 485
 486       if Alfa_Mode then
 487          return;
 488       end if;
 489
 490       --  Obtain the attributes of the allocation / deallocation
 491
 492       if Nkind (N) = N_Free_Statement then
 493          Expr := Expression (N);
 494          Ptr_Typ := Base_Type (Etype (Expr));
 495          Proc_To_Call := Procedure_To_Call (N);
 496
 497       else
 498          if Nkind (N) = N_Object_Declaration then
 499             Expr := Expression (N);
 500          else
 501             Expr := N;
 502          end if;
 503
 504          --  In certain cases an allocator with a qualified expression may
 505          --  be relocated and used as the initialization expression of a
 506          --  temporary:
 507
 508          --    before:
 509          --       Obj : Ptr_Typ := new Desig_Typ'(...);
 510
 511          --    after:
 512          --       Tmp : Ptr_Typ := new Desig_Typ'(...);
 513          --       Obj : Ptr_Typ := Tmp;
 514
 515          --  Since the allocator is always marked as analyzed to avoid infinite
 516          --  expansion, it will never be processed by this routine given that
 517          --  the designated type needs finalization actions. Detect this case
 518          --  and complete the expansion of the allocator.
 519
 520          if Nkind (Expr) = N_Identifier
 521            and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
 522            and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
 523          then
 524             Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
 525             return;
 526          end if;
 527
 528          --  The allocator may have been rewritten into something else in which
 529          --  case the expansion performed by this routine does not apply.
 530
 531          if Nkind (Expr) /= N_Allocator then
 532             return;
 533          end if;
 534
 535          Ptr_Typ := Base_Type (Etype (Expr));
 536          Proc_To_Call := Procedure_To_Call (Expr);
 537       end if;
 538
 539       Pool_Id := Associated_Storage_Pool (Ptr_Typ);
 540       Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
 541
 542       --  Handle concurrent types
 543
 544       if Is_Concurrent_Type (Desig_Typ)
 545         and then Present (Corresponding_Record_Type (Desig_Typ))
 546       then
 547          Desig_Typ := Corresponding_Record_Type (Desig_Typ);
 548       end if;
 549
 550       --  Do not process allocations / deallocations without a pool
 551
 552       if No (Pool_Id) then
 553          return;
 554
 555       --  Do not process allocations on / deallocations from the secondary
 556       --  stack.
 557
 558       elsif Is_RTE (Pool_Id, RE_SS_Pool) then
 559          return;
 560
 561       --  Do not replicate the machinery if the allocator / free has already
 562       --  been expanded and has a custom Allocate / Deallocate.
 563
 564       elsif Present (Proc_To_Call)
 565         and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
 566       then
 567          return;
 568       end if;
 569
 570       if Needs_Finalization (Desig_Typ) then
 571
 572          --  Certain run-time configurations and targets do not provide support
 573          --  for controlled types.
 574
 575          if Restriction_Active (No_Finalization) then
 576             return;
 577
 578          --  Do nothing if the access type may never allocate / deallocate
 579          --  objects.
 580
 581          elsif No_Pool_Assigned (Ptr_Typ) then
 582             return;
 583
 584          --  Access-to-controlled types are not supported on .NET/JVM since
 585          --  these targets cannot support pools and address arithmetic.
 586
 587          elsif VM_Target /= No_VM then
 588             return;
 589          end if;
 590
 591          --  The allocation / deallocation of a controlled object must be
 592          --  chained on / detached from a finalization master.
 593
 594          pragma Assert (Present (Finalization_Master (Ptr_Typ)));
 595
 596       --  The only other kind of allocation / deallocation supported by this
 597       --  routine is on / from a subpool.
 598
 599       elsif Nkind (Expr) = N_Allocator
 600         and then No (Subpool_Handle_Name (Expr))
 601       then
 602          return;
 603       end if;
 604
 605       declare
 606          Loc     : constant Source_Ptr := Sloc (N);
 607          Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
 608          Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
 609          Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
 610          Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
 611
 612          Actuals      : List_Id;
 613          Fin_Addr_Id  : Entity_Id;
 614          Fin_Mas_Act  : Node_Id;
 615          Fin_Mas_Id   : Entity_Id;
 616          Proc_To_Call : Entity_Id;
 617          Subpool      : Node_Id := Empty;
 618
 619       begin
 620          --  Step 1: Construct all the actuals for the call to library routine
 621          --  Allocate_Any_Controlled / Deallocate_Any_Controlled.
 622
 623          --  a) Storage pool
 624
 625          Actuals := New_List (New_Reference_To (Pool_Id, Loc));
 626
 627          if Is_Allocate then
 628
 629             --  b) Subpool
 630
 631             if Nkind (Expr) = N_Allocator then
 632                Subpool := Subpool_Handle_Name (Expr);
 633             end if;
 634
 635             if Present (Subpool) then
 636                Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
 637             else
 638                Append_To (Actuals, Make_Null (Loc));
 639             end if;
 640
 641             --  c) Finalization master
 642
 643             if Needs_Finalization (Desig_Typ) then
 644                Fin_Mas_Id  := Finalization_Master (Ptr_Typ);
 645                Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
 646
 647                --  Handle the case where the master is actually a pointer to a
 648                --  master. This case arises in build-in-place functions.
 649
 650                if Is_Access_Type (Etype (Fin_Mas_Id)) then
 651                   Append_To (Actuals, Fin_Mas_Act);
 652                else
 653                   Append_To (Actuals,
 654                     Make_Attribute_Reference (Loc,
 655                       Prefix         => Fin_Mas_Act,
 656                       Attribute_Name => Name_Unrestricted_Access));
 657                end if;
 658             else
 659                Append_To (Actuals, Make_Null (Loc));
 660             end if;
 661
 662             --  d) Finalize_Address
 663
 664             --  Primitive Finalize_Address is never generated in CodePeer mode
 665             --  since it contains an Unchecked_Conversion.
 666
 667             if Needs_Finalization (Desig_Typ)
 668               and then not CodePeer_Mode
 669             then
 670                Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
 671                pragma Assert (Present (Fin_Addr_Id));
 672
 673                Append_To (Actuals,
 674                  Make_Attribute_Reference (Loc,
 675                    Prefix         => New_Reference_To (Fin_Addr_Id, Loc),
 676                    Attribute_Name => Name_Unrestricted_Access));
 677             else
 678                Append_To (Actuals, Make_Null (Loc));
 679             end if;
 680          end if;
 681
 682          --  e) Address
 683          --  f) Storage_Size
 684          --  g) Alignment
 685
 686          Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
 687          Append_To (Actuals, New_Reference_To (Size_Id, Loc));
 688          Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
 689
 690          --  h) Is_Controlled
 691
 692          --  Generate a run-time check to determine whether a class-wide object
 693          --  is truly controlled.
 694
 695          if Needs_Finalization (Desig_Typ) then
 696             if Is_Class_Wide_Type (Desig_Typ)
 697               or else Is_Generic_Actual_Type (Desig_Typ)
 698             then
 699                declare
 700                   Flag_Id   : constant Entity_Id := Make_Temporary (Loc, 'F');
 701                   Flag_Expr : Node_Id;
 702                   Param     : Node_Id;
 703                   Temp      : Node_Id;
 704
 705                begin
 706                   if Is_Allocate then
 707                      Temp := Find_Object (Expression (Expr));
 708                   else
 709                      Temp := Expr;
 710                   end if;
 711
 712                   --  Processing for generic actuals
 713
 714                   if Is_Generic_Actual_Type (Desig_Typ) then
 715                      Flag_Expr :=
 716                        New_Reference_To (Boolean_Literals
 717                          (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
 718
 719                   --  Processing for subtype indications
 720
 721                   elsif Nkind (Temp) in N_Has_Entity
 722                     and then Is_Type (Entity (Temp))
 723                   then
 724                      Flag_Expr :=
 725                        New_Reference_To (Boolean_Literals
 726                          (Needs_Finalization (Entity (Temp))), Loc);
 727
 728                   --  Generate a runtime check to test the controlled state of
 729                   --  an object for the purposes of allocation / deallocation.
 730
 731                   else
 732                      --  The following case arises when allocating through an
 733                      --  interface class-wide type, generate:
 734                      --
 735                      --    Temp.all
 736
 737                      if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
 738                         Param :=
 739                           Make_Explicit_Dereference (Loc,
 740                             Prefix =>
 741                               Relocate_Node (Temp));
 742
 743                      --  Generate:
 744                      --    Temp'Tag
 745
 746                      else
 747                         Param :=
 748                           Make_Attribute_Reference (Loc,
 749                             Prefix =>
 750                               Relocate_Node (Temp),
 751                             Attribute_Name => Name_Tag);
 752                      end if;
 753
 754                      --  Generate:
 755                      --    Needs_Finalization (<Param>)
 756
 757                      Flag_Expr :=
 758                        Make_Function_Call (Loc,
 759                          Name =>
 760                            New_Reference_To (RTE (RE_Needs_Finalization), Loc),
 761                          Parameter_Associations => New_List (Param));
 762                   end if;
 763
 764                   --  Create the temporary which represents the finalization
 765                   --  state of the expression. Generate:
 766                   --
 767                   --    F : constant Boolean := <Flag_Expr>;
 768
 769                   Insert_Action (N,
 770                     Make_Object_Declaration (Loc,
 771                       Defining_Identifier => Flag_Id,
 772                       Constant_Present => True,
 773                       Object_Definition =>
 774                         New_Reference_To (Standard_Boolean, Loc),
 775                       Expression => Flag_Expr));
 776
 777                   --  The flag acts as the last actual
 778
 779                   Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
 780                end;
 781
 782             --  The object is statically known to be controlled
 783
 784             else
 785                Append_To (Actuals, New_Reference_To (Standard_True, Loc));
 786             end if;
 787          else
 788             Append_To (Actuals, New_Reference_To (Standard_False, Loc));
 789          end if;
 790
 791          --  i) On_Subpool
 792
 793          if Is_Allocate then
 794             Append_To (Actuals,
 795               New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
 796          end if;
 797
 798          --  Step 2: Build a wrapper Allocate / Deallocate which internally
 799          --  calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
 800
 801          --  Select the proper routine to call
 802
 803          if Is_Allocate then
 804             Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
 805          else
 806             Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
 807          end if;
 808
 809          --  Create a custom Allocate / Deallocate routine which has identical
 810          --  profile to that of System.Storage_Pools.
 811
 812          Insert_Action (N,
 813            Make_Subprogram_Body (Loc,
 814              Specification =>
 815
 816                --  procedure Pnn
 817
 818                Make_Procedure_Specification (Loc,
 819                  Defining_Unit_Name => Proc_Id,
 820                  Parameter_Specifications => New_List (
 821
 822                   --  P : Root_Storage_Pool
 823
 824                    Make_Parameter_Specification (Loc,
 825                      Defining_Identifier =>
 826                        Make_Temporary (Loc, 'P'),
 827                      Parameter_Type =>
 828                        New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),
 829
 830                   --  A : [out] Address
 831
 832                    Make_Parameter_Specification (Loc,
 833                      Defining_Identifier => Addr_Id,
 834                      Out_Present => Is_Allocate,
 835                      Parameter_Type =>
 836                        New_Reference_To (RTE (RE_Address), Loc)),
 837
 838                   --  S : Storage_Count
 839
 840                    Make_Parameter_Specification (Loc,
 841                      Defining_Identifier => Size_Id,
 842                      Parameter_Type =>
 843                        New_Reference_To (RTE (RE_Storage_Count), Loc)),
 844
 845                   --  L : Storage_Count
 846
 847                    Make_Parameter_Specification (Loc,
 848                      Defining_Identifier => Alig_Id,
 849                      Parameter_Type =>
 850                        New_Reference_To (RTE (RE_Storage_Count), Loc)))),
 851
 852              Declarations => No_List,
 853
 854              Handled_Statement_Sequence =>
 855                Make_Handled_Sequence_Of_Statements (Loc,
 856                  Statements => New_List (
 857                    Make_Procedure_Call_Statement (Loc,
 858                      Name =>
 859                        New_Reference_To (Proc_To_Call, Loc),
 860                      Parameter_Associations => Actuals)))));
 861
 862          --  The newly generated Allocate / Deallocate becomes the default
 863          --  procedure to call when the back end processes the allocation /
 864          --  deallocation.
 865
 866          if Is_Allocate then
 867             Set_Procedure_To_Call (Expr, Proc_Id);
 868          else
 869             Set_Procedure_To_Call (N, Proc_Id);
 870          end if;
 871       end;
 872    end Build_Allocate_Deallocate_Proc;
 873
 874    ------------------------
 875    -- Build_Runtime_Call --
 876    ------------------------
 877
 878    function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
 879    begin
 880       --  If entity is not available, we can skip making the call (this avoids
 881       --  junk duplicated error messages in a number of cases).
 882
 883       if not RTE_Available (RE) then
 884          return Make_Null_Statement (Loc);
 885       else
 886          return
 887            Make_Procedure_Call_Statement (Loc,
 888              Name => New_Reference_To (RTE (RE), Loc));
 889       end if;
 890    end Build_Runtime_Call;
 891
 892    ----------------------------
 893    -- Build_Task_Array_Image --
 894    ----------------------------
 895
 896    --  This function generates the body for a function that constructs the
 897    --  image string for a task that is an array component. The function is
 898    --  local to the init proc for the array type, and is called for each one
 899    --  of the components. The constructed image has the form of an indexed
 900    --  component, whose prefix is the outer variable of the array type.
 901    --  The n-dimensional array type has known indexes Index, Index2...
 902
 903    --  Id_Ref is an indexed component form created by the enclosing init proc.
 904    --  Its successive indexes are Val1, Val2, ... which are the loop variables
 905    --  in the loops that call the individual task init proc on each component.
 906
 907    --  The generated function has the following structure:
 908
 909    --  function F return String is
 910    --     Pref : string renames Task_Name;
 911    --     T1   : String := Index1'Image (Val1);
 912    --     ...
 913    --     Tn   : String := indexn'image (Valn);
 914    --     Len  : Integer := T1'Length + ... + Tn'Length + n + 1;
 915    --     --  Len includes commas and the end parentheses.
 916    --     Res  : String (1..Len);
 917    --     Pos  : Integer := Pref'Length;
 918    --
 919    --  begin
 920    --     Res (1 .. Pos) := Pref;
 921    --     Pos := Pos + 1;
 922    --     Res (Pos)    := '(';
 923    --     Pos := Pos + 1;
 924    --     Res (Pos .. Pos + T1'Length - 1) := T1;
 925    --     Pos := Pos + T1'Length;
 926    --     Res (Pos) := '.';
 927    --     Pos := Pos + 1;
 928    --     ...
 929    --     Res (Pos .. Pos + Tn'Length - 1) := Tn;
 930    --     Res (Len) := ')';
 931    --
 932    --     return Res;
 933    --  end F;
 934    --
 935    --  Needless to say, multidimensional arrays of tasks are rare enough that
 936    --  the bulkiness of this code is not really a concern.
 937
 938    function Build_Task_Array_Image
 939      (Loc    : Source_Ptr;
 940       Id_Ref : Node_Id;
 941       A_Type : Entity_Id;
 942       Dyn    : Boolean := False) return Node_Id
 943    is
 944       Dims : constant Nat := Number_Dimensions (A_Type);
 945       --  Number of dimensions for array of tasks
 946
 947       Temps : array (1 .. Dims) of Entity_Id;
 948       --  Array of temporaries to hold string for each index
 949
 950       Indx : Node_Id;
 951       --  Index expression
 952
 953       Len : Entity_Id;
 954       --  Total length of generated name
 955
 956       Pos : Entity_Id;
 957       --  Running index for substring assignments
 958
 959       Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
 960       --  Name of enclosing variable, prefix of resulting name
 961
 962       Res : Entity_Id;
 963       --  String to hold result
 964
 965       Val : Node_Id;
 966       --  Value of successive indexes
 967
 968       Sum : Node_Id;
 969       --  Expression to compute total size of string
 970
 971       T : Entity_Id;
 972       --  Entity for name at one index position
 973
 974       Decls : constant List_Id := New_List;
 975       Stats : constant List_Id := New_List;
 976
 977    begin
 978       --  For a dynamic task, the name comes from the target variable. For a
 979       --  static one it is a formal of the enclosing init proc.
 980
 981       if Dyn then
 982          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
 983          Append_To (Decls,
 984            Make_Object_Declaration (Loc,
 985              Defining_Identifier => Pref,
 986              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 987              Expression =>
 988                Make_String_Literal (Loc,
 989                  Strval => String_From_Name_Buffer)));
 990
 991       else
 992          Append_To (Decls,
 993            Make_Object_Renaming_Declaration (Loc,
 994              Defining_Identifier => Pref,
 995              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
 996              Name                => Make_Identifier (Loc, Name_uTask_Name)));
 997       end if;
 998
 999       Indx := First_Index (A_Type);
1000       Val  := First (Expressions (Id_Ref));
1001
1002       for J in 1 .. Dims loop
1003          T := Make_Temporary (Loc, 'T');
1004          Temps (J) := T;
1005
1006          Append_To (Decls,
1007             Make_Object_Declaration (Loc,
1008                Defining_Identifier => T,
1009                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1010                Expression =>
1011                  Make_Attribute_Reference (Loc,
1012                    Attribute_Name => Name_Image,
1013                    Prefix         => New_Occurrence_Of (Etype (Indx), Loc),
1014                    Expressions    => New_List (New_Copy_Tree (Val)))));
1015
1016          Next_Index (Indx);
1017          Next (Val);
1018       end loop;
1019
1020       Sum := Make_Integer_Literal (Loc, Dims + 1);
1021
1022       Sum :=
1023         Make_Op_Add (Loc,
1024           Left_Opnd => Sum,
1025           Right_Opnd =>
1026            Make_Attribute_Reference (Loc,
1027              Attribute_Name => Name_Length,
1028              Prefix =>
1029                New_Occurrence_Of (Pref, Loc),
1030              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1031
1032       for J in 1 .. Dims loop
1033          Sum :=
1034             Make_Op_Add (Loc,
1035              Left_Opnd => Sum,
1036              Right_Opnd =>
1037               Make_Attribute_Reference (Loc,
1038                 Attribute_Name => Name_Length,
1039                 Prefix =>
1040                   New_Occurrence_Of (Temps (J), Loc),
1041                 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1042       end loop;
1043
1044       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1045
1046       Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
1047
1048       Append_To (Stats,
1049          Make_Assignment_Statement (Loc,
1050            Name => Make_Indexed_Component (Loc,
1051               Prefix => New_Occurrence_Of (Res, Loc),
1052               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1053            Expression =>
1054              Make_Character_Literal (Loc,
1055                Chars => Name_Find,
1056                Char_Literal_Value =>
1057                  UI_From_Int (Character'Pos ('(')))));
1058
1059       Append_To (Stats,
1060          Make_Assignment_Statement (Loc,
1061             Name => New_Occurrence_Of (Pos, Loc),
1062             Expression =>
1063               Make_Op_Add (Loc,
1064                 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1065                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1066
1067       for J in 1 .. Dims loop
1068
1069          Append_To (Stats,
1070             Make_Assignment_Statement (Loc,
1071               Name => Make_Slice (Loc,
1072                  Prefix => New_Occurrence_Of (Res, Loc),
1073                  Discrete_Range  =>
1074                    Make_Range (Loc,
1075                       Low_Bound => New_Occurrence_Of  (Pos, Loc),
1076                       High_Bound => Make_Op_Subtract (Loc,
1077                         Left_Opnd =>
1078                           Make_Op_Add (Loc,
1079                             Left_Opnd => New_Occurrence_Of (Pos, Loc),
1080                             Right_Opnd =>
1081                               Make_Attribute_Reference (Loc,
1082                                 Attribute_Name => Name_Length,
1083                                 Prefix =>
1084                                   New_Occurrence_Of (Temps (J), Loc),
1085                                 Expressions =>
1086                                   New_List (Make_Integer_Literal (Loc, 1)))),
1087                          Right_Opnd => Make_Integer_Literal (Loc, 1)))),
1088
1089               Expression => New_Occurrence_Of (Temps (J), Loc)));
1090
1091          if J < Dims then
1092             Append_To (Stats,
1093                Make_Assignment_Statement (Loc,
1094                   Name => New_Occurrence_Of (Pos, Loc),
1095                   Expression =>
1096                     Make_Op_Add (Loc,
1097                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
1098                       Right_Opnd =>
1099                         Make_Attribute_Reference (Loc,
1100                           Attribute_Name => Name_Length,
1101                             Prefix => New_Occurrence_Of (Temps (J), Loc),
1102                             Expressions =>
1103                               New_List (Make_Integer_Literal (Loc, 1))))));
1104
1105             Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
1106
1107             Append_To (Stats,
1108                Make_Assignment_Statement (Loc,
1109                  Name => Make_Indexed_Component (Loc,
1110                     Prefix => New_Occurrence_Of (Res, Loc),
1111                     Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1112                  Expression =>
1113                    Make_Character_Literal (Loc,
1114                      Chars => Name_Find,
1115                      Char_Literal_Value =>
1116                        UI_From_Int (Character'Pos (',')))));
1117
1118             Append_To (Stats,
1119               Make_Assignment_Statement (Loc,
1120                 Name => New_Occurrence_Of (Pos, Loc),
1121                   Expression =>
1122                     Make_Op_Add (Loc,
1123                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
1124                       Right_Opnd => Make_Integer_Literal (Loc, 1))));
1125          end if;
1126       end loop;
1127
1128       Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
1129
1130       Append_To (Stats,
1131          Make_Assignment_Statement (Loc,
1132            Name => Make_Indexed_Component (Loc,
1133               Prefix => New_Occurrence_Of (Res, Loc),
1134               Expressions => New_List (New_Occurrence_Of (Len, Loc))),
1135            Expression =>
1136              Make_Character_Literal (Loc,
1137                Chars => Name_Find,
1138                Char_Literal_Value =>
1139                  UI_From_Int (Character'Pos (')')))));
1140       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1141    end Build_Task_Array_Image;
1142
1143    ----------------------------
1144    -- Build_Task_Image_Decls --
1145    ----------------------------
1146
1147    function Build_Task_Image_Decls
1148      (Loc          : Source_Ptr;
1149       Id_Ref       : Node_Id;
1150       A_Type       : Entity_Id;
1151       In_Init_Proc : Boolean := False) return List_Id
1152    is
1153       Decls  : constant List_Id   := New_List;
1154       T_Id   : Entity_Id := Empty;
1155       Decl   : Node_Id;
1156       Expr   : Node_Id   := Empty;
1157       Fun    : Node_Id   := Empty;
1158       Is_Dyn : constant Boolean :=
1159                  Nkind (Parent (Id_Ref)) = N_Assignment_Statement
1160                    and then
1161                  Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
1162
1163    begin
1164       --  If Discard_Names or No_Implicit_Heap_Allocations are in effect,
1165       --  generate a dummy declaration only.
1166
1167       if Restriction_Active (No_Implicit_Heap_Allocations)
1168         or else Global_Discard_Names
1169       then
1170          T_Id := Make_Temporary (Loc, 'J');
1171          Name_Len := 0;
1172
1173          return
1174            New_List (
1175              Make_Object_Declaration (Loc,
1176                Defining_Identifier => T_Id,
1177                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1178                Expression =>
1179                  Make_String_Literal (Loc,
1180                    Strval => String_From_Name_Buffer)));
1181
1182       else
1183          if Nkind (Id_Ref) = N_Identifier
1184            or else Nkind (Id_Ref) = N_Defining_Identifier
1185          then
1186             --  For a simple variable, the image of the task is built from
1187             --  the name of the variable. To avoid possible conflict with the
1188             --  anonymous type created for a single protected object, add a
1189             --  numeric suffix.
1190
1191             T_Id :=
1192               Make_Defining_Identifier (Loc,
1193                 New_External_Name (Chars (Id_Ref), 'T', 1));
1194
1195             Get_Name_String (Chars (Id_Ref));
1196
1197             Expr :=
1198               Make_String_Literal (Loc,
1199                 Strval => String_From_Name_Buffer);
1200
1201          elsif Nkind (Id_Ref) = N_Selected_Component then
1202             T_Id :=
1203               Make_Defining_Identifier (Loc,
1204                 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
1205             Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
1206
1207          elsif Nkind (Id_Ref) = N_Indexed_Component then
1208             T_Id :=
1209               Make_Defining_Identifier (Loc,
1210                 New_External_Name (Chars (A_Type), 'N'));
1211
1212             Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
1213          end if;
1214       end if;
1215
1216       if Present (Fun) then
1217          Append (Fun, Decls);
1218          Expr := Make_Function_Call (Loc,
1219            Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
1220
1221          if not In_Init_Proc and then VM_Target = No_VM then
1222             Set_Uses_Sec_Stack (Defining_Entity (Fun));
1223          end if;
1224       end if;
1225
1226       Decl := Make_Object_Declaration (Loc,
1227         Defining_Identifier => T_Id,
1228         Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
1229         Constant_Present    => True,
1230         Expression          => Expr);
1231
1232       Append (Decl, Decls);
1233       return Decls;
1234    end Build_Task_Image_Decls;
1235
1236    -------------------------------
1237    -- Build_Task_Image_Function --
1238    -------------------------------
1239
1240    function Build_Task_Image_Function
1241      (Loc   : Source_Ptr;
1242       Decls : List_Id;
1243       Stats : List_Id;
1244       Res   : Entity_Id) return Node_Id
1245    is
1246       Spec : Node_Id;
1247
1248    begin
1249       Append_To (Stats,
1250         Make_Simple_Return_Statement (Loc,
1251           Expression => New_Occurrence_Of (Res, Loc)));
1252
1253       Spec := Make_Function_Specification (Loc,
1254         Defining_Unit_Name => Make_Temporary (Loc, 'F'),
1255         Result_Definition  => New_Occurrence_Of (Standard_String, Loc));
1256
1257       --  Calls to 'Image use the secondary stack, which must be cleaned up
1258       --  after the task name is built.
1259
1260       return Make_Subprogram_Body (Loc,
1261          Specification => Spec,
1262          Declarations => Decls,
1263          Handled_Statement_Sequence =>
1264            Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
1265    end Build_Task_Image_Function;
1266
1267    -----------------------------
1268    -- Build_Task_Image_Prefix --
1269    -----------------------------
1270
1271    procedure Build_Task_Image_Prefix
1272       (Loc    : Source_Ptr;
1273        Len    : out Entity_Id;
1274        Res    : out Entity_Id;
1275        Pos    : out Entity_Id;
1276        Prefix : Entity_Id;
1277        Sum    : Node_Id;
1278        Decls  : List_Id;
1279        Stats  : List_Id)
1280    is
1281    begin
1282       Len := Make_Temporary (Loc, 'L', Sum);
1283
1284       Append_To (Decls,
1285         Make_Object_Declaration (Loc,
1286           Defining_Identifier => Len,
1287           Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),
1288           Expression          => Sum));
1289
1290       Res := Make_Temporary (Loc, 'R');
1291
1292       Append_To (Decls,
1293          Make_Object_Declaration (Loc,
1294             Defining_Identifier => Res,
1295             Object_Definition =>
1296                Make_Subtype_Indication (Loc,
1297                   Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1298                Constraint =>
1299                  Make_Index_Or_Discriminant_Constraint (Loc,
1300                    Constraints =>
1301                      New_List (
1302                        Make_Range (Loc,
1303                          Low_Bound => Make_Integer_Literal (Loc, 1),
1304                          High_Bound => New_Occurrence_Of (Len, Loc)))))));
1305
1306       Pos := Make_Temporary (Loc, 'P');
1307
1308       Append_To (Decls,
1309          Make_Object_Declaration (Loc,
1310             Defining_Identifier => Pos,
1311             Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc)));
1312
1313       --  Pos := Prefix'Length;
1314
1315       Append_To (Stats,
1316          Make_Assignment_Statement (Loc,
1317             Name => New_Occurrence_Of (Pos, Loc),
1318             Expression =>
1319               Make_Attribute_Reference (Loc,
1320                 Attribute_Name => Name_Length,
1321                 Prefix         => New_Occurrence_Of (Prefix, Loc),
1322                 Expressions    => New_List (Make_Integer_Literal (Loc, 1)))));
1323
1324       --  Res (1 .. Pos) := Prefix;
1325
1326       Append_To (Stats,
1327         Make_Assignment_Statement (Loc,
1328           Name =>
1329             Make_Slice (Loc,
1330               Prefix          => New_Occurrence_Of (Res, Loc),
1331               Discrete_Range  =>
1332                 Make_Range (Loc,
1333                    Low_Bound  => Make_Integer_Literal (Loc, 1),
1334                    High_Bound => New_Occurrence_Of (Pos, Loc))),
1335
1336           Expression => New_Occurrence_Of (Prefix, Loc)));
1337
1338       Append_To (Stats,
1339          Make_Assignment_Statement (Loc,
1340             Name       => New_Occurrence_Of (Pos, Loc),
1341             Expression =>
1342               Make_Op_Add (Loc,
1343                 Left_Opnd  => New_Occurrence_Of (Pos, Loc),
1344                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1345    end Build_Task_Image_Prefix;
1346
1347    -----------------------------
1348    -- Build_Task_Record_Image --
1349    -----------------------------
1350
1351    function Build_Task_Record_Image
1352      (Loc    : Source_Ptr;
1353       Id_Ref : Node_Id;
1354       Dyn    : Boolean := False) return Node_Id
1355    is
1356       Len : Entity_Id;
1357       --  Total length of generated name
1358
1359       Pos : Entity_Id;
1360       --  Index into result
1361
1362       Res : Entity_Id;
1363       --  String to hold result
1364
1365       Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1366       --  Name of enclosing variable, prefix of resulting name
1367
1368       Sum : Node_Id;
1369       --  Expression to compute total size of string
1370
1371       Sel : Entity_Id;
1372       --  Entity for selector name
1373
1374       Decls : constant List_Id := New_List;
1375       Stats : constant List_Id := New_List;
1376
1377    begin
1378       --  For a dynamic task, the name comes from the target variable. For a
1379       --  static one it is a formal of the enclosing init proc.
1380
1381       if Dyn then
1382          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1383          Append_To (Decls,
1384            Make_Object_Declaration (Loc,
1385              Defining_Identifier => Pref,
1386              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1387              Expression =>
1388                Make_String_Literal (Loc,
1389                  Strval => String_From_Name_Buffer)));
1390
1391       else
1392          Append_To (Decls,
1393            Make_Object_Renaming_Declaration (Loc,
1394              Defining_Identifier => Pref,
1395              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
1396              Name                => Make_Identifier (Loc, Name_uTask_Name)));
1397       end if;
1398
1399       Sel := Make_Temporary (Loc, 'S');
1400
1401       Get_Name_String (Chars (Selector_Name (Id_Ref)));
1402
1403       Append_To (Decls,
1404          Make_Object_Declaration (Loc,
1405            Defining_Identifier => Sel,
1406            Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
1407            Expression          =>
1408              Make_String_Literal (Loc,
1409                Strval => String_From_Name_Buffer)));
1410
1411       Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
1412
1413       Sum :=
1414         Make_Op_Add (Loc,
1415           Left_Opnd => Sum,
1416           Right_Opnd =>
1417            Make_Attribute_Reference (Loc,
1418              Attribute_Name => Name_Length,
1419              Prefix =>
1420                New_Occurrence_Of (Pref, Loc),
1421              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1422
1423       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1424
1425       Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
1426
1427       --  Res (Pos) := '.';
1428
1429       Append_To (Stats,
1430          Make_Assignment_Statement (Loc,
1431            Name => Make_Indexed_Component (Loc,
1432               Prefix => New_Occurrence_Of (Res, Loc),
1433               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1434            Expression =>
1435              Make_Character_Literal (Loc,
1436                Chars => Name_Find,
1437                Char_Literal_Value =>
1438                  UI_From_Int (Character'Pos ('.')))));
1439
1440       Append_To (Stats,
1441         Make_Assignment_Statement (Loc,
1442           Name => New_Occurrence_Of (Pos, Loc),
1443           Expression =>
1444             Make_Op_Add (Loc,
1445               Left_Opnd => New_Occurrence_Of (Pos, Loc),
1446               Right_Opnd => Make_Integer_Literal (Loc, 1))));
1447
1448       --  Res (Pos .. Len) := Selector;
1449
1450       Append_To (Stats,
1451         Make_Assignment_Statement (Loc,
1452           Name => Make_Slice (Loc,
1453              Prefix => New_Occurrence_Of (Res, Loc),
1454              Discrete_Range  =>
1455                Make_Range (Loc,
1456                  Low_Bound  => New_Occurrence_Of (Pos, Loc),
1457                  High_Bound => New_Occurrence_Of (Len, Loc))),
1458           Expression => New_Occurrence_Of (Sel, Loc)));
1459
1460       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1461    end Build_Task_Record_Image;
1462
1463    ----------------------------------
1464    -- Component_May_Be_Bit_Aligned --
1465    ----------------------------------
1466
1467    function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
1468       UT : Entity_Id;
1469
1470    begin
1471       --  If no component clause, then everything is fine, since the back end
1472       --  never bit-misaligns by default, even if there is a pragma Packed for
1473       --  the record.
1474
1475       if No (Comp) or else No (Component_Clause (Comp)) then
1476          return False;
1477       end if;
1478
1479       UT := Underlying_Type (Etype (Comp));
1480
1481       --  It is only array and record types that cause trouble
1482
1483       if not Is_Record_Type (UT)
1484         and then not Is_Array_Type (UT)
1485       then
1486          return False;
1487
1488       --  If we know that we have a small (64 bits or less) record or small
1489       --  bit-packed array, then everything is fine, since the back end can
1490       --  handle these cases correctly.
1491
1492       elsif Esize (Comp) <= 64
1493         and then (Is_Record_Type (UT)
1494                    or else Is_Bit_Packed_Array (UT))
1495       then
1496          return False;
1497
1498       --  Otherwise if the component is not byte aligned, we know we have the
1499       --  nasty unaligned case.
1500
1501       elsif Normalized_First_Bit (Comp) /= Uint_0
1502         or else Esize (Comp) mod System_Storage_Unit /= Uint_0
1503       then
1504          return True;
1505
1506       --  If we are large and byte aligned, then OK at this level
1507
1508       else
1509          return False;
1510       end if;
1511    end Component_May_Be_Bit_Aligned;
1512
1513    -----------------------------------
1514    -- Corresponding_Runtime_Package --
1515    -----------------------------------
1516
1517    function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
1518       Pkg_Id : RTU_Id := RTU_Null;
1519
1520    begin
1521       pragma Assert (Is_Concurrent_Type (Typ));
1522
1523       if Ekind (Typ) in Protected_Kind then
1524          if Has_Entries (Typ)
1525
1526             --  A protected type without entries that covers an interface and
1527             --  overrides the abstract routines with protected procedures is
1528             --  considered equivalent to a protected type with entries in the
1529             --  context of dispatching select statements. It is sufficient to
1530             --  check for the presence of an interface list in the declaration
1531             --  node to recognize this case.
1532
1533            or else Present (Interface_List (Parent (Typ)))
1534            or else
1535              (((Has_Attach_Handler (Typ) and then not Restricted_Profile)
1536                  or else Has_Interrupt_Handler (Typ))
1537                and then not Restriction_Active (No_Dynamic_Attachment))
1538          then
1539             if Abort_Allowed
1540               or else Restriction_Active (No_Entry_Queue) = False
1541               or else Number_Entries (Typ) > 1
1542               or else (Has_Attach_Handler (Typ)
1543                         and then not Restricted_Profile)
1544             then
1545                Pkg_Id := System_Tasking_Protected_Objects_Entries;
1546             else
1547                Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
1548             end if;
1549
1550          else
1551             Pkg_Id := System_Tasking_Protected_Objects;
1552          end if;
1553       end if;
1554
1555       return Pkg_Id;
1556    end Corresponding_Runtime_Package;
1557
1558    -------------------------------
1559    -- Convert_To_Actual_Subtype --
1560    -------------------------------
1561
1562    procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
1563       Act_ST : Entity_Id;
1564
1565    begin
1566       Act_ST := Get_Actual_Subtype (Exp);
1567
1568       if Act_ST = Etype (Exp) then
1569          return;
1570       else
1571          Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
1572          Analyze_And_Resolve (Exp, Act_ST);
1573       end if;
1574    end Convert_To_Actual_Subtype;
1575
1576    -----------------------------------
1577    -- Current_Sem_Unit_Declarations --
1578    -----------------------------------
1579
1580    function Current_Sem_Unit_Declarations return List_Id is
1581       U     : Node_Id := Unit (Cunit (Current_Sem_Unit));
1582       Decls : List_Id;
1583
1584    begin
1585       --  If the current unit is a package body, locate the visible
1586       --  declarations of the package spec.
1587
1588       if Nkind (U) = N_Package_Body then
1589          U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
1590       end if;
1591
1592       if Nkind (U) = N_Package_Declaration then
1593          U := Specification (U);
1594          Decls := Visible_Declarations (U);
1595
1596          if No (Decls) then
1597             Decls := New_List;
1598             Set_Visible_Declarations (U, Decls);
1599          end if;
1600
1601       else
1602          Decls := Declarations (U);
1603
1604          if No (Decls) then
1605             Decls := New_List;
1606             Set_Declarations (U, Decls);
1607          end if;
1608       end if;
1609
1610       return Decls;
1611    end Current_Sem_Unit_Declarations;
1612
1613    -----------------------
1614    -- Duplicate_Subexpr --
1615    -----------------------
1616
1617    function Duplicate_Subexpr
1618      (Exp      : Node_Id;
1619       Name_Req : Boolean := False) return Node_Id
1620    is
1621    begin
1622       Remove_Side_Effects (Exp, Name_Req);
1623       return New_Copy_Tree (Exp);
1624    end Duplicate_Subexpr;
1625
1626    ---------------------------------
1627    -- Duplicate_Subexpr_No_Checks --
1628    ---------------------------------
1629
1630    function Duplicate_Subexpr_No_Checks
1631      (Exp      : Node_Id;
1632       Name_Req : Boolean := False) return Node_Id
1633    is
1634       New_Exp : Node_Id;
1635
1636    begin
1637       Remove_Side_Effects (Exp, Name_Req);
1638       New_Exp := New_Copy_Tree (Exp);
1639       Remove_Checks (New_Exp);
1640       return New_Exp;
1641    end Duplicate_Subexpr_No_Checks;
1642
1643    -----------------------------------
1644    -- Duplicate_Subexpr_Move_Checks --
1645    -----------------------------------
1646
1647    function Duplicate_Subexpr_Move_Checks
1648      (Exp      : Node_Id;
1649       Name_Req : Boolean := False) return Node_Id
1650    is
1651       New_Exp : Node_Id;
1652    begin
1653       Remove_Side_Effects (Exp, Name_Req);
1654       New_Exp := New_Copy_Tree (Exp);
1655       Remove_Checks (Exp);
1656       return New_Exp;
1657    end Duplicate_Subexpr_Move_Checks;
1658
1659    --------------------
1660    -- Ensure_Defined --
1661    --------------------
1662
1663    procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1664       IR : Node_Id;
1665
1666    begin
1667       --  An itype reference must only be created if this is a local itype, so
1668       --  that gigi can elaborate it on the proper objstack.
1669
1670       if Is_Itype (Typ)
1671         and then Scope (Typ) = Current_Scope
1672       then
1673          IR := Make_Itype_Reference (Sloc (N));
1674          Set_Itype (IR, Typ);
1675          Insert_Action (N, IR);
1676       end if;
1677    end Ensure_Defined;
1678
1679    --------------------
1680    -- Entry_Names_OK --
1681    --------------------
1682
1683    function Entry_Names_OK return Boolean is
1684    begin
1685       return
1686         not Restricted_Profile
1687           and then not Global_Discard_Names
1688           and then not Restriction_Active (No_Implicit_Heap_Allocations)
1689           and then not Restriction_Active (No_Local_Allocators);
1690    end Entry_Names_OK;
1691
1692    ---------------------
1693    -- Evolve_And_Then --
1694    ---------------------
1695
1696    procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1697    begin
1698       if No (Cond) then
1699          Cond := Cond1;
1700       else
1701          Cond :=
1702            Make_And_Then (Sloc (Cond1),
1703              Left_Opnd  => Cond,
1704              Right_Opnd => Cond1);
1705       end if;
1706    end Evolve_And_Then;
1707
1708    --------------------
1709    -- Evolve_Or_Else --
1710    --------------------
1711
1712    procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1713    begin
1714       if No (Cond) then
1715          Cond := Cond1;
1716       else
1717          Cond :=
1718            Make_Or_Else (Sloc (Cond1),
1719              Left_Opnd  => Cond,
1720              Right_Opnd => Cond1);
1721       end if;
1722    end Evolve_Or_Else;
1723
1724    ------------------------------
1725    -- Expand_Subtype_From_Expr --
1726    ------------------------------
1727
1728    --  This function is applicable for both static and dynamic allocation of
1729    --  objects which are constrained by an initial expression. Basically it
1730    --  transforms an unconstrained subtype indication into a constrained one.
1731
1732    --  The expression may also be transformed in certain cases in order to
1733    --  avoid multiple evaluation. In the static allocation case, the general
1734    --  scheme is:
1735
1736    --     Val : T := Expr;
1737
1738    --        is transformed into
1739
1740    --     Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1741    --
1742    --  Here are the main cases :
1743    --
1744    --  <if Expr is a Slice>
1745    --    Val : T ([Index_Subtype (Expr)]) := Expr;
1746    --
1747    --  <elsif Expr is a String Literal>
1748    --    Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1749    --
1750    --  <elsif Expr is Constrained>
1751    --    subtype T is Type_Of_Expr
1752    --    Val : T := Expr;
1753    --
1754    --  <elsif Expr is an entity_name>
1755    --    Val : T (constraints taken from Expr) := Expr;
1756    --
1757    --  <else>
1758    --    type Axxx is access all T;
1759    --    Rval : Axxx := Expr'ref;
1760    --    Val  : T (constraints taken from Rval) := Rval.all;
1761
1762    --    ??? note: when the Expression is allocated in the secondary stack
1763    --              we could use it directly instead of copying it by declaring
1764    --              Val : T (...) renames Rval.all
1765
1766    procedure Expand_Subtype_From_Expr
1767      (N             : Node_Id;
1768       Unc_Type      : Entity_Id;
1769       Subtype_Indic : Node_Id;
1770       Exp           : Node_Id)
1771    is
1772       Loc     : constant Source_Ptr := Sloc (N);
1773       Exp_Typ : constant Entity_Id  := Etype (Exp);
1774       T       : Entity_Id;
1775
1776    begin
1777       --  In general we cannot build the subtype if expansion is disabled,
1778       --  because internal entities may not have been defined. However, to
1779       --  avoid some cascaded errors, we try to continue when the expression is
1780       --  an array (or string), because it is safe to compute the bounds. It is
1781       --  in fact required to do so even in a generic context, because there
1782       --  may be constants that depend on the bounds of a string literal, both
1783       --  standard string types and more generally arrays of characters.
1784
1785       if not Expander_Active
1786         and then (No (Etype (Exp))
1787                    or else not Is_String_Type (Etype (Exp)))
1788       then
1789          return;
1790       end if;
1791
1792       if Nkind (Exp) = N_Slice then
1793          declare
1794             Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1795
1796          begin
1797             Rewrite (Subtype_Indic,
1798               Make_Subtype_Indication (Loc,
1799                 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1800                 Constraint =>
1801                   Make_Index_Or_Discriminant_Constraint (Loc,
1802                     Constraints => New_List
1803                       (New_Reference_To (Slice_Type, Loc)))));
1804
1805             --  This subtype indication may be used later for constraint checks
1806             --  we better make sure that if a variable was used as a bound of
1807             --  of the original slice, its value is frozen.
1808
1809             Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1810             Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1811          end;
1812
1813       elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1814          Rewrite (Subtype_Indic,
1815            Make_Subtype_Indication (Loc,
1816              Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1817              Constraint =>
1818                Make_Index_Or_Discriminant_Constraint (Loc,
1819                  Constraints => New_List (
1820                    Make_Literal_Range (Loc,
1821                      Literal_Typ => Exp_Typ)))));
1822
1823       elsif Is_Constrained (Exp_Typ)
1824         and then not Is_Class_Wide_Type (Unc_Type)
1825       then
1826          if Is_Itype (Exp_Typ) then
1827
1828             --  Within an initialization procedure, a selected component
1829             --  denotes a component of the enclosing record, and it appears as
1830             --  an actual in a call to its own initialization procedure. If
1831             --  this component depends on the outer discriminant, we must
1832             --  generate the proper actual subtype for it.
1833
1834             if Nkind (Exp) = N_Selected_Component
1835               and then Within_Init_Proc
1836             then
1837                declare
1838                   Decl : constant Node_Id :=
1839                            Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
1840                begin
1841                   if Present (Decl) then
1842                      Insert_Action (N, Decl);
1843                      T := Defining_Identifier (Decl);
1844                   else
1845                      T := Exp_Typ;
1846                   end if;
1847                end;
1848
1849             --  No need to generate a new one (new what???)
1850
1851             else
1852                T := Exp_Typ;
1853             end if;
1854
1855          else
1856             T := Make_Temporary (Loc, 'T');
1857
1858             Insert_Action (N,
1859               Make_Subtype_Declaration (Loc,
1860                 Defining_Identifier => T,
1861                 Subtype_Indication  => New_Reference_To (Exp_Typ, Loc)));
1862
1863             --  This type is marked as an itype even though it has an explicit
1864             --  declaration since otherwise Is_Generic_Actual_Type can get
1865             --  set, resulting in the generation of spurious errors. (See
1866             --  sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1867
1868             Set_Is_Itype (T);
1869             Set_Associated_Node_For_Itype (T, Exp);
1870          end if;
1871
1872          Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1873
1874       --  Nothing needs to be done for private types with unknown discriminants
1875       --  if the underlying type is not an unconstrained composite type or it
1876       --  is an unchecked union.
1877
1878       elsif Is_Private_Type (Unc_Type)
1879         and then Has_Unknown_Discriminants (Unc_Type)
1880         and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1881                    or else Is_Constrained (Underlying_Type (Unc_Type))
1882                    or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
1883       then
1884          null;
1885
1886       --  Case of derived type with unknown discriminants where the parent type
1887       --  also has unknown discriminants.
1888
1889       elsif Is_Record_Type (Unc_Type)
1890         and then not Is_Class_Wide_Type (Unc_Type)
1891         and then Has_Unknown_Discriminants (Unc_Type)
1892         and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
1893       then
1894          --  Nothing to be done if no underlying record view available
1895
1896          if No (Underlying_Record_View (Unc_Type)) then
1897             null;
1898
1899          --  Otherwise use the Underlying_Record_View to create the proper
1900          --  constrained subtype for an object of a derived type with unknown
1901          --  discriminants.
1902
1903          else
1904             Remove_Side_Effects (Exp);
1905             Rewrite (Subtype_Indic,
1906               Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
1907          end if;
1908
1909       --  Renamings of class-wide interface types require no equivalent
1910       --  constrained type declarations because we only need to reference
1911       --  the tag component associated with the interface. The same is
1912       --  presumably true for class-wide types in general, so this test
1913       --  is broadened to include all class-wide renamings, which also
1914       --  avoids cases of unbounded recursion in Remove_Side_Effects.
1915       --  (Is this really correct, or are there some cases of class-wide
1916       --  renamings that require action in this procedure???)
1917
1918       elsif Present (N)
1919         and then Nkind (N) = N_Object_Renaming_Declaration
1920         and then Is_Class_Wide_Type (Unc_Type)
1921       then
1922          null;
1923
1924       --  In Ada95 nothing to be done if the type of the expression is limited,
1925       --  because in this case the expression cannot be copied, and its use can
1926       --  only be by reference.
1927
1928       --  In Ada2005, the context can be an object declaration whose expression
1929       --  is a function that returns in place. If the nominal subtype has
1930       --  unknown discriminants, the call still provides constraints on the
1931       --  object, and we have to create an actual subtype from it.
1932
1933       --  If the type is class-wide, the expression is dynamically tagged and
1934       --  we do not create an actual subtype either. Ditto for an interface.
1935       --  For now this applies only if the type is immutably limited, and the
1936       --  function being called is build-in-place. This will have to be revised
1937       --  when build-in-place functions are generalized to other types.
1938
1939       elsif Is_Immutably_Limited_Type (Exp_Typ)
1940         and then
1941          (Is_Class_Wide_Type (Exp_Typ)
1942            or else Is_Interface (Exp_Typ)
1943            or else not Has_Unknown_Discriminants (Exp_Typ)
1944            or else not Is_Composite_Type (Unc_Type))
1945       then
1946          null;
1947
1948       --  For limited objects initialized with build in place function calls,
1949       --  nothing to be done; otherwise we prematurely introduce an N_Reference
1950       --  node in the expression initializing the object, which breaks the
1951       --  circuitry that detects and adds the additional arguments to the
1952       --  called function.
1953
1954       elsif Is_Build_In_Place_Function_Call (Exp) then
1955          null;
1956
1957       else
1958          Remove_Side_Effects (Exp);
1959          Rewrite (Subtype_Indic,
1960            Make_Subtype_From_Expr (Exp, Unc_Type));
1961       end if;
1962    end Expand_Subtype_From_Expr;
1963
1964    --------------------
1965    -- Find_Init_Call --
1966    --------------------
1967
1968    function Find_Init_Call
1969      (Var        : Entity_Id;
1970       Rep_Clause : Node_Id) return Node_Id
1971    is
1972       Typ : constant Entity_Id := Etype (Var);
1973
1974       Init_Proc : Entity_Id;
1975       --  Initialization procedure for Typ
1976
1977       function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
1978       --  Look for init call for Var starting at From and scanning the
1979       --  enclosing list until Rep_Clause or the end of the list is reached.
1980
1981       ----------------------------
1982       -- Find_Init_Call_In_List --
1983       ----------------------------
1984
1985       function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
1986          Init_Call : Node_Id;
1987       begin
1988          Init_Call := From;
1989
1990          while Present (Init_Call) and then Init_Call /= Rep_Clause loop
1991             if Nkind (Init_Call) = N_Procedure_Call_Statement
1992               and then Is_Entity_Name (Name (Init_Call))
1993               and then Entity (Name (Init_Call)) = Init_Proc
1994             then
1995                return Init_Call;
1996             end if;
1997
1998             Next (Init_Call);
1999          end loop;
2000
2001          return Empty;
2002       end Find_Init_Call_In_List;
2003
2004       Init_Call : Node_Id;
2005
2006    --  Start of processing for Find_Init_Call
2007
2008    begin
2009       if not Has_Non_Null_Base_Init_Proc (Typ) then
2010          --  No init proc for the type, so obviously no call to be found
2011
2012          return Empty;
2013       end if;
2014
2015       Init_Proc := Base_Init_Proc (Typ);
2016
2017       --  First scan the list containing the declaration of Var
2018
2019       Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
2020
2021       --  If not found, also look on Var's freeze actions list, if any, since
2022       --  the init call may have been moved there (case of an address clause
2023       --  applying to Var).
2024
2025       if No (Init_Call) and then Present (Freeze_Node (Var)) then
2026          Init_Call :=
2027            Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
2028       end if;
2029
2030       return Init_Call;
2031    end Find_Init_Call;
2032
2033    ------------------------
2034    -- Find_Interface_ADT --
2035    ------------------------
2036
2037    function Find_Interface_ADT
2038      (T     : Entity_Id;
2039       Iface : Entity_Id) return Elmt_Id
2040    is
2041       ADT : Elmt_Id;
2042       Typ : Entity_Id := T;
2043
2044    begin
2045       pragma Assert (Is_Interface (Iface));
2046
2047       --  Handle private types
2048
2049       if Has_Private_Declaration (Typ)
2050         and then Present (Full_View (Typ))
2051       then
2052          Typ := Full_View (Typ);
2053       end if;
2054
2055       --  Handle access types
2056
2057       if Is_Access_Type (Typ) then
2058          Typ := Designated_Type (Typ);
2059       end if;
2060
2061       --  Handle task and protected types implementing interfaces
2062
2063       if Is_Concurrent_Type (Typ) then
2064          Typ := Corresponding_Record_Type (Typ);
2065       end if;
2066
2067       pragma Assert
2068         (not Is_Class_Wide_Type (Typ)
2069           and then Ekind (Typ) /= E_Incomplete_Type);
2070
2071       if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2072          return First_Elmt (Access_Disp_Table (Typ));
2073
2074       else
2075          ADT :=
2076            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
2077          while Present (ADT)
2078            and then Present (Related_Type (Node (ADT)))
2079            and then Related_Type (Node (ADT)) /= Iface
2080            and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
2081                                      Use_Full_View => True)
2082          loop
2083             Next_Elmt (ADT);
2084          end loop;
2085
2086          pragma Assert (Present (Related_Type (Node (ADT))));
2087          return ADT;
2088       end if;
2089    end Find_Interface_ADT;
2090
2091    ------------------------
2092    -- Find_Interface_Tag --
2093    ------------------------
2094
2095    function Find_Interface_Tag
2096      (T     : Entity_Id;
2097       Iface : Entity_Id) return Entity_Id
2098    is
2099       AI_Tag : Entity_Id;
2100       Found  : Boolean   := False;
2101       Typ    : Entity_Id := T;
2102
2103       procedure Find_Tag (Typ : Entity_Id);
2104       --  Internal subprogram used to recursively climb to the ancestors
2105
2106       --------------
2107       -- Find_Tag --
2108       --------------
2109
2110       procedure Find_Tag (Typ : Entity_Id) is
2111          AI_Elmt : Elmt_Id;
2112          AI      : Node_Id;
2113
2114       begin
2115          --  This routine does not handle the case in which the interface is an
2116          --  ancestor of Typ. That case is handled by the enclosing subprogram.
2117
2118          pragma Assert (Typ /= Iface);
2119
2120          --  Climb to the root type handling private types
2121
2122          if Present (Full_View (Etype (Typ))) then
2123             if Full_View (Etype (Typ)) /= Typ then
2124                Find_Tag (Full_View (Etype (Typ)));
2125             end if;
2126
2127          elsif Etype (Typ) /= Typ then
2128             Find_Tag (Etype (Typ));
2129          end if;
2130
2131          --  Traverse the list of interfaces implemented by the type
2132
2133          if not Found
2134            and then Present (Interfaces (Typ))
2135            and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
2136          then
2137             --  Skip the tag associated with the primary table
2138
2139             pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2140             AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
2141             pragma Assert (Present (AI_Tag));
2142
2143             AI_Elmt := First_Elmt (Interfaces (Typ));
2144             while Present (AI_Elmt) loop
2145                AI := Node (AI_Elmt);
2146
2147                if AI = Iface
2148                  or else Is_Ancestor (Iface, AI, Use_Full_View => True)
2149                then
2150                   Found := True;
2151                   return;
2152                end if;
2153
2154                AI_Tag := Next_Tag_Component (AI_Tag);
2155                Next_Elmt (AI_Elmt);
2156             end loop;
2157          end if;
2158       end Find_Tag;
2159
2160    --  Start of processing for Find_Interface_Tag
2161
2162    begin
2163       pragma Assert (Is_Interface (Iface));
2164
2165       --  Handle access types
2166
2167       if Is_Access_Type (Typ) then
2168          Typ := Designated_Type (Typ);
2169       end if;
2170
2171       --  Handle class-wide types
2172
2173       if Is_Class_Wide_Type (Typ) then
2174          Typ := Root_Type (Typ);
2175       end if;
2176
2177       --  Handle private types
2178
2179       if Has_Private_Declaration (Typ)
2180         and then Present (Full_View (Typ))
2181       then
2182          Typ := Full_View (Typ);
2183       end if;
2184
2185       --  Handle entities from the limited view
2186
2187       if Ekind (Typ) = E_Incomplete_Type then
2188          pragma Assert (Present (Non_Limited_View (Typ)));
2189          Typ := Non_Limited_View (Typ);
2190       end if;
2191
2192       --  Handle task and protected types implementing interfaces
2193
2194       if Is_Concurrent_Type (Typ) then
2195          Typ := Corresponding_Record_Type (Typ);
2196       end if;
2197
2198       --  If the interface is an ancestor of the type, then it shared the
2199       --  primary dispatch table.
2200
2201       if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2202          pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2203          return First_Tag_Component (Typ);
2204
2205       --  Otherwise we need to search for its associated tag component
2206
2207       else
2208          Find_Tag (Typ);
2209          pragma Assert (Found);
2210          return AI_Tag;
2211       end if;
2212    end Find_Interface_Tag;
2213
2214    ------------------
2215    -- Find_Prim_Op --
2216    ------------------
2217
2218    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
2219       Prim : Elmt_Id;
2220       Typ  : Entity_Id := T;
2221       Op   : Entity_Id;
2222
2223    begin
2224       if Is_Class_Wide_Type (Typ) then
2225          Typ := Root_Type (Typ);
2226       end if;
2227
2228       Typ := Underlying_Type (Typ);
2229
2230       --  Loop through primitive operations
2231
2232       Prim := First_Elmt (Primitive_Operations (Typ));
2233       while Present (Prim) loop
2234          Op := Node (Prim);
2235
2236          --  We can retrieve primitive operations by name if it is an internal
2237          --  name. For equality we must check that both of its operands have
2238          --  the same type, to avoid confusion with user-defined equalities
2239          --  than may have a non-symmetric signature.
2240
2241          exit when Chars (Op) = Name
2242            and then
2243              (Name /= Name_Op_Eq
2244                 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
2245
2246          Next_Elmt (Prim);
2247
2248          --  Raise Program_Error if no primitive found
2249
2250          if No (Prim) then
2251             raise Program_Error;
2252          end if;
2253       end loop;
2254
2255       return Node (Prim);
2256    end Find_Prim_Op;
2257
2258    ------------------
2259    -- Find_Prim_Op --
2260    ------------------
2261
2262    function Find_Prim_Op
2263      (T    : Entity_Id;
2264       Name : TSS_Name_Type) return Entity_Id
2265    is
2266       Inher_Op  : Entity_Id := Empty;
2267       Own_Op    : Entity_Id := Empty;
2268       Prim_Elmt : Elmt_Id;
2269       Prim_Id   : Entity_Id;
2270       Typ       : Entity_Id := T;
2271
2272    begin
2273       if Is_Class_Wide_Type (Typ) then
2274          Typ := Root_Type (Typ);
2275       end if;
2276
2277       Typ := Underlying_Type (Typ);
2278
2279       --  This search is based on the assertion that the dispatching version
2280       --  of the TSS routine always precedes the real primitive.
2281
2282       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2283       while Present (Prim_Elmt) loop
2284          Prim_Id := Node (Prim_Elmt);
2285
2286          if Is_TSS (Prim_Id, Name) then
2287             if Present (Alias (Prim_Id)) then
2288                Inher_Op := Prim_Id;
2289             else
2290                Own_Op := Prim_Id;
2291             end if;
2292          end if;
2293
2294          Next_Elmt (Prim_Elmt);
2295       end loop;
2296
2297       if Present (Own_Op) then
2298          return Own_Op;
2299       elsif Present (Inher_Op) then
2300          return Inher_Op;
2301       else
2302          raise Program_Error;
2303       end if;
2304    end Find_Prim_Op;
2305
2306    ----------------------------
2307    -- Find_Protection_Object --
2308    ----------------------------
2309
2310    function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
2311       S : Entity_Id;
2312
2313    begin
2314       S := Scop;
2315       while Present (S) loop
2316          if (Ekind (S) = E_Entry
2317                or else Ekind (S) = E_Entry_Family
2318                or else Ekind (S) = E_Function
2319                or else Ekind (S) = E_Procedure)
2320            and then Present (Protection_Object (S))
2321          then
2322             return Protection_Object (S);
2323          end if;
2324
2325          S := Scope (S);
2326       end loop;
2327
2328       --  If we do not find a Protection object in the scope chain, then
2329       --  something has gone wrong, most likely the object was never created.
2330
2331       raise Program_Error;
2332    end Find_Protection_Object;
2333
2334    --------------------------
2335    -- Find_Protection_Type --
2336    --------------------------
2337
2338    function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
2339       Comp : Entity_Id;
2340       Typ  : Entity_Id := Conc_Typ;
2341
2342    begin
2343       if Is_Concurrent_Type (Typ) then
2344          Typ := Corresponding_Record_Type (Typ);
2345       end if;
2346
2347       --  Since restriction violations are not considered serious errors, the
2348       --  expander remains active, but may leave the corresponding record type
2349       --  malformed. In such cases, component _object is not available so do
2350       --  not look for it.
2351
2352       if not Analyzed (Typ) then
2353          return Empty;
2354       end if;
2355
2356       Comp := First_Component (Typ);
2357       while Present (Comp) loop
2358          if Chars (Comp) = Name_uObject then
2359             return Base_Type (Etype (Comp));
2360          end if;
2361
2362          Next_Component (Comp);
2363       end loop;
2364
2365       --  The corresponding record of a protected type should always have an
2366       --  _object field.
2367
2368       raise Program_Error;
2369    end Find_Protection_Type;
2370
2371    ----------------------
2372    -- Force_Evaluation --
2373    ----------------------
2374
2375    procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
2376    begin
2377       Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
2378    end Force_Evaluation;
2379
2380    ---------------------------------
2381    -- Fully_Qualified_Name_String --
2382    ---------------------------------
2383
2384    function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
2385       procedure Internal_Full_Qualified_Name (E : Entity_Id);
2386       --  Compute recursively the qualified name without NUL at the end, adding
2387       --  it to the currently started string being generated
2388
2389       ----------------------------------
2390       -- Internal_Full_Qualified_Name --
2391       ----------------------------------
2392
2393       procedure Internal_Full_Qualified_Name (E : Entity_Id) is
2394          Ent : Entity_Id;
2395
2396       begin
2397          --  Deal properly with child units
2398
2399          if Nkind (E) = N_Defining_Program_Unit_Name then
2400             Ent := Defining_Identifier (E);
2401          else
2402             Ent := E;
2403          end if;
2404
2405          --  Compute qualification recursively (only "Standard" has no scope)
2406
2407          if Present (Scope (Scope (Ent))) then
2408             Internal_Full_Qualified_Name (Scope (Ent));
2409             Store_String_Char (Get_Char_Code ('.'));
2410          end if;
2411
2412          --  Every entity should have a name except some expanded blocks
2413          --  don't bother about those.
2414
2415          if Chars (Ent) = No_Name then
2416             return;
2417          end if;
2418
2419          --  Generates the entity name in upper case
2420
2421          Get_Decoded_Name_String (Chars (Ent));
2422          Set_All_Upper_Case;
2423          Store_String_Chars (Name_Buffer (1 .. Name_Len));
2424          return;
2425       end Internal_Full_Qualified_Name;
2426
2427    --  Start of processing for Full_Qualified_Name
2428
2429    begin
2430       Start_String;
2431       Internal_Full_Qualified_Name (E);
2432       Store_String_Char (Get_Char_Code (ASCII.NUL));
2433       return End_String;
2434    end Fully_Qualified_Name_String;
2435
2436    ------------------------
2437    -- Generate_Poll_Call --
2438    ------------------------
2439
2440    procedure Generate_Poll_Call (N : Node_Id) is
2441    begin
2442       --  No poll call if polling not active
2443
2444       if not Polling_Required then
2445          return;
2446
2447       --  Otherwise generate require poll call
2448
2449       else
2450          Insert_Before_And_Analyze (N,
2451            Make_Procedure_Call_Statement (Sloc (N),
2452              Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
2453       end if;
2454    end Generate_Poll_Call;
2455
2456    ---------------------------------
2457    -- Get_Current_Value_Condition --
2458    ---------------------------------
2459
2460    --  Note: the implementation of this procedure is very closely tied to the
2461    --  implementation of Set_Current_Value_Condition. In the Get procedure, we
2462    --  interpret Current_Value fields set by the Set procedure, so the two
2463    --  procedures need to be closely coordinated.
2464
2465    procedure Get_Current_Value_Condition
2466      (Var : Node_Id;
2467       Op  : out Node_Kind;
2468       Val : out Node_Id)
2469    is
2470       Loc : constant Source_Ptr := Sloc (Var);
2471       Ent : constant Entity_Id  := Entity (Var);
2472
2473       procedure Process_Current_Value_Condition
2474         (N : Node_Id;
2475          S : Boolean);
2476       --  N is an expression which holds either True (S = True) or False (S =
2477       --  False) in the condition. This procedure digs out the expression and
2478       --  if it refers to Ent, sets Op and Val appropriately.
2479
2480       -------------------------------------
2481       -- Process_Current_Value_Condition --
2482       -------------------------------------
2483
2484       procedure Process_Current_Value_Condition
2485         (N : Node_Id;
2486          S : Boolean)
2487       is
2488          Cond : Node_Id;
2489          Sens : Boolean;
2490
2491       begin
2492          Cond := N;
2493          Sens := S;
2494
2495          --  Deal with NOT operators, inverting sense
2496
2497          while Nkind (Cond) = N_Op_Not loop
2498             Cond := Right_Opnd (Cond);
2499             Sens := not Sens;
2500          end loop;
2501
2502          --  Deal with AND THEN and AND cases
2503
2504          if Nkind (Cond) = N_And_Then
2505            or else Nkind (Cond) = N_Op_And
2506          then
2507             --  Don't ever try to invert a condition that is of the form of an
2508             --  AND or AND THEN (since we are not doing sufficiently general
2509             --  processing to allow this).
2510
2511             if Sens = False then
2512                Op  := N_Empty;
2513                Val := Empty;
2514                return;
2515             end if;
2516
2517             --  Recursively process AND and AND THEN branches
2518
2519             Process_Current_Value_Condition (Left_Opnd (Cond), True);
2520
2521             if Op /= N_Empty then
2522                return;
2523             end if;
2524
2525             Process_Current_Value_Condition (Right_Opnd (Cond), True);
2526             return;
2527
2528          --  Case of relational operator
2529
2530          elsif Nkind (Cond) in N_Op_Compare then
2531             Op := Nkind (Cond);
2532
2533             --  Invert sense of test if inverted test
2534
2535             if Sens = False then
2536                case Op is
2537                   when N_Op_Eq => Op := N_Op_Ne;
2538                   when N_Op_Ne => Op := N_Op_Eq;
2539                   when N_Op_Lt => Op := N_Op_Ge;
2540                   when N_Op_Gt => Op := N_Op_Le;
2541                   when N_Op_Le => Op := N_Op_Gt;
2542                   when N_Op_Ge => Op := N_Op_Lt;
2543                   when others  => raise Program_Error;
2544                end case;
2545             end if;
2546
2547             --  Case of entity op value
2548
2549             if Is_Entity_Name (Left_Opnd (Cond))
2550               and then Ent = Entity (Left_Opnd (Cond))
2551               and then Compile_Time_Known_Value (Right_Opnd (Cond))
2552             then
2553                Val := Right_Opnd (Cond);
2554
2555             --  Case of value op entity
2556
2557             elsif Is_Entity_Name (Right_Opnd (Cond))
2558               and then Ent = Entity (Right_Opnd (Cond))
2559               and then Compile_Time_Known_Value (Left_Opnd (Cond))
2560             then
2561                Val := Left_Opnd (Cond);
2562
2563                --  We are effectively swapping operands
2564
2565                case Op is
2566                   when N_Op_Eq => null;
2567                   when N_Op_Ne => null;
2568                   when N_Op_Lt => Op := N_Op_Gt;
2569                   when N_Op_Gt => Op := N_Op_Lt;
2570                   when N_Op_Le => Op := N_Op_Ge;
2571                   when N_Op_Ge => Op := N_Op_Le;
2572                   when others  => raise Program_Error;
2573                end case;
2574
2575             else
2576                Op := N_Empty;
2577             end if;
2578
2579             return;
2580
2581             --  Case of Boolean variable reference, return as though the
2582             --  reference had said var = True.
2583
2584          else
2585             if Is_Entity_Name (Cond)
2586               and then Ent = Entity (Cond)
2587             then
2588                Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
2589
2590                if Sens = False then
2591                   Op := N_Op_Ne;
2592                else
2593                   Op := N_Op_Eq;
2594                end if;
2595             end if;
2596          end if;
2597       end Process_Current_Value_Condition;
2598
2599    --  Start of processing for Get_Current_Value_Condition
2600
2601    begin
2602       Op  := N_Empty;
2603       Val := Empty;
2604
2605       --  Immediate return, nothing doing, if this is not an object
2606
2607       if Ekind (Ent) not in Object_Kind then
2608          return;
2609       end if;
2610
2611       --  Otherwise examine current value
2612
2613       declare
2614          CV   : constant Node_Id := Current_Value (Ent);
2615          Sens : Boolean;
2616          Stm  : Node_Id;
2617
2618       begin
2619          --  If statement. Condition is known true in THEN section, known False
2620          --  in any ELSIF or ELSE part, and unknown outside the IF statement.
2621
2622          if Nkind (CV) = N_If_Statement then
2623
2624             --  Before start of IF statement
2625
2626             if Loc < Sloc (CV) then
2627                return;
2628
2629                --  After end of IF statement
2630
2631             elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
2632                return;
2633             end if;
2634
2635             --  At this stage we know that we are within the IF statement, but
2636             --  unfortunately, the tree does not record the SLOC of the ELSE so
2637             --  we cannot use a simple SLOC comparison to distinguish between
2638             --  the then/else statements, so we have to climb the tree.
2639
2640             declare
2641                N : Node_Id;
2642
2643             begin
2644                N := Parent (Var);
2645                while Parent (N) /= CV loop
2646                   N := Parent (N);
2647
2648                   --  If we fall off the top of the tree, then that's odd, but
2649                   --  perhaps it could occur in some error situation, and the
2650                   --  safest response is simply to assume that the outcome of
2651                   --  the condition is unknown. No point in bombing during an
2652                   --  attempt to optimize things.
2653
2654                   if No (N) then
2655                      return;
2656                   end if;
2657                end loop;
2658
2659                --  Now we have N pointing to a node whose parent is the IF
2660                --  statement in question, so now we can tell if we are within
2661                --  the THEN statements.
2662
2663                if Is_List_Member (N)
2664                  and then List_Containing (N) = Then_Statements (CV)
2665                then
2666                   Sens := True;
2667
2668                --  If the variable reference does not come from source, we
2669                --  cannot reliably tell whether it appears in the else part.
2670                --  In particular, if it appears in generated code for a node
2671                --  that requires finalization, it may be attached to a list
2672                --  that has not been yet inserted into the code. For now,
2673                --  treat it as unknown.
2674
2675                elsif not Comes_From_Source (N) then
2676                   return;
2677
2678                --  Otherwise we must be in ELSIF or ELSE part
2679
2680                else
2681                   Sens := False;
2682                end if;
2683             end;
2684
2685             --  ELSIF part. Condition is known true within the referenced
2686             --  ELSIF, known False in any subsequent ELSIF or ELSE part,
2687             --  and unknown before the ELSE part or after the IF statement.
2688
2689          elsif Nkind (CV) = N_Elsif_Part then
2690
2691             --  if the Elsif_Part had condition_actions, the elsif has been
2692             --  rewritten as a nested if, and the original elsif_part is
2693             --  detached from the tree, so there is no way to obtain useful
2694             --  information on the current value of the variable.
2695             --  Can this be improved ???
2696
2697             if No (Parent (CV)) then
2698                return;
2699             end if;
2700
2701             Stm := Parent (CV);
2702
2703             --  Before start of ELSIF part
2704
2705             if Loc < Sloc (CV) then
2706                return;
2707
2708                --  After end of IF statement
2709
2710             elsif Loc >= Sloc (Stm) +
2711               Text_Ptr (UI_To_Int (End_Span (Stm)))
2712             then
2713                return;
2714             end if;
2715
2716             --  Again we lack the SLOC of the ELSE, so we need to climb the
2717             --  tree to see if we are within the ELSIF part in question.
2718
2719             declare
2720                N : Node_Id;
2721
2722             begin
2723                N := Parent (Var);
2724                while Parent (N) /= Stm loop
2725                   N := Parent (N);
2726
2727                   --  If we fall off the top of the tree, then that's odd, but
2728                   --  perhaps it could occur in some error situation, and the
2729                   --  safest response is simply to assume that the outcome of
2730                   --  the condition is unknown. No point in bombing during an
2731                   --  attempt to optimize things.
2732
2733                   if No (N) then
2734                      return;
2735                   end if;
2736                end loop;
2737
2738                --  Now we have N pointing to a node whose parent is the IF
2739                --  statement in question, so see if is the ELSIF part we want.
2740                --  the THEN statements.
2741
2742                if N = CV then
2743                   Sens := True;
2744
2745                   --  Otherwise we must be in subsequent ELSIF or ELSE part
2746
2747                else
2748                   Sens := False;
2749                end if;
2750             end;
2751
2752          --  Iteration scheme of while loop. The condition is known to be
2753          --  true within the body of the loop.
2754
2755          elsif Nkind (CV) = N_Iteration_Scheme then
2756             declare
2757                Loop_Stmt : constant Node_Id := Parent (CV);
2758
2759             begin
2760                --  Before start of body of loop
2761
2762                if Loc < Sloc (Loop_Stmt) then
2763                   return;
2764
2765                --  After end of LOOP statement
2766
2767                elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
2768                   return;
2769
2770                --  We are within the body of the loop
2771
2772                else
2773                   Sens := True;
2774                end if;
2775             end;
2776
2777          --  All other cases of Current_Value settings
2778
2779          else
2780             return;
2781          end if;
2782
2783          --  If we fall through here, then we have a reportable condition, Sens
2784          --  is True if the condition is true and False if it needs inverting.
2785
2786          Process_Current_Value_Condition (Condition (CV), Sens);
2787       end;
2788    end Get_Current_Value_Condition;
2789
2790    ---------------------
2791    -- Get_Stream_Size --
2792    ---------------------
2793
2794    function Get_Stream_Size (E : Entity_Id) return Uint is
2795    begin
2796       --  If we have a Stream_Size clause for this type use it
2797
2798       if Has_Stream_Size_Clause (E) then
2799          return Static_Integer (Expression (Stream_Size_Clause (E)));
2800
2801       --  Otherwise the Stream_Size if the size of the type
2802
2803       else
2804          return Esize (E);
2805       end if;
2806    end Get_Stream_Size;
2807
2808    ---------------------------
2809    -- Has_Access_Constraint --
2810    ---------------------------
2811
2812    function Has_Access_Constraint (E : Entity_Id) return Boolean is
2813       Disc : Entity_Id;
2814       T    : constant Entity_Id := Etype (E);
2815
2816    begin
2817       if Has_Per_Object_Constraint (E)
2818         and then Has_Discriminants (T)
2819       then
2820          Disc := First_Discriminant (T);
2821          while Present (Disc) loop
2822             if Is_Access_Type (Etype (Disc)) then
2823                return True;
2824             end if;
2825
2826             Next_Discriminant (Disc);
2827          end loop;
2828
2829          return False;
2830       else
2831          return False;
2832       end if;
2833    end Has_Access_Constraint;
2834
2835    ----------------------------------
2836    -- Has_Following_Address_Clause --
2837    ----------------------------------
2838
2839    --  Should this function check the private part in a package ???
2840
2841    function Has_Following_Address_Clause (D : Node_Id) return Boolean is
2842       Id   : constant Entity_Id := Defining_Identifier (D);
2843       Decl : Node_Id;
2844
2845    begin
2846       Decl := Next (D);
2847       while Present (Decl) loop
2848          if Nkind (Decl) = N_At_Clause
2849            and then Chars (Identifier (Decl)) = Chars (Id)
2850          then
2851             return True;
2852
2853          elsif Nkind (Decl) = N_Attribute_Definition_Clause
2854            and then Chars (Decl) = Name_Address
2855            and then Chars (Name (Decl)) = Chars (Id)
2856          then
2857             return True;
2858          end if;
2859
2860          Next (Decl);
2861       end loop;
2862
2863       return False;
2864    end Has_Following_Address_Clause;
2865
2866    --------------------
2867    -- Homonym_Number --
2868    --------------------
2869
2870    function Homonym_Number (Subp : Entity_Id) return Nat is
2871       Count : Nat;
2872       Hom   : Entity_Id;
2873
2874    begin
2875       Count := 1;
2876       Hom := Homonym (Subp);
2877       while Present (Hom) loop
2878          if Scope (Hom) = Scope (Subp) then
2879             Count := Count + 1;
2880          end if;
2881
2882          Hom := Homonym (Hom);
2883       end loop;
2884
2885       return Count;
2886    end Homonym_Number;
2887
2888    -----------------------------------
2889    -- In_Library_Level_Package_Body --
2890    -----------------------------------
2891
2892    function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
2893    begin
2894       --  First determine whether the entity appears at the library level, then
2895       --  look at the containing unit.
2896
2897       if Is_Library_Level_Entity (Id) then
2898          declare
2899             Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
2900
2901          begin
2902             return Nkind (Unit (Container)) = N_Package_Body;
2903          end;
2904       end if;
2905
2906       return False;
2907    end In_Library_Level_Package_Body;
2908
2909    ------------------------------
2910    -- In_Unconditional_Context --
2911    ------------------------------
2912
2913    function In_Unconditional_Context (Node : Node_Id) return Boolean is
2914       P : Node_Id;
2915
2916    begin
2917       P := Node;
2918       while Present (P) loop
2919          case Nkind (P) is
2920             when N_Subprogram_Body =>
2921                return True;
2922
2923             when N_If_Statement =>
2924                return False;
2925
2926             when N_Loop_Statement =>
2927                return False;
2928
2929             when N_Case_Statement =>
2930                return False;
2931
2932             when others =>
2933                P := Parent (P);
2934          end case;
2935       end loop;
2936
2937       return False;
2938    end In_Unconditional_Context;
2939
2940    -------------------
2941    -- Insert_Action --
2942    -------------------
2943
2944    procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
2945    begin
2946       if Present (Ins_Action) then
2947          Insert_Actions (Assoc_Node, New_List (Ins_Action));
2948       end if;
2949    end Insert_Action;
2950
2951    --  Version with check(s) suppressed
2952
2953    procedure Insert_Action
2954      (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
2955    is
2956    begin
2957       Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
2958    end Insert_Action;
2959
2960    -------------------------
2961    -- Insert_Action_After --
2962    -------------------------
2963
2964    procedure Insert_Action_After
2965      (Assoc_Node : Node_Id;
2966       Ins_Action : Node_Id)
2967    is
2968    begin
2969       Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
2970    end Insert_Action_After;
2971
2972    --------------------
2973    -- Insert_Actions --
2974    --------------------
2975
2976    procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
2977       N : Node_Id;
2978       P : Node_Id;
2979
2980       Wrapped_Node : Node_Id := Empty;
2981
2982    begin
2983       if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
2984          return;
2985       end if;
2986
2987       --  Ignore insert of actions from inside default expression (or other
2988       --  similar "spec expression") in the special spec-expression analyze
2989       --  mode. Any insertions at this point have no relevance, since we are
2990       --  only doing the analyze to freeze the types of any static expressions.
2991       --  See section "Handling of Default Expressions" in the spec of package
2992       --  Sem for further details.
2993
2994       if In_Spec_Expression then
2995          return;
2996       end if;
2997
2998       --  If the action derives from stuff inside a record, then the actions
2999       --  are attached to the current scope, to be inserted and analyzed on
3000       --  exit from the scope. The reason for this is that we may also be
3001       --  generating freeze actions at the same time, and they must eventually
3002       --  be elaborated in the correct order.
3003
3004       if Is_Record_Type (Current_Scope)
3005         and then not Is_Frozen (Current_Scope)
3006       then
3007          if No (Scope_Stack.Table
3008            (Scope_Stack.Last).Pending_Freeze_Actions)
3009          then
3010             Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
3011               Ins_Actions;
3012          else
3013             Append_List
3014               (Ins_Actions,
3015                Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
3016          end if;
3017
3018          return;
3019       end if;
3020
3021       --  We now intend to climb up the tree to find the right point to
3022       --  insert the actions. We start at Assoc_Node, unless this node is a
3023       --  subexpression in which case we start with its parent. We do this for
3024       --  two reasons. First it speeds things up. Second, if Assoc_Node is
3025       --  itself one of the special nodes like N_And_Then, then we assume that
3026       --  an initial request to insert actions for such a node does not expect
3027       --  the actions to get deposited in the node for later handling when the
3028       --  node is expanded, since clearly the node is being dealt with by the
3029       --  caller. Note that in the subexpression case, N is always the child we
3030       --  came from.
3031
3032       --  N_Raise_xxx_Error is an annoying special case, it is a statement if
3033       --  it has type Standard_Void_Type, and a subexpression otherwise.
3034       --  otherwise. Procedure attribute references are also statements.
3035
3036       if Nkind (Assoc_Node) in N_Subexpr
3037         and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
3038                    or else Etype (Assoc_Node) /= Standard_Void_Type)
3039         and then (Nkind (Assoc_Node) /= N_Attribute_Reference
3040                    or else
3041                      not Is_Procedure_Attribute_Name
3042                            (Attribute_Name (Assoc_Node)))
3043       then
3044          P := Assoc_Node;             -- ??? does not agree with above!
3045          N := Parent (Assoc_Node);
3046
3047       --  Non-subexpression case. Note that N is initially Empty in this case
3048       --  (N is only guaranteed Non-Empty in the subexpr case).
3049
3050       else
3051          P := Assoc_Node;
3052          N := Empty;
3053       end if;
3054
3055       --  Capture root of the transient scope
3056
3057       if Scope_Is_Transient then
3058          Wrapped_Node := Node_To_Be_Wrapped;
3059       end if;
3060
3061       loop
3062          pragma Assert (Present (P));
3063
3064          case Nkind (P) is
3065
3066             --  Case of right operand of AND THEN or OR ELSE. Put the actions
3067             --  in the Actions field of the right operand. They will be moved
3068             --  out further when the AND THEN or OR ELSE operator is expanded.
3069             --  Nothing special needs to be done for the left operand since
3070             --  in that case the actions are executed unconditionally.
3071
3072             when N_Short_Circuit =>
3073                if N = Right_Opnd (P) then
3074
3075                   --  We are now going to either append the actions to the
3076                   --  actions field of the short-circuit operation. We will
3077                   --  also analyze the actions now.
3078
3079                   --  This analysis is really too early, the proper thing would
3080                   --  be to just park them there now, and only analyze them if
3081                   --  we find we really need them, and to it at the proper
3082                   --  final insertion point. However attempting to this proved
3083                   --  tricky, so for now we just kill current values before and
3084                   --  after the analyze call to make sure we avoid peculiar
3085                   --  optimizations from this out of order insertion.
3086
3087                   Kill_Current_Values;
3088
3089                   if Present (Actions (P)) then
3090                      Insert_List_After_And_Analyze
3091                        (Last (Actions (P)), Ins_Actions);
3092                   else
3093                      Set_Actions (P, Ins_Actions);
3094                      Analyze_List (Actions (P));
3095                   end if;
3096
3097                   Kill_Current_Values;
3098
3099                   return;
3100                end if;
3101
3102             --  Then or Else operand of conditional expression. Add actions to
3103             --  Then_Actions or Else_Actions field as appropriate. The actions
3104             --  will be moved further out when the conditional is expanded.
3105
3106             when N_Conditional_Expression =>
3107                declare
3108                   ThenX : constant Node_Id := Next (First (Expressions (P)));
3109                   ElseX : constant Node_Id := Next (ThenX);
3110
3111                begin
3112                   --  If the enclosing expression is already analyzed, as
3113                   --  is the case for nested elaboration checks, insert the
3114                   --  conditional further out.
3115
3116                   if Analyzed (P) then
3117                      null;
3118
3119                   --  Actions belong to the then expression, temporarily place
3120                   --  them as Then_Actions of the conditional expr. They will
3121                   --  be moved to the proper place later when the conditional
3122                   --  expression is expanded.
3123
3124                   elsif N = ThenX then
3125                      if Present (Then_Actions (P)) then
3126                         Insert_List_After_And_Analyze
3127                           (Last (Then_Actions (P)), Ins_Actions);
3128                      else
3129                         Set_Then_Actions (P, Ins_Actions);
3130                         Analyze_List (Then_Actions (P));
3131                      end if;
3132
3133                      return;
3134
3135                   --  Actions belong to the else expression, temporarily
3136                   --  place them as Else_Actions of the conditional expr.
3137                   --  They will be moved to the proper place later when
3138                   --  the conditional expression is expanded.
3139
3140                   elsif N = ElseX then
3141                      if Present (Else_Actions (P)) then
3142                         Insert_List_After_And_Analyze
3143                           (Last (Else_Actions (P)), Ins_Actions);
3144                      else
3145                         Set_Else_Actions (P, Ins_Actions);
3146                         Analyze_List (Else_Actions (P));
3147                      end if;
3148
3149                      return;
3150
3151                   --  Actions belong to the condition. In this case they are
3152                   --  unconditionally executed, and so we can continue the
3153                   --  search for the proper insert point.
3154
3155                   else
3156                      null;
3157                   end if;
3158                end;
3159
3160             --  Alternative of case expression, we place the action in the
3161             --  Actions field of the case expression alternative, this will
3162             --  be handled when the case expression is expanded.
3163
3164             when N_Case_Expression_Alternative =>
3165                if Present (Actions (P)) then
3166                   Insert_List_After_And_Analyze
3167                     (Last (Actions (P)), Ins_Actions);
3168                else
3169                   Set_Actions (P, Ins_Actions);
3170                   Analyze_List (Actions (P));
3171                end if;
3172
3173                return;
3174
3175             --  Case of appearing within an Expressions_With_Actions node. We
3176             --  prepend the actions to the list of actions already there, if
3177             --  the node has not been analyzed yet. Otherwise find insertion
3178             --  location further up the tree.
3179
3180             when N_Expression_With_Actions =>
3181                if not Analyzed (P) then
3182                   Prepend_List (Ins_Actions, Actions (P));
3183                   return;
3184                end if;
3185
3186             --  Case of appearing in the condition of a while expression or
3187             --  elsif. We insert the actions into the Condition_Actions field.
3188             --  They will be moved further out when the while loop or elsif
3189             --  is analyzed.
3190
3191             when N_Iteration_Scheme |
3192                  N_Elsif_Part
3193             =>
3194                if N = Condition (P) then
3195                   if Present (Condition_Actions (P)) then
3196                      Insert_List_After_And_Analyze
3197                        (Last (Condition_Actions (P)), Ins_Actions);
3198                   else
3199                      Set_Condition_Actions (P, Ins_Actions);
3200
3201                      --  Set the parent of the insert actions explicitly. This
3202                      --  is not a syntactic field, but we need the parent field
3203                      --  set, in particular so that freeze can understand that
3204                      --  it is dealing with condition actions, and properly
3205                      --  insert the freezing actions.
3206
3207                      Set_Parent (Ins_Actions, P);
3208                      Analyze_List (Condition_Actions (P));
3209                   end if;
3210
3211                   return;
3212                end if;
3213
3214             --  Statements, declarations, pragmas, representation clauses
3215
3216             when
3217                --  Statements
3218
3219                N_Procedure_Call_Statement               |
3220                N_Statement_Other_Than_Procedure_Call    |
3221
3222                --  Pragmas
3223
3224                N_Pragma                                 |
3225
3226                --  Representation_Clause
3227
3228                N_At_Clause                              |
3229                N_Attribute_Definition_Clause            |
3230                N_Enumeration_Representation_Clause      |
3231                N_Record_Representation_Clause           |
3232
3233                --  Declarations
3234
3235                N_Abstract_Subprogram_Declaration        |
3236                N_Entry_Body                             |
3237                N_Exception_Declaration                  |
3238                N_Exception_Renaming_Declaration         |
3239                N_Expression_Function                    |
3240                N_Formal_Abstract_Subprogram_Declaration |
3241                N_Formal_Concrete_Subprogram_Declaration |
3242                N_Formal_Object_Declaration              |
3243                N_Formal_Type_Declaration                |
3244                N_Full_Type_Declaration                  |
3245                N_Function_Instantiation                 |
3246                N_Generic_Function_Renaming_Declaration  |
3247                N_Generic_Package_Declaration            |
3248                N_Generic_Package_Renaming_Declaration   |
3249                N_Generic_Procedure_Renaming_Declaration |
3250                N_Generic_Subprogram_Declaration         |
3251                N_Implicit_Label_Declaration             |
3252                N_Incomplete_Type_Declaration            |
3253                N_Number_Declaration                     |
3254                N_Object_Declaration                     |
3255                N_Object_Renaming_Declaration            |
3256                N_Package_Body                           |
3257                N_Package_Body_Stub                      |
3258                N_Package_Declaration                    |
3259                N_Package_Instantiation                  |
3260                N_Package_Renaming_Declaration           |
3261                N_Private_Extension_Declaration          |
3262                N_Private_Type_Declaration               |
3263                N_Procedure_Instantiation                |
3264                N_Protected_Body                         |
3265                N_Protected_Body_Stub                    |
3266                N_Protected_Type_Declaration             |
3267                N_Single_Task_Declaration                |
3268                N_Subprogram_Body                        |
3269                N_Subprogram_Body_Stub                   |
3270                N_Subprogram_Declaration                 |
3271                N_Subprogram_Renaming_Declaration        |
3272                N_Subtype_Declaration                    |
3273                N_Task_Body                              |
3274                N_Task_Body_Stub                         |
3275                N_Task_Type_Declaration                  |
3276
3277                --  Use clauses can appear in lists of declarations
3278
3279                N_Use_Package_Clause                     |
3280                N_Use_Type_Clause                        |
3281
3282                --  Freeze entity behaves like a declaration or statement
3283
3284                N_Freeze_Entity
3285             =>
3286                --  Do not insert here if the item is not a list member (this
3287                --  happens for example with a triggering statement, and the
3288                --  proper approach is to insert before the entire select).
3289
3290                if not Is_List_Member (P) then
3291                   null;
3292
3293                --  Do not insert if parent of P is an N_Component_Association
3294                --  node (i.e. we are in the context of an N_Aggregate or
3295                --  N_Extension_Aggregate node. In this case we want to insert
3296                --  before the entire aggregate.
3297
3298                elsif Nkind (Parent (P)) = N_Component_Association then
3299                   null;
3300
3301                --  Do not insert if the parent of P is either an N_Variant node
3302                --  or an N_Record_Definition node, meaning in either case that
3303                --  P is a member of a component list, and that therefore the
3304                --  actions should be inserted outside the complete record
3305                --  declaration.
3306
3307                elsif Nkind (Parent (P)) = N_Variant
3308                  or else Nkind (Parent (P)) = N_Record_Definition
3309                then
3310                   null;
3311
3312                --  Do not insert freeze nodes within the loop generated for
3313                --  an aggregate, because they may be elaborated too late for
3314                --  subsequent use in the back end: within a package spec the
3315                --  loop is part of the elaboration procedure and is only
3316                --  elaborated during the second pass.
3317
3318                --  If the loop comes from source, or the entity is local to the
3319                --  loop itself it must remain within.
3320
3321                elsif Nkind (Parent (P)) = N_Loop_Statement
3322                  and then not Comes_From_Source (Parent (P))
3323                  and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
3324                  and then
3325                    Scope (Entity (First (Ins_Actions))) /= Current_Scope
3326                then
3327                   null;
3328
3329                --  Otherwise we can go ahead and do the insertion
3330
3331                elsif P = Wrapped_Node then
3332                   Store_Before_Actions_In_Scope (Ins_Actions);
3333                   return;
3334
3335                else
3336                   Insert_List_Before_And_Analyze (P, Ins_Actions);
3337                   return;
3338                end if;
3339
3340             --  A special case, N_Raise_xxx_Error can act either as a statement
3341             --  or a subexpression. We tell the difference by looking at the
3342             --  Etype. It is set to Standard_Void_Type in the statement case.
3343
3344             when
3345                N_Raise_xxx_Error =>
3346                   if Etype (P) = Standard_Void_Type then
3347                      if  P = Wrapped_Node then
3348                         Store_Before_Actions_In_Scope (Ins_Actions);
3349                      else
3350                         Insert_List_Before_And_Analyze (P, Ins_Actions);
3351                      end if;
3352
3353                      return;
3354
3355                   --  In the subexpression case, keep climbing
3356
3357                   else
3358                      null;
3359                   end if;
3360
3361             --  If a component association appears within a loop created for
3362             --  an array aggregate, attach the actions to the association so
3363             --  they can be subsequently inserted within the loop. For other
3364             --  component associations insert outside of the aggregate. For
3365             --  an association that will generate a loop, its Loop_Actions
3366             --  attribute is already initialized (see exp_aggr.adb).
3367
3368             --  The list of loop_actions can in turn generate additional ones,
3369             --  that are inserted before the associated node. If the associated
3370             --  node is outside the aggregate, the new actions are collected
3371             --  at the end of the loop actions, to respect the order in which
3372             --  they are to be elaborated.
3373
3374             when
3375                N_Component_Association =>
3376                   if Nkind (Parent (P)) = N_Aggregate
3377                     and then Present (Loop_Actions (P))
3378                   then
3379                      if Is_Empty_List (Loop_Actions (P)) then
3380                         Set_Loop_Actions (P, Ins_Actions);
3381                         Analyze_List (Ins_Actions);
3382
3383                      else
3384                         declare
3385                            Decl : Node_Id;
3386
3387                         begin
3388                            --  Check whether these actions were generated by a
3389                            --  declaration that is part of the loop_ actions
3390                            --  for the component_association.
3391
3392                            Decl := Assoc_Node;
3393                            while Present (Decl) loop
3394                               exit when Parent (Decl) = P
3395                                 and then Is_List_Member (Decl)
3396                                 and then
3397                                   List_Containing (Decl) = Loop_Actions (P);
3398                               Decl := Parent (Decl);
3399                            end loop;
3400
3401                            if Present (Decl) then
3402                               Insert_List_Before_And_Analyze
3403                                 (Decl, Ins_Actions);
3404                            else
3405                               Insert_List_After_And_Analyze
3406                                 (Last (Loop_Actions (P)), Ins_Actions);
3407                            end if;
3408                         end;
3409                      end if;
3410
3411                      return;
3412
3413                   else
3414                      null;
3415                   end if;
3416
3417             --  Another special case, an attribute denoting a procedure call
3418
3419             when
3420                N_Attribute_Reference =>
3421                   if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
3422                      if P = Wrapped_Node then
3423                         Store_Before_Actions_In_Scope (Ins_Actions);
3424                      else
3425                         Insert_List_Before_And_Analyze (P, Ins_Actions);
3426                      end if;
3427
3428                      return;
3429
3430                   --  In the subexpression case, keep climbing
3431
3432                   else
3433                      null;
3434                   end if;
3435
3436             --  A contract node should not belong to the tree
3437
3438             when N_Contract =>
3439                raise Program_Error;
3440
3441             --  For all other node types, keep climbing tree
3442
3443             when
3444                N_Abortable_Part                         |
3445                N_Accept_Alternative                     |
3446                N_Access_Definition                      |
3447                N_Access_Function_Definition             |
3448                N_Access_Procedure_Definition            |
3449                N_Access_To_Object_Definition            |
3450                N_Aggregate                              |
3451                N_Allocator                              |
3452                N_Aspect_Specification                   |
3453                N_Case_Expression                        |
3454                N_Case_Statement_Alternative             |
3455                N_Character_Literal                      |
3456                N_Compilation_Unit                       |
3457                N_Compilation_Unit_Aux                   |
3458                N_Component_Clause                       |
3459                N_Component_Declaration                  |
3460                N_Component_Definition                   |
3461                N_Component_List                         |
3462                N_Constrained_Array_Definition           |
3463                N_Decimal_Fixed_Point_Definition         |
3464                N_Defining_Character_Literal             |
3465                N_Defining_Identifier                    |
3466                N_Defining_Operator_Symbol               |
3467                N_Defining_Program_Unit_Name             |
3468                N_Delay_Alternative                      |
3469                N_Delta_Constraint                       |
3470                N_Derived_Type_Definition                |
3471                N_Designator                             |
3472                N_Digits_Constraint                      |
3473                N_Discriminant_Association               |
3474                N_Discriminant_Specification             |
3475                N_Empty                                  |
3476                N_Entry_Body_Formal_Part                 |
3477                N_Entry_Call_Alternative                 |
3478                N_Entry_Declaration                      |
3479                N_Entry_Index_Specification              |
3480                N_Enumeration_Type_Definition            |
3481                N_Error                                  |
3482                N_Exception_Handler                      |
3483                N_Expanded_Name                          |
3484                N_Explicit_Dereference                   |
3485                N_Extension_Aggregate                    |
3486                N_Floating_Point_Definition              |
3487                N_Formal_Decimal_Fixed_Point_Definition  |
3488                N_Formal_Derived_Type_Definition         |
3489                N_Formal_Discrete_Type_Definition        |
3490                N_Formal_Floating_Point_Definition       |
3491                N_Formal_Modular_Type_Definition         |
3492                N_Formal_Ordinary_Fixed_Point_Definition |
3493                N_Formal_Package_Declaration             |
3494                N_Formal_Private_Type_Definition         |
3495                N_Formal_Incomplete_Type_Definition      |
3496                N_Formal_Signed_Integer_Type_Definition  |
3497                N_Function_Call                          |
3498                N_Function_Specification                 |
3499                N_Generic_Association                    |
3500                N_Handled_Sequence_Of_Statements         |
3501                N_Identifier                             |
3502                N_In                                     |
3503                N_Index_Or_Discriminant_Constraint       |
3504                N_Indexed_Component                      |
3505                N_Integer_Literal                        |
3506                N_Iterator_Specification                 |
3507                N_Itype_Reference                        |
3508                N_Label                                  |
3509                N_Loop_Parameter_Specification           |
3510                N_Mod_Clause                             |
3511                N_Modular_Type_Definition                |
3512                N_Not_In                                 |
3513                N_Null                                   |
3514                N_Op_Abs                                 |
3515                N_Op_Add                                 |
3516                N_Op_And                                 |
3517                N_Op_Concat                              |
3518                N_Op_Divide                              |
3519                N_Op_Eq                                  |
3520                N_Op_Expon                               |
3521                N_Op_Ge                                  |
3522                N_Op_Gt                                  |
3523                N_Op_Le                                  |
3524                N_Op_Lt                                  |
3525                N_Op_Minus                               |
3526                N_Op_Mod                                 |
3527                N_Op_Multiply                            |
3528                N_Op_Ne                                  |
3529                N_Op_Not                                 |
3530                N_Op_Or                                  |
3531                N_Op_Plus                                |
3532                N_Op_Rem                                 |
3533                N_Op_Rotate_Left                         |
3534                N_Op_Rotate_Right                        |
3535                N_Op_Shift_Left                          |
3536                N_Op_Shift_Right                         |
3537                N_Op_Shift_Right_Arithmetic              |
3538                N_Op_Subtract                            |
3539                N_Op_Xor                                 |
3540                N_Operator_Symbol                        |
3541                N_Ordinary_Fixed_Point_Definition        |
3542                N_Others_Choice                          |
3543                N_Package_Specification                  |
3544                N_Parameter_Association                  |
3545                N_Parameter_Specification                |
3546                N_Pop_Constraint_Error_Label             |
3547                N_Pop_Program_Error_Label                |
3548                N_Pop_Storage_Error_Label                |
3549                N_Pragma_Argument_Association            |
3550                N_Procedure_Specification                |
3551                N_Protected_Definition                   |
3552                N_Push_Constraint_Error_Label            |
3553                N_Push_Program_Error_Label               |
3554                N_Push_Storage_Error_Label               |
3555                N_Qualified_Expression                   |
3556                N_Quantified_Expression                  |
3557                N_Range                                  |
3558                N_Range_Constraint                       |
3559                N_Real_Literal                           |
3560                N_Real_Range_Specification               |
3561                N_Record_Definition                      |
3562                N_Reference                              |
3563                N_SCIL_Dispatch_Table_Tag_Init           |
3564                N_SCIL_Dispatching_Call                  |
3565                N_SCIL_Membership_Test                   |
3566                N_Selected_Component                     |
3567                N_Signed_Integer_Type_Definition         |
3568                N_Single_Protected_Declaration           |
3569                N_Slice                                  |
3570                N_String_Literal                         |
3571                N_Subprogram_Info                        |
3572                N_Subtype_Indication                     |
3573                N_Subunit                                |
3574                N_Task_Definition                        |
3575                N_Terminate_Alternative                  |
3576                N_Triggering_Alternative                 |
3577                N_Type_Conversion                        |
3578                N_Unchecked_Expression                   |
3579                N_Unchecked_Type_Conversion              |
3580                N_Unconstrained_Array_Definition         |
3581                N_Unused_At_End                          |
3582                N_Unused_At_Start                        |
3583                N_Variant                                |
3584                N_Variant_Part                           |
3585                N_Validate_Unchecked_Conversion          |
3586                N_With_Clause
3587             =>
3588                null;
3589
3590          end case;
3591
3592          --  Make sure that inserted actions stay in the transient scope
3593
3594          if P = Wrapped_Node then
3595             Store_Before_Actions_In_Scope (Ins_Actions);
3596             return;
3597          end if;
3598
3599          --  If we fall through above tests, keep climbing tree
3600
3601          N := P;
3602
3603          if Nkind (Parent (N)) = N_Subunit then
3604
3605             --  This is the proper body corresponding to a stub. Insertion must
3606             --  be done at the point of the stub, which is in the declarative
3607             --  part of the parent unit.
3608
3609             P := Corresponding_Stub (Parent (N));
3610
3611          else
3612             P := Parent (N);
3613          end if;
3614       end loop;
3615    end Insert_Actions;
3616
3617    --  Version with check(s) suppressed
3618
3619    procedure Insert_Actions
3620      (Assoc_Node  : Node_Id;
3621       Ins_Actions : List_Id;
3622       Suppress    : Check_Id)
3623    is
3624    begin
3625       if Suppress = All_Checks then
3626          declare
3627             Svg : constant Suppress_Array := Scope_Suppress;
3628          begin
3629             Scope_Suppress := (others => True);
3630             Insert_Actions (Assoc_Node, Ins_Actions);
3631             Scope_Suppress := Svg;
3632          end;
3633
3634       else
3635          declare
3636             Svg : constant Boolean := Scope_Suppress (Suppress);
3637          begin
3638             Scope_Suppress (Suppress) := True;
3639             Insert_Actions (Assoc_Node, Ins_Actions);
3640             Scope_Suppress (Suppress) := Svg;
3641          end;
3642       end if;
3643    end Insert_Actions;
3644
3645    --------------------------
3646    -- Insert_Actions_After --
3647    --------------------------
3648
3649    procedure Insert_Actions_After
3650      (Assoc_Node  : Node_Id;
3651       Ins_Actions : List_Id)
3652    is
3653    begin
3654       if Scope_Is_Transient
3655         and then Assoc_Node = Node_To_Be_Wrapped
3656       then
3657          Store_After_Actions_In_Scope (Ins_Actions);
3658       else
3659          Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
3660       end if;
3661    end Insert_Actions_After;
3662
3663    ---------------------------------
3664    -- Insert_Library_Level_Action --
3665    ---------------------------------
3666
3667    procedure Insert_Library_Level_Action (N : Node_Id) is
3668       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3669
3670    begin
3671       Push_Scope (Cunit_Entity (Main_Unit));
3672       --  ??? should this be Current_Sem_Unit instead of Main_Unit?
3673
3674       if No (Actions (Aux)) then
3675          Set_Actions (Aux, New_List (N));
3676       else
3677          Append (N, Actions (Aux));
3678       end if;
3679
3680       Analyze (N);
3681       Pop_Scope;
3682    end Insert_Library_Level_Action;
3683
3684    ----------------------------------
3685    -- Insert_Library_Level_Actions --
3686    ----------------------------------
3687
3688    procedure Insert_Library_Level_Actions (L : List_Id) is
3689       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3690
3691    begin
3692       if Is_Non_Empty_List (L) then
3693          Push_Scope (Cunit_Entity (Main_Unit));
3694          --  ??? should this be Current_Sem_Unit instead of Main_Unit?
3695
3696          if No (Actions (Aux)) then
3697             Set_Actions (Aux, L);
3698             Analyze_List (L);
3699          else
3700             Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
3701          end if;
3702
3703          Pop_Scope;
3704       end if;
3705    end Insert_Library_Level_Actions;
3706
3707    ----------------------
3708    -- Inside_Init_Proc --
3709    ----------------------
3710
3711    function Inside_Init_Proc return Boolean is
3712       S : Entity_Id;
3713
3714    begin
3715       S := Current_Scope;
3716       while Present (S)
3717         and then S /= Standard_Standard
3718       loop
3719          if Is_Init_Proc (S) then
3720             return True;
3721          else
3722             S := Scope (S);
3723          end if;
3724       end loop;
3725
3726       return False;
3727    end Inside_Init_Proc;
3728
3729    ----------------------------
3730    -- Is_All_Null_Statements --
3731    ----------------------------
3732
3733    function Is_All_Null_Statements (L : List_Id) return Boolean is
3734       Stm : Node_Id;
3735
3736    begin
3737       Stm := First (L);
3738       while Present (Stm) loop
3739          if Nkind (Stm) /= N_Null_Statement then
3740             return False;
3741          end if;
3742
3743          Next (Stm);
3744       end loop;
3745
3746       return True;
3747    end Is_All_Null_Statements;
3748
3749    ------------------------------
3750    -- Is_Finalizable_Transient --
3751    ------------------------------
3752
3753    function Is_Finalizable_Transient
3754      (Decl     : Node_Id;
3755       Rel_Node : Node_Id) return Boolean
3756    is
3757       Obj_Id  : constant Entity_Id := Defining_Identifier (Decl);
3758       Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
3759       Desig   : Entity_Id := Obj_Typ;
3760
3761       function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
3762       --  Determine whether transient object Trans_Id is initialized either
3763       --  by a function call which returns an access type or simply renames
3764       --  another pointer.
3765
3766       function Initialized_By_Aliased_BIP_Func_Call
3767         (Trans_Id : Entity_Id) return Boolean;
3768       --  Determine whether transient object Trans_Id is initialized by a
3769       --  build-in-place function call where the BIPalloc parameter is of
3770       --  value 1 and BIPaccess is not null. This case creates an aliasing
3771       --  between the returned value and the value denoted by BIPaccess.
3772
3773       function Is_Aliased
3774         (Trans_Id   : Entity_Id;
3775          First_Stmt : Node_Id) return Boolean;
3776       --  Determine whether transient object Trans_Id has been renamed or
3777       --  aliased through 'reference in the statement list starting from
3778       --  First_Stmt.
3779
3780       function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
3781       --  Determine whether transient object Trans_Id is allocated on the heap
3782
3783       ---------------------------
3784       -- Initialized_By_Access --
3785       ---------------------------
3786
3787       function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
3788          Expr : constant Node_Id := Expression (Parent (Trans_Id));
3789
3790       begin
3791          return
3792            Present (Expr)
3793              and then Nkind (Expr) /= N_Reference
3794              and then Is_Access_Type (Etype (Expr));
3795       end Initialized_By_Access;
3796
3797       ------------------------------------------
3798       -- Initialized_By_Aliased_BIP_Func_Call --
3799       ------------------------------------------
3800
3801       function Initialized_By_Aliased_BIP_Func_Call
3802         (Trans_Id : Entity_Id) return Boolean
3803       is
3804          Call : Node_Id := Expression (Parent (Trans_Id));
3805
3806       begin
3807          --  Build-in-place calls usually appear in 'reference format
3808
3809          if Nkind (Call) = N_Reference then
3810             Call := Prefix (Call);
3811          end if;
3812
3813          if Is_Build_In_Place_Function_Call (Call) then
3814             declare
3815                Access_Nam : Name_Id := No_Name;
3816                Access_OK  : Boolean := False;
3817                Actual     : Node_Id;
3818                Alloc_Nam  : Name_Id := No_Name;
3819                Alloc_OK   : Boolean := False;
3820                Formal     : Node_Id;
3821                Func_Id    : Entity_Id;
3822                Param      : Node_Id;
3823
3824             begin
3825                --  Examine all parameter associations of the function call
3826
3827                Param := First (Parameter_Associations (Call));
3828                while Present (Param) loop
3829                   if Nkind (Param) = N_Parameter_Association
3830                     and then Nkind (Selector_Name (Param)) = N_Identifier
3831                   then
3832                      Actual := Explicit_Actual_Parameter (Param);
3833                      Formal := Selector_Name (Param);
3834
3835                      --  Construct the names of formals BIPaccess and BIPalloc
3836                      --  using the function name retrieved from an arbitrary
3837                      --  formal.
3838
3839                      if Access_Nam = No_Name
3840                        and then Alloc_Nam = No_Name
3841                        and then Present (Entity (Formal))
3842                      then
3843                         Func_Id := Scope (Entity (Formal));
3844
3845                         Access_Nam :=
3846                           New_External_Name (Chars (Func_Id),
3847                             BIP_Formal_Suffix (BIP_Object_Access));
3848
3849                         Alloc_Nam :=
3850                           New_External_Name (Chars (Func_Id),
3851                             BIP_Formal_Suffix (BIP_Alloc_Form));
3852                      end if;
3853
3854                      --  A match for BIPaccess => Temp has been found
3855
3856                      if Chars (Formal) = Access_Nam
3857                        and then Nkind (Actual) /= N_Null
3858                      then
3859                         Access_OK := True;
3860                      end if;
3861
3862                      --  A match for BIPalloc => 1 has been found
3863
3864                      if Chars (Formal) = Alloc_Nam
3865                        and then Nkind (Actual) = N_Integer_Literal
3866                        and then Intval (Actual) = Uint_1
3867                      then
3868                         Alloc_OK := True;
3869                      end if;
3870                   end if;
3871
3872                   Next (Param);
3873                end loop;
3874
3875                return Access_OK and then Alloc_OK;
3876             end;
3877          end if;
3878
3879          return False;
3880       end Initialized_By_Aliased_BIP_Func_Call;
3881
3882       ----------------
3883       -- Is_Aliased --
3884       ----------------
3885
3886       function Is_Aliased
3887         (Trans_Id   : Entity_Id;
3888          First_Stmt : Node_Id) return Boolean
3889       is
3890          function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
3891          --  Given an object renaming declaration, retrieve the entity of the
3892          --  renamed name. Return Empty if the renamed name is anything other
3893          --  than a variable or a constant.
3894
3895          -------------------------
3896          -- Find_Renamed_Object --
3897          -------------------------
3898
3899          function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
3900             Ren_Obj : Node_Id := Empty;
3901
3902             function Find_Object (N : Node_Id) return Traverse_Result;
3903             --  Try to detect an object which is either a constant or a
3904             --  variable.
3905
3906             -----------------
3907             -- Find_Object --
3908             -----------------
3909
3910             function Find_Object (N : Node_Id) return Traverse_Result is
3911             begin
3912                --  Stop the search once a constant or a variable has been
3913                --  detected.
3914
3915                if Nkind (N) = N_Identifier
3916                  and then Present (Entity (N))
3917                  and then Ekind_In (Entity (N), E_Constant, E_Variable)
3918                then
3919                   Ren_Obj := Entity (N);
3920                   return Abandon;
3921                end if;
3922
3923                return OK;
3924             end Find_Object;
3925
3926             procedure Search is new Traverse_Proc (Find_Object);
3927
3928             --  Local variables
3929
3930             Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
3931
3932          --  Start of processing for Find_Renamed_Object
3933
3934          begin
3935             --  Actions related to dispatching calls may appear as renamings of
3936             --  tags. Do not process this type of renaming because it does not
3937             --  use the actual value of the object.
3938
3939             if not Is_RTE (Typ, RE_Tag_Ptr) then
3940                Search (Name (Ren_Decl));
3941             end if;
3942
3943             return Ren_Obj;
3944          end Find_Renamed_Object;
3945
3946          --  Local variables
3947
3948          Expr    : Node_Id;
3949          Ren_Obj : Entity_Id;
3950          Stmt    : Node_Id;
3951
3952       --  Start of processing for Is_Aliased
3953
3954       begin
3955          Stmt := First_Stmt;
3956          while Present (Stmt) loop
3957             if Nkind (Stmt) = N_Object_Declaration then
3958                Expr := Expression (Stmt);
3959
3960                if Present (Expr)
3961                  and then Nkind (Expr) = N_Reference
3962                  and then Nkind (Prefix (Expr)) = N_Identifier
3963                  and then Entity (Prefix (Expr)) = Trans_Id
3964                then
3965                   return True;
3966                end if;
3967
3968             elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
3969                Ren_Obj := Find_Renamed_Object (Stmt);
3970
3971                if Present (Ren_Obj)
3972                  and then Ren_Obj = Trans_Id
3973                then
3974                   return True;
3975                end if;
3976             end if;
3977
3978             Next (Stmt);
3979          end loop;
3980
3981          return False;
3982       end Is_Aliased;
3983
3984       ------------------
3985       -- Is_Allocated --
3986       ------------------
3987
3988       function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
3989          Expr : constant Node_Id := Expression (Parent (Trans_Id));
3990       begin
3991          return
3992            Is_Access_Type (Etype (Trans_Id))
3993              and then Present (Expr)
3994              and then Nkind (Expr) = N_Allocator;
3995       end Is_Allocated;
3996
3997    --  Start of processing for Is_Finalizable_Transient
3998
3999    begin
4000       --  Handle access types
4001
4002       if Is_Access_Type (Desig) then
4003          Desig := Available_View (Designated_Type (Desig));
4004       end if;
4005
4006       return
4007         Ekind_In (Obj_Id, E_Constant, E_Variable)
4008           and then Needs_Finalization (Desig)
4009           and then Requires_Transient_Scope (Desig)
4010           and then Nkind (Rel_Node) /= N_Simple_Return_Statement
4011
4012           --  Do not consider renamed or 'reference-d transient objects because
4013           --  the act of renaming extends the object's lifetime.
4014
4015           and then not Is_Aliased (Obj_Id, Decl)
4016
4017           --  Do not consider transient objects allocated on the heap since
4018           --  they are attached to a finalization master.
4019
4020           and then not Is_Allocated (Obj_Id)
4021
4022           --  If the transient object is a pointer, check that it is not
4023           --  initialized by a function which returns a pointer or acts as a
4024           --  renaming of another pointer.
4025
4026           and then
4027             (not Is_Access_Type (Obj_Typ)
4028                or else not Initialized_By_Access (Obj_Id))
4029
4030           --  Do not consider transient objects which act as indirect aliases
4031           --  of build-in-place function results.
4032
4033           and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
4034
4035           --  Do not consider conversions of tags to class-wide types
4036
4037           and then not Is_Tag_To_CW_Conversion (Obj_Id);
4038    end Is_Finalizable_Transient;
4039
4040    ---------------------------------
4041    -- Is_Fully_Repped_Tagged_Type --
4042    ---------------------------------
4043
4044    function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
4045       U    : constant Entity_Id := Underlying_Type (T);
4046       Comp : Entity_Id;
4047
4048    begin
4049       if No (U) or else not Is_Tagged_Type (U) then
4050          return False;
4051       elsif Has_Discriminants (U) then
4052          return False;
4053       elsif not Has_Specified_Layout (U) then
4054          return False;
4055       end if;
4056
4057       --  Here we have a tagged type, see if it has any unlayed out fields
4058       --  other than a possible tag and parent fields. If so, we return False.
4059
4060       Comp := First_Component (U);
4061       while Present (Comp) loop
4062          if not Is_Tag (Comp)
4063            and then Chars (Comp) /= Name_uParent
4064            and then No (Component_Clause (Comp))
4065          then
4066             return False;
4067          else
4068             Next_Component (Comp);
4069          end if;
4070       end loop;
4071
4072       --  All components are layed out
4073
4074       return True;
4075    end Is_Fully_Repped_Tagged_Type;
4076
4077    ----------------------------------
4078    -- Is_Library_Level_Tagged_Type --
4079    ----------------------------------
4080
4081    function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
4082    begin
4083       return Is_Tagged_Type (Typ)
4084         and then Is_Library_Level_Entity (Typ);
4085    end Is_Library_Level_Tagged_Type;
4086
4087    ----------------------------------
4088    -- Is_Null_Access_BIP_Func_Call --
4089    ----------------------------------
4090
4091    function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
4092       Call : Node_Id := Expr;
4093
4094    begin
4095       --  Build-in-place calls usually appear in 'reference format
4096
4097       if Nkind (Call) = N_Reference then
4098          Call := Prefix (Call);
4099       end if;
4100
4101       if Nkind_In (Call, N_Qualified_Expression,
4102                          N_Unchecked_Type_Conversion)
4103       then
4104          Call := Expression (Call);
4105       end if;
4106
4107       if Is_Build_In_Place_Function_Call (Call) then
4108          declare
4109             Access_Nam : Name_Id := No_Name;
4110             Actual     : Node_Id;
4111             Param      : Node_Id;
4112             Formal     : Node_Id;
4113
4114          begin
4115             --  Examine all parameter associations of the function call
4116
4117             Param := First (Parameter_Associations (Call));
4118             while Present (Param) loop
4119                if Nkind (Param) = N_Parameter_Association
4120                  and then Nkind (Selector_Name (Param)) = N_Identifier
4121                then
4122                   Formal := Selector_Name (Param);
4123                   Actual := Explicit_Actual_Parameter (Param);
4124
4125                   --  Construct the name of formal BIPaccess. It is much easier
4126                   --  to extract the name of the function using an arbitrary
4127                   --  formal's scope rather than the Name field of Call.
4128
4129                   if Access_Nam = No_Name
4130                     and then Present (Entity (Formal))
4131                   then
4132                      Access_Nam :=
4133                        New_External_Name
4134                          (Chars (Scope (Entity (Formal))),
4135                           BIP_Formal_Suffix (BIP_Object_Access));
4136                   end if;
4137
4138                   --  A match for BIPaccess => null has been found
4139
4140                   if Chars (Formal) = Access_Nam
4141                     and then Nkind (Actual) = N_Null
4142                   then
4143                      return True;
4144                   end if;
4145                end if;
4146
4147                Next (Param);
4148             end loop;
4149          end;
4150       end if;
4151
4152       return False;
4153    end Is_Null_Access_BIP_Func_Call;
4154
4155    --------------------------
4156    -- Is_Non_BIP_Func_Call --
4157    --------------------------
4158
4159    function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
4160    begin
4161       --  The expected call is of the format
4162       --
4163       --    Func_Call'reference
4164
4165       return
4166         Nkind (Expr) = N_Reference
4167           and then Nkind (Prefix (Expr)) = N_Function_Call
4168           and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
4169    end Is_Non_BIP_Func_Call;
4170
4171    ----------------------------------
4172    -- Is_Possibly_Unaligned_Object --
4173    ----------------------------------
4174
4175    function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
4176       T  : constant Entity_Id := Etype (N);
4177
4178    begin
4179       --  If renamed object, apply test to underlying object
4180
4181       if Is_Entity_Name (N)
4182         and then Is_Object (Entity (N))
4183         and then Present (Renamed_Object (Entity (N)))
4184       then
4185          return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
4186       end if;
4187
4188       --  Tagged and controlled types and aliased types are always aligned, as
4189       --  are concurrent types.
4190
4191       if Is_Aliased (T)
4192         or else Has_Controlled_Component (T)
4193         or else Is_Concurrent_Type (T)
4194         or else Is_Tagged_Type (T)
4195         or else Is_Controlled (T)
4196       then
4197          return False;
4198       end if;
4199
4200       --  If this is an element of a packed array, may be unaligned
4201
4202       if Is_Ref_To_Bit_Packed_Array (N) then
4203          return True;
4204       end if;
4205
4206       --  Case of component reference
4207
4208       if Nkind (N) = N_Selected_Component then
4209          declare
4210             P : constant Node_Id   := Prefix (N);
4211             C : constant Entity_Id := Entity (Selector_Name (N));
4212             M : Nat;
4213             S : Nat;
4214
4215          begin
4216             --  If component reference is for an array with non-static bounds,
4217             --  then it is always aligned: we can only process unaligned arrays
4218             --  with static bounds (more precisely compile time known bounds).
4219
4220             if Is_Array_Type (T)
4221               and then not Compile_Time_Known_Bounds (T)
4222             then
4223                return False;
4224             end if;
4225
4226             --  If component is aliased, it is definitely properly aligned
4227
4228             if Is_Aliased (C) then
4229                return False;
4230             end if;
4231
4232             --  If component is for a type implemented as a scalar, and the
4233             --  record is packed, and the component is other than the first
4234             --  component of the record, then the component may be unaligned.
4235
4236             if Is_Packed (Etype (P))
4237               and then Represented_As_Scalar (Etype (C))
4238               and then First_Entity (Scope (C)) /= C
4239             then
4240                return True;
4241             end if;
4242
4243             --  Compute maximum possible alignment for T
4244
4245             --  If alignment is known, then that settles things
4246
4247             if Known_Alignment (T) then
4248                M := UI_To_Int (Alignment (T));
4249
4250             --  If alignment is not known, tentatively set max alignment
4251
4252             else
4253                M := Ttypes.Maximum_Alignment;
4254
4255                --  We can reduce this if the Esize is known since the default
4256                --  alignment will never be more than the smallest power of 2
4257                --  that does not exceed this Esize value.
4258
4259                if Known_Esize (T) then
4260                   S := UI_To_Int (Esize (T));
4261
4262                   while (M / 2) >= S loop
4263                      M := M / 2;
4264                   end loop;
4265                end if;
4266             end if;
4267
4268             --  The following code is historical, it used to be present but it
4269             --  is too cautious, because the front-end does not know the proper
4270             --  default alignments for the target. Also, if the alignment is
4271             --  not known, the front end can't know in any case! If a copy is
4272             --  needed, the back-end will take care of it. This whole section
4273             --  including this comment can be removed later ???
4274
4275             --  If the component reference is for a record that has a specified
4276             --  alignment, and we either know it is too small, or cannot tell,
4277             --  then the component may be unaligned.
4278
4279             --  What is the following commented out code ???
4280
4281             --  if Known_Alignment (Etype (P))
4282             --    and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
4283             --    and then M > Alignment (Etype (P))
4284             --  then
4285             --     return True;
4286             --  end if;
4287
4288             --  Case of component clause present which may specify an
4289             --  unaligned position.
4290
4291             if Present (Component_Clause (C)) then
4292
4293                --  Otherwise we can do a test to make sure that the actual
4294                --  start position in the record, and the length, are both
4295                --  consistent with the required alignment. If not, we know
4296                --  that we are unaligned.
4297
4298                declare
4299                   Align_In_Bits : constant Nat := M * System_Storage_Unit;
4300                begin
4301                   if Component_Bit_Offset (C) mod Align_In_Bits /= 0
4302                     or else Esize (C) mod Align_In_Bits /= 0
4303                   then
4304                      return True;
4305                   end if;
4306                end;
4307             end if;
4308
4309             --  Otherwise, for a component reference, test prefix
4310
4311             return Is_Possibly_Unaligned_Object (P);
4312          end;
4313
4314       --  If not a component reference, must be aligned
4315
4316       else
4317          return False;
4318       end if;
4319    end Is_Possibly_Unaligned_Object;
4320
4321    ---------------------------------
4322    -- Is_Possibly_Unaligned_Slice --
4323    ---------------------------------
4324
4325    function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
4326    begin
4327       --  Go to renamed object
4328
4329       if Is_Entity_Name (N)
4330         and then Is_Object (Entity (N))
4331         and then Present (Renamed_Object (Entity (N)))
4332       then
4333          return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
4334       end if;
4335
4336       --  The reference must be a slice
4337
4338       if Nkind (N) /= N_Slice then
4339          return False;
4340       end if;
4341
4342       --  Always assume the worst for a nested record component with a
4343       --  component clause, which gigi/gcc does not appear to handle well.
4344       --  It is not clear why this special test is needed at all ???
4345
4346       if Nkind (Prefix (N)) = N_Selected_Component
4347         and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
4348         and then
4349           Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
4350       then
4351          return True;
4352       end if;
4353
4354       --  We only need to worry if the target has strict alignment
4355
4356       if not Target_Strict_Alignment then
4357          return False;
4358       end if;
4359
4360       --  If it is a slice, then look at the array type being sliced
4361
4362       declare
4363          Sarr : constant Node_Id := Prefix (N);
4364          --  Prefix of the slice, i.e. the array being sliced
4365
4366          Styp : constant Entity_Id := Etype (Prefix (N));
4367          --  Type of the array being sliced
4368
4369          Pref : Node_Id;
4370          Ptyp : Entity_Id;
4371
4372       begin
4373          --  The problems arise if the array object that is being sliced
4374          --  is a component of a record or array, and we cannot guarantee
4375          --  the alignment of the array within its containing object.
4376
4377          --  To investigate this, we look at successive prefixes to see
4378          --  if we have a worrisome indexed or selected component.
4379
4380          Pref := Sarr;
4381          loop
4382             --  Case of array is part of an indexed component reference
4383
4384             if Nkind (Pref) = N_Indexed_Component then
4385                Ptyp := Etype (Prefix (Pref));
4386
4387                --  The only problematic case is when the array is packed, in
4388                --  which case we really know nothing about the alignment of
4389                --  individual components.
4390
4391                if Is_Bit_Packed_Array (Ptyp) then
4392                   return True;
4393                end if;
4394
4395             --  Case of array is part of a selected component reference
4396
4397             elsif Nkind (Pref) = N_Selected_Component then
4398                Ptyp := Etype (Prefix (Pref));
4399
4400                --  We are definitely in trouble if the record in question
4401                --  has an alignment, and either we know this alignment is
4402                --  inconsistent with the alignment of the slice, or we don't
4403                --  know what the alignment of the slice should be.
4404
4405                if Known_Alignment (Ptyp)
4406                  and then (Unknown_Alignment (Styp)
4407                              or else Alignment (Styp) > Alignment (Ptyp))
4408                then
4409                   return True;
4410                end if;
4411
4412                --  We are in potential trouble if the record type is packed.
4413                --  We could special case when we know that the array is the
4414                --  first component, but that's not such a simple case ???
4415
4416                if Is_Packed (Ptyp) then
4417                   return True;
4418                end if;
4419
4420                --  We are in trouble if there is a component clause, and
4421                --  either we do not know the alignment of the slice, or
4422                --  the alignment of the slice is inconsistent with the
4423                --  bit position specified by the component clause.
4424
4425                declare
4426                   Field : constant Entity_Id := Entity (Selector_Name (Pref));
4427                begin
4428                   if Present (Component_Clause (Field))
4429                     and then
4430                       (Unknown_Alignment (Styp)
4431                         or else
4432                          (Component_Bit_Offset (Field) mod
4433                            (System_Storage_Unit * Alignment (Styp))) /= 0)
4434                   then
4435                      return True;
4436                   end if;
4437                end;
4438
4439             --  For cases other than selected or indexed components we know we
4440             --  are OK, since no issues arise over alignment.
4441
4442             else
4443                return False;
4444             end if;
4445
4446             --  We processed an indexed component or selected component
4447             --  reference that looked safe, so keep checking prefixes.
4448
4449             Pref := Prefix (Pref);
4450          end loop;
4451       end;
4452    end Is_Possibly_Unaligned_Slice;
4453
4454    -------------------------------
4455    -- Is_Related_To_Func_Return --
4456    -------------------------------
4457
4458    function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
4459       Expr : constant Node_Id := Related_Expression (Id);
4460    begin
4461       return
4462         Present (Expr)
4463           and then Nkind (Expr) = N_Explicit_Dereference
4464           and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
4465    end Is_Related_To_Func_Return;
4466
4467    --------------------------------
4468    -- Is_Ref_To_Bit_Packed_Array --
4469    --------------------------------
4470
4471    function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
4472       Result : Boolean;
4473       Expr   : Node_Id;
4474
4475    begin
4476       if Is_Entity_Name (N)
4477         and then Is_Object (Entity (N))
4478         and then Present (Renamed_Object (Entity (N)))
4479       then
4480          return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
4481       end if;
4482
4483       if Nkind (N) = N_Indexed_Component
4484            or else
4485          Nkind (N) = N_Selected_Component
4486       then
4487          if Is_Bit_Packed_Array (Etype (Prefix (N))) then
4488             Result := True;
4489          else
4490             Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
4491          end if;
4492
4493          if Result and then Nkind (N) = N_Indexed_Component then
4494             Expr := First (Expressions (N));
4495             while Present (Expr) loop
4496                Force_Evaluation (Expr);
4497                Next (Expr);
4498             end loop;
4499          end if;
4500
4501          return Result;
4502
4503       else
4504          return False;
4505       end if;
4506    end Is_Ref_To_Bit_Packed_Array;
4507
4508    --------------------------------
4509    -- Is_Ref_To_Bit_Packed_Slice --
4510    --------------------------------
4511
4512    function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
4513    begin
4514       if Nkind (N) = N_Type_Conversion then
4515          return Is_Ref_To_Bit_Packed_Slice (Expression (N));
4516
4517       elsif Is_Entity_Name (N)
4518         and then Is_Object (Entity (N))
4519         and then Present (Renamed_Object (Entity (N)))
4520       then
4521          return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
4522
4523       elsif Nkind (N) = N_Slice
4524         and then Is_Bit_Packed_Array (Etype (Prefix (N)))
4525       then
4526          return True;
4527
4528       elsif Nkind (N) = N_Indexed_Component
4529            or else
4530          Nkind (N) = N_Selected_Component
4531       then
4532          return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
4533
4534       else
4535          return False;
4536       end if;
4537    end Is_Ref_To_Bit_Packed_Slice;
4538
4539    -----------------------
4540    -- Is_Renamed_Object --
4541    -----------------------
4542
4543    function Is_Renamed_Object (N : Node_Id) return Boolean is
4544       Pnod : constant Node_Id   := Parent (N);
4545       Kind : constant Node_Kind := Nkind (Pnod);
4546    begin
4547       if Kind = N_Object_Renaming_Declaration then
4548          return True;
4549       elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
4550          return Is_Renamed_Object (Pnod);
4551       else
4552          return False;
4553       end if;
4554    end Is_Renamed_Object;
4555
4556    -----------------------------
4557    -- Is_Tag_To_CW_Conversion --
4558    -----------------------------
4559
4560    function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
4561       Expr : constant Node_Id := Expression (Parent (Obj_Id));
4562
4563    begin
4564       return
4565         Is_Class_Wide_Type (Etype (Obj_Id))
4566           and then Present (Expr)
4567           and then Nkind (Expr) = N_Unchecked_Type_Conversion
4568           and then Etype (Expression (Expr)) = RTE (RE_Tag);
4569    end Is_Tag_To_CW_Conversion;
4570
4571    ----------------------------
4572    -- Is_Untagged_Derivation --
4573    ----------------------------
4574
4575    function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
4576    begin
4577       return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
4578                or else
4579              (Is_Private_Type (T) and then Present (Full_View (T))
4580                and then not Is_Tagged_Type (Full_View (T))
4581                and then Is_Derived_Type (Full_View (T))
4582                and then Etype (Full_View (T)) /= T);
4583    end Is_Untagged_Derivation;
4584
4585    ---------------------------
4586    -- Is_Volatile_Reference --
4587    ---------------------------
4588
4589    function Is_Volatile_Reference (N : Node_Id) return Boolean is
4590    begin
4591       if Nkind (N) in N_Has_Etype
4592         and then Present (Etype (N))
4593         and then Treat_As_Volatile (Etype (N))
4594       then
4595          return True;
4596
4597       elsif Is_Entity_Name (N) then
4598          return Treat_As_Volatile (Entity (N));
4599
4600       elsif Nkind (N) = N_Slice then
4601          return Is_Volatile_Reference (Prefix (N));
4602
4603       elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
4604          if (Is_Entity_Name (Prefix (N))
4605                and then Has_Volatile_Components (Entity (Prefix (N))))
4606            or else (Present (Etype (Prefix (N)))
4607                       and then Has_Volatile_Components (Etype (Prefix (N))))
4608          then
4609             return True;
4610          else
4611             return Is_Volatile_Reference (Prefix (N));
4612          end if;
4613
4614       else
4615          return False;
4616       end if;
4617    end Is_Volatile_Reference;
4618
4619    --------------------------
4620    -- Is_VM_By_Copy_Actual --
4621    --------------------------
4622
4623    function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
4624    begin
4625       return VM_Target /= No_VM
4626         and then (Nkind (N) = N_Slice
4627                     or else
4628                       (Nkind (N) = N_Identifier
4629                          and then Present (Renamed_Object (Entity (N)))
4630                          and then Nkind (Renamed_Object (Entity (N)))
4631                                     = N_Slice));
4632    end Is_VM_By_Copy_Actual;
4633
4634    --------------------
4635    -- Kill_Dead_Code --
4636    --------------------
4637
4638    procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
4639       W : Boolean := Warn;
4640       --  Set False if warnings suppressed
4641
4642    begin
4643       if Present (N) then
4644          Remove_Warning_Messages (N);
4645
4646          --  Generate warning if appropriate
4647
4648          if W then
4649
4650             --  We suppress the warning if this code is under control of an
4651             --  if statement, whose condition is a simple identifier, and
4652             --  either we are in an instance, or warnings off is set for this
4653             --  identifier. The reason for killing it in the instance case is
4654             --  that it is common and reasonable for code to be deleted in
4655             --  instances for various reasons.
4656
4657             if Nkind (Parent (N)) = N_If_Statement then
4658                declare
4659                   C : constant Node_Id := Condition (Parent (N));
4660                begin
4661                   if Nkind (C) = N_Identifier
4662                     and then
4663                       (In_Instance
4664                         or else (Present (Entity (C))
4665                                    and then Has_Warnings_Off (Entity (C))))
4666                   then
4667                      W := False;
4668                   end if;
4669                end;
4670             end if;
4671
4672             --  Generate warning if not suppressed
4673
4674             if W then
4675                Error_Msg_F
4676                  ("?this code can never be executed and has been deleted!", N);
4677             end if;
4678          end if;
4679
4680          --  Recurse into block statements and bodies to process declarations
4681          --  and statements.
4682
4683          if Nkind (N) = N_Block_Statement
4684            or else Nkind (N) = N_Subprogram_Body
4685            or else Nkind (N) = N_Package_Body
4686          then
4687             Kill_Dead_Code (Declarations (N), False);
4688             Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
4689
4690             if Nkind (N) = N_Subprogram_Body then
4691                Set_Is_Eliminated (Defining_Entity (N));
4692             end if;
4693
4694          elsif Nkind (N) = N_Package_Declaration then
4695             Kill_Dead_Code (Visible_Declarations (Specification (N)));
4696             Kill_Dead_Code (Private_Declarations (Specification (N)));
4697
4698             --  ??? After this point, Delete_Tree has been called on all
4699             --  declarations in Specification (N), so references to entities
4700             --  therein look suspicious.
4701
4702             declare
4703                E : Entity_Id := First_Entity (Defining_Entity (N));
4704             begin
4705                while Present (E) loop
4706                   if Ekind (E) = E_Operator then
4707                      Set_Is_Eliminated (E);
4708                   end if;
4709
4710                   Next_Entity (E);
4711                end loop;
4712             end;
4713
4714          --  Recurse into composite statement to kill individual statements in
4715          --  particular instantiations.
4716
4717          elsif Nkind (N) = N_If_Statement then
4718             Kill_Dead_Code (Then_Statements (N));
4719             Kill_Dead_Code (Elsif_Parts (N));
4720             Kill_Dead_Code (Else_Statements (N));
4721
4722          elsif Nkind (N) = N_Loop_Statement then
4723             Kill_Dead_Code (Statements (N));
4724
4725          elsif Nkind (N) = N_Case_Statement then
4726             declare
4727                Alt : Node_Id;
4728             begin
4729                Alt := First (Alternatives (N));
4730                while Present (Alt) loop
4731                   Kill_Dead_Code (Statements (Alt));
4732                   Next (Alt);
4733                end loop;
4734             end;
4735
4736          elsif Nkind (N) = N_Case_Statement_Alternative then
4737             Kill_Dead_Code (Statements (N));
4738
4739          --  Deal with dead instances caused by deleting instantiations
4740
4741          elsif Nkind (N) in N_Generic_Instantiation then
4742             Remove_Dead_Instance (N);
4743          end if;
4744       end if;
4745    end Kill_Dead_Code;
4746
4747    --  Case where argument is a list of nodes to be killed
4748
4749    procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
4750       N : Node_Id;
4751       W : Boolean;
4752    begin
4753       W := Warn;
4754       if Is_Non_Empty_List (L) then
4755          N := First (L);
4756          while Present (N) loop
4757             Kill_Dead_Code (N, W);
4758             W := False;
4759             Next (N);
4760          end loop;
4761       end if;
4762    end Kill_Dead_Code;
4763
4764    ------------------------
4765    -- Known_Non_Negative --
4766    ------------------------
4767
4768    function Known_Non_Negative (Opnd : Node_Id) return Boolean is
4769    begin
4770       if Is_OK_Static_Expression (Opnd)
4771         and then Expr_Value (Opnd) >= 0
4772       then
4773          return True;
4774
4775       else
4776          declare
4777             Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
4778
4779          begin
4780             return
4781               Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
4782          end;
4783       end if;
4784    end Known_Non_Negative;
4785
4786    --------------------
4787    -- Known_Non_Null --
4788    --------------------
4789
4790    function Known_Non_Null (N : Node_Id) return Boolean is
4791    begin
4792       --  Checks for case where N is an entity reference
4793
4794       if Is_Entity_Name (N) and then Present (Entity (N)) then
4795          declare
4796             E   : constant Entity_Id := Entity (N);
4797             Op  : Node_Kind;
4798             Val : Node_Id;
4799
4800          begin
4801             --  First check if we are in decisive conditional
4802
4803             Get_Current_Value_Condition (N, Op, Val);
4804
4805             if Known_Null (Val) then
4806                if Op = N_Op_Eq then
4807                   return False;
4808                elsif Op = N_Op_Ne then
4809                   return True;
4810                end if;
4811             end if;
4812
4813             --  If OK to do replacement, test Is_Known_Non_Null flag
4814
4815             if OK_To_Do_Constant_Replacement (E) then
4816                return Is_Known_Non_Null (E);
4817
4818             --  Otherwise if not safe to do replacement, then say so
4819
4820             else
4821                return False;
4822             end if;
4823          end;
4824
4825       --  True if access attribute
4826
4827       elsif Nkind (N) = N_Attribute_Reference
4828         and then (Attribute_Name (N) = Name_Access
4829                     or else
4830                   Attribute_Name (N) = Name_Unchecked_Access
4831                     or else
4832                   Attribute_Name (N) = Name_Unrestricted_Access)
4833       then
4834          return True;
4835
4836       --  True if allocator
4837
4838       elsif Nkind (N) = N_Allocator then
4839          return True;
4840
4841       --  For a conversion, true if expression is known non-null
4842
4843       elsif Nkind (N) = N_Type_Conversion then
4844          return Known_Non_Null (Expression (N));
4845
4846       --  Above are all cases where the value could be determined to be
4847       --  non-null. In all other cases, we don't know, so return False.
4848
4849       else
4850          return False;
4851       end if;
4852    end Known_Non_Null;
4853
4854    ----------------
4855    -- Known_Null --
4856    ----------------
4857
4858    function Known_Null (N : Node_Id) return Boolean is
4859    begin
4860       --  Checks for case where N is an entity reference
4861
4862       if Is_Entity_Name (N) and then Present (Entity (N)) then
4863          declare
4864             E   : constant Entity_Id := Entity (N);
4865             Op  : Node_Kind;
4866             Val : Node_Id;
4867
4868          begin
4869             --  Constant null value is for sure null
4870
4871             if Ekind (E) = E_Constant
4872               and then Known_Null (Constant_Value (E))
4873             then
4874                return True;
4875             end if;
4876
4877             --  First check if we are in decisive conditional
4878
4879             Get_Current_Value_Condition (N, Op, Val);
4880
4881             if Known_Null (Val) then
4882                if Op = N_Op_Eq then
4883                   return True;
4884                elsif Op = N_Op_Ne then
4885                   return False;
4886                end if;
4887             end if;
4888
4889             --  If OK to do replacement, test Is_Known_Null flag
4890
4891             if OK_To_Do_Constant_Replacement (E) then
4892                return Is_Known_Null (E);
4893
4894             --  Otherwise if not safe to do replacement, then say so
4895
4896             else
4897                return False;
4898             end if;
4899          end;
4900
4901       --  True if explicit reference to null
4902
4903       elsif Nkind (N) = N_Null then
4904          return True;
4905
4906       --  For a conversion, true if expression is known null
4907
4908       elsif Nkind (N) = N_Type_Conversion then
4909          return Known_Null (Expression (N));
4910
4911       --  Above are all cases where the value could be determined to be null.
4912       --  In all other cases, we don't know, so return False.
4913
4914       else
4915          return False;
4916       end if;
4917    end Known_Null;
4918
4919    -----------------------------
4920    -- Make_CW_Equivalent_Type --
4921    -----------------------------
4922
4923    --  Create a record type used as an equivalent of any member of the class
4924    --  which takes its size from exp.
4925
4926    --  Generate the following code:
4927
4928    --   type Equiv_T is record
4929    --     _parent :  T (List of discriminant constraints taken from Exp);
4930    --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
4931    --   end Equiv_T;
4932    --
4933    --   ??? Note that this type does not guarantee same alignment as all
4934    --   derived types
4935
4936    function Make_CW_Equivalent_Type
4937      (T : Entity_Id;
4938       E : Node_Id) return Entity_Id
4939    is
4940       Loc         : constant Source_Ptr := Sloc (E);
4941       Root_Typ    : constant Entity_Id  := Root_Type (T);
4942       List_Def    : constant List_Id    := Empty_List;
4943       Comp_List   : constant List_Id    := New_List;
4944       Equiv_Type  : Entity_Id;
4945       Range_Type  : Entity_Id;
4946       Str_Type    : Entity_Id;
4947       Constr_Root : Entity_Id;
4948       Sizexpr     : Node_Id;
4949
4950    begin
4951       --  If the root type is already constrained, there are no discriminants
4952       --  in the expression.
4953
4954       if not Has_Discriminants (Root_Typ)
4955         or else Is_Constrained (Root_Typ)
4956       then
4957          Constr_Root := Root_Typ;
4958       else
4959          Constr_Root := Make_Temporary (Loc, 'R');
4960
4961          --  subtype cstr__n is T (List of discr constraints taken from Exp)
4962
4963          Append_To (List_Def,
4964            Make_Subtype_Declaration (Loc,
4965              Defining_Identifier => Constr_Root,
4966              Subtype_Indication  => Make_Subtype_From_Expr (E, Root_Typ)));
4967       end if;
4968
4969       --  Generate the range subtype declaration
4970
4971       Range_Type := Make_Temporary (Loc, 'G');
4972
4973       if not Is_Interface (Root_Typ) then
4974
4975          --  subtype rg__xx is
4976          --    Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
4977
4978          Sizexpr :=
4979            Make_Op_Subtract (Loc,
4980              Left_Opnd =>
4981                Make_Attribute_Reference (Loc,
4982                  Prefix =>
4983                    OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
4984                  Attribute_Name => Name_Size),
4985              Right_Opnd =>
4986                Make_Attribute_Reference (Loc,
4987                  Prefix => New_Reference_To (Constr_Root, Loc),
4988                  Attribute_Name => Name_Object_Size));
4989       else
4990          --  subtype rg__xx is
4991          --    Storage_Offset range 1 .. Expr'size / Storage_Unit
4992
4993          Sizexpr :=
4994            Make_Attribute_Reference (Loc,
4995              Prefix =>
4996                OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
4997              Attribute_Name => Name_Size);
4998       end if;
4999
5000       Set_Paren_Count (Sizexpr, 1);
5001
5002       Append_To (List_Def,
5003         Make_Subtype_Declaration (Loc,
5004           Defining_Identifier => Range_Type,
5005           Subtype_Indication =>
5006             Make_Subtype_Indication (Loc,
5007               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
5008               Constraint => Make_Range_Constraint (Loc,
5009                 Range_Expression =>
5010                   Make_Range (Loc,
5011                     Low_Bound => Make_Integer_Literal (Loc, 1),
5012                     High_Bound =>
5013                       Make_Op_Divide (Loc,
5014                         Left_Opnd => Sizexpr,
5015                         Right_Opnd => Make_Integer_Literal (Loc,
5016                             Intval => System_Storage_Unit)))))));
5017
5018       --  subtype str__nn is Storage_Array (rg__x);
5019
5020       Str_Type := Make_Temporary (Loc, 'S');
5021       Append_To (List_Def,
5022         Make_Subtype_Declaration (Loc,
5023           Defining_Identifier => Str_Type,
5024           Subtype_Indication =>
5025             Make_Subtype_Indication (Loc,
5026               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
5027               Constraint =>
5028                 Make_Index_Or_Discriminant_Constraint (Loc,
5029                   Constraints =>
5030                     New_List (New_Reference_To (Range_Type, Loc))))));
5031
5032       --  type Equiv_T is record
5033       --    [ _parent : Tnn; ]
5034       --    E : Str_Type;
5035       --  end Equiv_T;
5036
5037       Equiv_Type := Make_Temporary (Loc, 'T');
5038       Set_Ekind (Equiv_Type, E_Record_Type);
5039       Set_Parent_Subtype (Equiv_Type, Constr_Root);
5040
5041       --  Set Is_Class_Wide_Equivalent_Type very early to trigger the special
5042       --  treatment for this type. In particular, even though _parent's type
5043       --  is a controlled type or contains controlled components, we do not
5044       --  want to set Has_Controlled_Component on it to avoid making it gain
5045       --  an unwanted _controller component.
5046
5047       Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
5048
5049       if not Is_Interface (Root_Typ) then
5050          Append_To (Comp_List,
5051            Make_Component_Declaration (Loc,
5052              Defining_Identifier =>
5053                Make_Defining_Identifier (Loc, Name_uParent),
5054              Component_Definition =>
5055                Make_Component_Definition (Loc,
5056                  Aliased_Present    => False,
5057                  Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
5058       end if;
5059
5060       Append_To (Comp_List,
5061         Make_Component_Declaration (Loc,
5062           Defining_Identifier  => Make_Temporary (Loc, 'C'),
5063           Component_Definition =>
5064             Make_Component_Definition (Loc,
5065               Aliased_Present    => False,
5066               Subtype_Indication => New_Reference_To (Str_Type, Loc))));
5067
5068       Append_To (List_Def,
5069         Make_Full_Type_Declaration (Loc,
5070           Defining_Identifier => Equiv_Type,
5071           Type_Definition =>
5072             Make_Record_Definition (Loc,
5073               Component_List =>
5074                 Make_Component_List (Loc,
5075                   Component_Items => Comp_List,
5076                   Variant_Part    => Empty))));
5077
5078       --  Suppress all checks during the analysis of the expanded code to avoid
5079       --  the generation of spurious warnings under ZFP run-time.
5080
5081       Insert_Actions (E, List_Def, Suppress => All_Checks);
5082       return Equiv_Type;
5083    end Make_CW_Equivalent_Type;
5084
5085    -------------------------
5086    -- Make_Invariant_Call --
5087    -------------------------
5088
5089    function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
5090       Loc : constant Source_Ptr := Sloc (Expr);
5091       Typ : constant Entity_Id  := Etype (Expr);
5092
5093    begin
5094       pragma Assert
5095         (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
5096
5097       if Check_Enabled (Name_Invariant)
5098            or else
5099          Check_Enabled (Name_Assertion)
5100       then
5101          return
5102            Make_Procedure_Call_Statement (Loc,
5103              Name                   =>
5104                New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
5105              Parameter_Associations => New_List (Relocate_Node (Expr)));
5106
5107       else
5108          return
5109            Make_Null_Statement (Loc);
5110       end if;
5111    end Make_Invariant_Call;
5112
5113    ------------------------
5114    -- Make_Literal_Range --
5115    ------------------------
5116
5117    function Make_Literal_Range
5118      (Loc         : Source_Ptr;
5119       Literal_Typ : Entity_Id) return Node_Id
5120    is
5121       Lo          : constant Node_Id :=
5122                       New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
5123       Index       : constant Entity_Id := Etype (Lo);
5124
5125       Hi          : Node_Id;
5126       Length_Expr : constant Node_Id :=
5127                       Make_Op_Subtract (Loc,
5128                         Left_Opnd =>
5129                           Make_Integer_Literal (Loc,
5130                             Intval => String_Literal_Length (Literal_Typ)),
5131                         Right_Opnd =>
5132                           Make_Integer_Literal (Loc, 1));
5133
5134    begin
5135       Set_Analyzed (Lo, False);
5136
5137          if Is_Integer_Type (Index) then
5138             Hi :=
5139               Make_Op_Add (Loc,
5140                 Left_Opnd  => New_Copy_Tree (Lo),
5141                 Right_Opnd => Length_Expr);
5142          else
5143             Hi :=
5144               Make_Attribute_Reference (Loc,
5145                 Attribute_Name => Name_Val,
5146                 Prefix => New_Occurrence_Of (Index, Loc),
5147                 Expressions => New_List (
5148                  Make_Op_Add (Loc,
5149                    Left_Opnd =>
5150                      Make_Attribute_Reference (Loc,
5151                        Attribute_Name => Name_Pos,
5152                        Prefix => New_Occurrence_Of (Index, Loc),
5153                        Expressions => New_List (New_Copy_Tree (Lo))),
5154                   Right_Opnd => Length_Expr)));
5155          end if;
5156
5157          return
5158            Make_Range (Loc,
5159              Low_Bound  => Lo,
5160              High_Bound => Hi);
5161    end Make_Literal_Range;
5162
5163    --------------------------
5164    -- Make_Non_Empty_Check --
5165    --------------------------
5166
5167    function Make_Non_Empty_Check
5168      (Loc : Source_Ptr;
5169       N   : Node_Id) return Node_Id
5170    is
5171    begin
5172       return
5173         Make_Op_Ne (Loc,
5174           Left_Opnd =>
5175             Make_Attribute_Reference (Loc,
5176               Attribute_Name => Name_Length,
5177               Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
5178           Right_Opnd =>
5179             Make_Integer_Literal (Loc, 0));
5180    end Make_Non_Empty_Check;
5181
5182    -------------------------
5183    -- Make_Predicate_Call --
5184    -------------------------
5185
5186    function Make_Predicate_Call
5187      (Typ  : Entity_Id;
5188       Expr : Node_Id) return Node_Id
5189    is
5190       Loc : constant Source_Ptr := Sloc (Expr);
5191
5192    begin
5193       pragma Assert (Present (Predicate_Function (Typ)));
5194
5195       return
5196         Make_Function_Call (Loc,
5197           Name                   =>
5198             New_Occurrence_Of (Predicate_Function (Typ), Loc),
5199           Parameter_Associations => New_List (Relocate_Node (Expr)));
5200    end Make_Predicate_Call;
5201
5202    --------------------------
5203    -- Make_Predicate_Check --
5204    --------------------------
5205
5206    function Make_Predicate_Check
5207      (Typ  : Entity_Id;
5208       Expr : Node_Id) return Node_Id
5209    is
5210       Loc : constant Source_Ptr := Sloc (Expr);
5211
5212    begin
5213       return
5214         Make_Pragma (Loc,
5215           Pragma_Identifier            => Make_Identifier (Loc, Name_Check),
5216           Pragma_Argument_Associations => New_List (
5217             Make_Pragma_Argument_Association (Loc,
5218               Expression => Make_Identifier (Loc, Name_Predicate)),
5219             Make_Pragma_Argument_Association (Loc,
5220               Expression => Make_Predicate_Call (Typ, Expr))));
5221    end Make_Predicate_Check;
5222
5223    ----------------------------
5224    -- Make_Subtype_From_Expr --
5225    ----------------------------
5226
5227    --  1. If Expr is an unconstrained array expression, creates
5228    --    Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
5229
5230    --  2. If Expr is a unconstrained discriminated type expression, creates
5231    --    Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
5232
5233    --  3. If Expr is class-wide, creates an implicit class wide subtype
5234
5235    function Make_Subtype_From_Expr
5236      (E       : Node_Id;
5237       Unc_Typ : Entity_Id) return Node_Id
5238    is
5239       Loc         : constant Source_Ptr := Sloc (E);
5240       List_Constr : constant List_Id    := New_List;
5241       D           : Entity_Id;
5242
5243       Full_Subtyp  : Entity_Id;
5244       Priv_Subtyp  : Entity_Id;
5245       Utyp         : Entity_Id;
5246       Full_Exp     : Node_Id;
5247
5248    begin
5249       if Is_Private_Type (Unc_Typ)
5250         and then Has_Unknown_Discriminants (Unc_Typ)
5251       then
5252          --  Prepare the subtype completion, Go to base type to
5253          --  find underlying type, because the type may be a generic
5254          --  actual or an explicit subtype.
5255
5256          Utyp        := Underlying_Type (Base_Type (Unc_Typ));
5257          Full_Subtyp := Make_Temporary (Loc, 'C');
5258          Full_Exp    :=
5259            Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
5260          Set_Parent (Full_Exp, Parent (E));
5261
5262          Priv_Subtyp := Make_Temporary (Loc, 'P');
5263
5264          Insert_Action (E,
5265            Make_Subtype_Declaration (Loc,
5266              Defining_Identifier => Full_Subtyp,
5267              Subtype_Indication  => Make_Subtype_From_Expr (Full_Exp, Utyp)));
5268
5269          --  Define the dummy private subtype
5270
5271          Set_Ekind          (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
5272          Set_Etype          (Priv_Subtyp, Base_Type (Unc_Typ));
5273          Set_Scope          (Priv_Subtyp, Full_Subtyp);
5274          Set_Is_Constrained (Priv_Subtyp);
5275          Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
5276          Set_Is_Itype       (Priv_Subtyp);
5277          Set_Associated_Node_For_Itype (Priv_Subtyp, E);
5278
5279          if Is_Tagged_Type  (Priv_Subtyp) then
5280             Set_Class_Wide_Type
5281               (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
5282             Set_Direct_Primitive_Operations (Priv_Subtyp,
5283               Direct_Primitive_Operations (Unc_Typ));
5284          end if;
5285
5286          Set_Full_View (Priv_Subtyp, Full_Subtyp);
5287
5288          return New_Reference_To (Priv_Subtyp, Loc);
5289
5290       elsif Is_Array_Type (Unc_Typ) then
5291          for J in 1 .. Number_Dimensions (Unc_Typ) loop
5292             Append_To (List_Constr,
5293               Make_Range (Loc,
5294                 Low_Bound =>
5295                   Make_Attribute_Reference (Loc,
5296                     Prefix => Duplicate_Subexpr_No_Checks (E),
5297                     Attribute_Name => Name_First,
5298                     Expressions => New_List (
5299                       Make_Integer_Literal (Loc, J))),
5300
5301                 High_Bound =>
5302                   Make_Attribute_Reference (Loc,
5303                     Prefix         => Duplicate_Subexpr_No_Checks (E),
5304                     Attribute_Name => Name_Last,
5305                     Expressions    => New_List (
5306                       Make_Integer_Literal (Loc, J)))));
5307          end loop;
5308
5309       elsif Is_Class_Wide_Type (Unc_Typ) then
5310          declare
5311             CW_Subtype : Entity_Id;
5312             EQ_Typ     : Entity_Id := Empty;
5313
5314          begin
5315             --  A class-wide equivalent type is not needed when VM_Target
5316             --  because the VM back-ends handle the class-wide object
5317             --  initialization itself (and doesn't need or want the
5318             --  additional intermediate type to handle the assignment).
5319
5320             if Expander_Active and then Tagged_Type_Expansion then
5321
5322                --  If this is the class_wide type of a completion that is a
5323                --  record subtype, set the type of the class_wide type to be
5324                --  the full base type, for use in the expanded code for the
5325                --  equivalent type. Should this be done earlier when the
5326                --  completion is analyzed ???
5327
5328                if Is_Private_Type (Etype (Unc_Typ))
5329                  and then
5330                    Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
5331                then
5332                   Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
5333                end if;
5334
5335                EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
5336             end if;
5337
5338             CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
5339             Set_Equivalent_Type (CW_Subtype, EQ_Typ);
5340             Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
5341
5342             return New_Occurrence_Of (CW_Subtype, Loc);
5343          end;
5344
5345       --  Indefinite record type with discriminants
5346
5347       else
5348          D := First_Discriminant (Unc_Typ);
5349          while Present (D) loop
5350             Append_To (List_Constr,
5351               Make_Selected_Component (Loc,
5352                 Prefix        => Duplicate_Subexpr_No_Checks (E),
5353                 Selector_Name => New_Reference_To (D, Loc)));
5354
5355             Next_Discriminant (D);
5356          end loop;
5357       end if;
5358
5359       return
5360         Make_Subtype_Indication (Loc,
5361           Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
5362           Constraint   =>
5363             Make_Index_Or_Discriminant_Constraint (Loc,
5364               Constraints => List_Constr));
5365    end Make_Subtype_From_Expr;
5366
5367    -----------------------------
5368    -- May_Generate_Large_Temp --
5369    -----------------------------
5370
5371    --  At the current time, the only types that we return False for (i.e. where
5372    --  we decide we know they cannot generate large temps) are ones where we
5373    --  know the size is 256 bits or less at compile time, and we are still not
5374    --  doing a thorough job on arrays and records ???
5375
5376    function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
5377    begin
5378       if not Size_Known_At_Compile_Time (Typ) then
5379          return False;
5380
5381       elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
5382          return False;
5383
5384       elsif Is_Array_Type (Typ)
5385         and then Present (Packed_Array_Type (Typ))
5386       then
5387          return May_Generate_Large_Temp (Packed_Array_Type (Typ));
5388
5389       --  We could do more here to find other small types ???
5390
5391       else
5392          return True;
5393       end if;
5394    end May_Generate_Large_Temp;
5395
5396    ------------------------
5397    -- Needs_Finalization --
5398    ------------------------
5399
5400    function Needs_Finalization (T : Entity_Id) return Boolean is
5401       function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
5402       --  If type is not frozen yet, check explicitly among its components,
5403       --  because the Has_Controlled_Component flag is not necessarily set.
5404
5405       -----------------------------------
5406       -- Has_Some_Controlled_Component --
5407       -----------------------------------
5408
5409       function Has_Some_Controlled_Component
5410         (Rec : Entity_Id) return Boolean
5411       is
5412          Comp : Entity_Id;
5413
5414       begin
5415          if Has_Controlled_Component (Rec) then
5416             return True;
5417
5418          elsif not Is_Frozen (Rec) then
5419             if Is_Record_Type (Rec) then
5420                Comp := First_Entity (Rec);
5421
5422                while Present (Comp) loop
5423                   if not Is_Type (Comp)
5424                     and then Needs_Finalization (Etype (Comp))
5425                   then
5426                      return True;
5427                   end if;
5428
5429                   Next_Entity (Comp);
5430                end loop;
5431
5432                return False;
5433
5434             elsif Is_Array_Type (Rec) then
5435                return Needs_Finalization (Component_Type (Rec));
5436
5437             else
5438                return Has_Controlled_Component (Rec);
5439             end if;
5440          else
5441             return False;
5442          end if;
5443       end Has_Some_Controlled_Component;
5444
5445    --  Start of processing for Needs_Finalization
5446
5447    begin
5448       --  Certain run-time configurations and targets do not provide support
5449       --  for controlled types.
5450
5451       if Restriction_Active (No_Finalization) then
5452          return False;
5453
5454       --  C, C++, CIL and Java types are not considered controlled. It is
5455       --  assumed that the non-Ada side will handle their clean up.
5456
5457       elsif Convention (T) = Convention_C
5458         or else Convention (T) = Convention_CIL
5459         or else Convention (T) = Convention_CPP
5460         or else Convention (T) = Convention_Java
5461       then
5462          return False;
5463
5464       else
5465          --  Class-wide types are treated as controlled because derivations
5466          --  from the root type can introduce controlled components.
5467
5468          return
5469            Is_Class_Wide_Type (T)
5470              or else Is_Controlled (T)
5471              or else Has_Controlled_Component (T)
5472              or else Has_Some_Controlled_Component (T)
5473              or else
5474                (Is_Concurrent_Type (T)
5475                   and then Present (Corresponding_Record_Type (T))
5476                   and then Needs_Finalization (Corresponding_Record_Type (T)));
5477       end if;
5478    end Needs_Finalization;
5479
5480    ----------------------------
5481    -- Needs_Constant_Address --
5482    ----------------------------
5483
5484    function Needs_Constant_Address
5485      (Decl : Node_Id;
5486       Typ  : Entity_Id) return Boolean
5487    is
5488    begin
5489
5490       --  If we have no initialization of any kind, then we don't need to place
5491       --  any restrictions on the address clause, because the object will be
5492       --  elaborated after the address clause is evaluated. This happens if the
5493       --  declaration has no initial expression, or the type has no implicit
5494       --  initialization, or the object is imported.
5495
5496       --  The same holds for all initialized scalar types and all access types.
5497       --  Packed bit arrays of size up to 64 are represented using a modular
5498       --  type with an initialization (to zero) and can be processed like other
5499       --  initialized scalar types.
5500
5501       --  If the type is controlled, code to attach the object to a
5502       --  finalization chain is generated at the point of declaration, and
5503       --  therefore the elaboration of the object cannot be delayed: the
5504       --  address expression must be a constant.
5505
5506       if No (Expression (Decl))
5507         and then not Needs_Finalization (Typ)
5508         and then
5509           (not Has_Non_Null_Base_Init_Proc (Typ)
5510             or else Is_Imported (Defining_Identifier (Decl)))
5511       then
5512          return False;
5513
5514       elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
5515         or else Is_Access_Type (Typ)
5516         or else
5517           (Is_Bit_Packed_Array (Typ)
5518              and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
5519       then
5520          return False;
5521
5522       else
5523
5524          --  Otherwise, we require the address clause to be constant because
5525          --  the call to the initialization procedure (or the attach code) has
5526          --  to happen at the point of the declaration.
5527
5528          --  Actually the IP call has been moved to the freeze actions anyway,
5529          --  so maybe we can relax this restriction???
5530
5531          return True;
5532       end if;
5533    end Needs_Constant_Address;
5534
5535    ----------------------------
5536    -- New_Class_Wide_Subtype --
5537    ----------------------------
5538
5539    function New_Class_Wide_Subtype
5540      (CW_Typ : Entity_Id;
5541       N      : Node_Id) return Entity_Id
5542    is
5543       Res       : constant Entity_Id := Create_Itype (E_Void, N);
5544       Res_Name  : constant Name_Id   := Chars (Res);
5545       Res_Scope : constant Entity_Id := Scope (Res);
5546
5547    begin
5548       Copy_Node (CW_Typ, Res);
5549       Set_Comes_From_Source (Res, False);
5550       Set_Sloc (Res, Sloc (N));
5551       Set_Is_Itype (Res);
5552       Set_Associated_Node_For_Itype (Res, N);
5553       Set_Is_Public (Res, False);   --  By default, may be changed below.
5554       Set_Public_Status (Res);
5555       Set_Chars (Res, Res_Name);
5556       Set_Scope (Res, Res_Scope);
5557       Set_Ekind (Res, E_Class_Wide_Subtype);
5558       Set_Next_Entity (Res, Empty);
5559       Set_Etype (Res, Base_Type (CW_Typ));
5560       Set_Is_Frozen (Res, False);
5561       Set_Freeze_Node (Res, Empty);
5562       return (Res);
5563    end New_Class_Wide_Subtype;
5564
5565    --------------------------------
5566    -- Non_Limited_Designated_Type --
5567    ---------------------------------
5568
5569    function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
5570       Desig : constant Entity_Id := Designated_Type (T);
5571    begin
5572       if Ekind (Desig) = E_Incomplete_Type
5573         and then Present (Non_Limited_View (Desig))
5574       then
5575          return Non_Limited_View (Desig);
5576       else
5577          return Desig;
5578       end if;
5579    end Non_Limited_Designated_Type;
5580
5581    -----------------------------------
5582    -- OK_To_Do_Constant_Replacement --
5583    -----------------------------------
5584
5585    function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
5586       ES : constant Entity_Id := Scope (E);
5587       CS : Entity_Id;
5588
5589    begin
5590       --  Do not replace statically allocated objects, because they may be
5591       --  modified outside the current scope.
5592
5593       if Is_Statically_Allocated (E) then
5594          return False;
5595
5596       --  Do not replace aliased or volatile objects, since we don't know what
5597       --  else might change the value.
5598
5599       elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
5600          return False;
5601
5602       --  Debug flag -gnatdM disconnects this optimization
5603
5604       elsif Debug_Flag_MM then
5605          return False;
5606
5607       --  Otherwise check scopes
5608
5609       else
5610          CS := Current_Scope;
5611
5612          loop
5613             --  If we are in right scope, replacement is safe
5614
5615             if CS = ES then
5616                return True;
5617
5618             --  Packages do not affect the determination of safety
5619
5620             elsif Ekind (CS) = E_Package then
5621                exit when CS = Standard_Standard;
5622                CS := Scope (CS);
5623
5624             --  Blocks do not affect the determination of safety
5625
5626             elsif Ekind (CS) = E_Block then
5627                CS := Scope (CS);
5628
5629             --  Loops do not affect the determination of safety. Note that we
5630             --  kill all current values on entry to a loop, so we are just
5631             --  talking about processing within a loop here.
5632
5633             elsif Ekind (CS) = E_Loop then
5634                CS := Scope (CS);
5635
5636             --  Otherwise, the reference is dubious, and we cannot be sure that
5637             --  it is safe to do the replacement.
5638
5639             else
5640                exit;
5641             end if;
5642          end loop;
5643
5644          return False;
5645       end if;
5646    end OK_To_Do_Constant_Replacement;
5647
5648    ------------------------------------
5649    -- Possible_Bit_Aligned_Component --
5650    ------------------------------------
5651
5652    function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
5653    begin
5654       case Nkind (N) is
5655
5656          --  Case of indexed component
5657
5658          when N_Indexed_Component =>
5659             declare
5660                P    : constant Node_Id   := Prefix (N);
5661                Ptyp : constant Entity_Id := Etype (P);
5662
5663             begin
5664                --  If we know the component size and it is less than 64, then
5665                --  we are definitely OK. The back end always does assignment of
5666                --  misaligned small objects correctly.
5667
5668                if Known_Static_Component_Size (Ptyp)
5669                  and then Component_Size (Ptyp) <= 64
5670                then
5671                   return False;
5672
5673                --  Otherwise, we need to test the prefix, to see if we are
5674                --  indexing from a possibly unaligned component.
5675
5676                else
5677                   return Possible_Bit_Aligned_Component (P);
5678                end if;
5679             end;
5680
5681          --  Case of selected component
5682
5683          when N_Selected_Component =>
5684             declare
5685                P    : constant Node_Id   := Prefix (N);
5686                Comp : constant Entity_Id := Entity (Selector_Name (N));
5687
5688             begin
5689                --  If there is no component clause, then we are in the clear
5690                --  since the back end will never misalign a large component
5691                --  unless it is forced to do so. In the clear means we need
5692                --  only the recursive test on the prefix.
5693
5694                if Component_May_Be_Bit_Aligned (Comp) then
5695                   return True;
5696                else
5697                   return Possible_Bit_Aligned_Component (P);
5698                end if;
5699             end;
5700
5701          --  For a slice, test the prefix, if that is possibly misaligned,
5702          --  then for sure the slice is!
5703
5704          when N_Slice =>
5705             return Possible_Bit_Aligned_Component (Prefix (N));
5706
5707          --  For an unchecked conversion, check whether the expression may
5708          --  be bit-aligned.
5709
5710          when N_Unchecked_Type_Conversion =>
5711             return Possible_Bit_Aligned_Component (Expression (N));
5712
5713          --  If we have none of the above, it means that we have fallen off the
5714          --  top testing prefixes recursively, and we now have a stand alone
5715          --  object, where we don't have a problem.
5716
5717          when others =>
5718             return False;
5719
5720       end case;
5721    end Possible_Bit_Aligned_Component;
5722
5723    -----------------------------------------------
5724    -- Process_Statements_For_Controlled_Objects --
5725    -----------------------------------------------
5726
5727    procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
5728       Loc : constant Source_Ptr := Sloc (N);
5729
5730       function Are_Wrapped (L : List_Id) return Boolean;
5731       --  Determine whether list L contains only one statement which is a block
5732
5733       function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
5734       --  Given a list of statements L, wrap it in a block statement and return
5735       --  the generated node.
5736
5737       -----------------
5738       -- Are_Wrapped --
5739       -----------------
5740
5741       function Are_Wrapped (L : List_Id) return Boolean is
5742          Stmt : constant Node_Id := First (L);
5743       begin
5744          return
5745            Present (Stmt)
5746              and then No (Next (Stmt))
5747              and then Nkind (Stmt) = N_Block_Statement;
5748       end Are_Wrapped;
5749
5750       ------------------------------
5751       -- Wrap_Statements_In_Block --
5752       ------------------------------
5753
5754       function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
5755       begin
5756          return
5757            Make_Block_Statement (Loc,
5758              Declarations => No_List,
5759              Handled_Statement_Sequence =>
5760                Make_Handled_Sequence_Of_Statements (Loc,
5761                  Statements => L));
5762       end Wrap_Statements_In_Block;
5763
5764       --  Local variables
5765
5766       Block : Node_Id;
5767
5768    --  Start of processing for Process_Statements_For_Controlled_Objects
5769
5770    begin
5771       --  Whenever a non-handled statement list is wrapped in a block, the
5772       --  block must be explicitly analyzed to redecorate all entities in the
5773       --  list and ensure that a finalizer is properly built.
5774
5775       case Nkind (N) is
5776          when N_Elsif_Part             |
5777               N_If_Statement           |
5778               N_Conditional_Entry_Call |
5779               N_Selective_Accept       =>
5780
5781             --  Check the "then statements" for elsif parts and if statements
5782
5783             if Nkind_In (N, N_Elsif_Part, N_If_Statement)
5784               and then not Is_Empty_List (Then_Statements (N))
5785               and then not Are_Wrapped (Then_Statements (N))
5786               and then Requires_Cleanup_Actions
5787                          (Then_Statements (N), False, False)
5788             then
5789                Block := Wrap_Statements_In_Block (Then_Statements (N));
5790                Set_Then_Statements (N, New_List (Block));
5791
5792                Analyze (Block);
5793             end if;
5794
5795             --  Check the "else statements" for conditional entry calls, if
5796             --  statements and selective accepts.
5797
5798             if Nkind_In (N, N_Conditional_Entry_Call,
5799                             N_If_Statement,
5800                             N_Selective_Accept)
5801               and then not Is_Empty_List (Else_Statements (N))
5802               and then not Are_Wrapped (Else_Statements (N))
5803               and then Requires_Cleanup_Actions
5804                          (Else_Statements (N), False, False)
5805             then
5806                Block := Wrap_Statements_In_Block (Else_Statements (N));
5807                Set_Else_Statements (N, New_List (Block));
5808
5809                Analyze (Block);
5810             end if;
5811
5812          when N_Abortable_Part             |
5813               N_Accept_Alternative         |
5814               N_Case_Statement_Alternative |
5815               N_Delay_Alternative          |
5816               N_Entry_Call_Alternative     |
5817               N_Exception_Handler          |
5818               N_Loop_Statement             |
5819               N_Triggering_Alternative     =>
5820
5821             if not Is_Empty_List (Statements (N))
5822               and then not Are_Wrapped (Statements (N))
5823               and then Requires_Cleanup_Actions (Statements (N), False, False)
5824             then
5825                Block := Wrap_Statements_In_Block (Statements (N));
5826                Set_Statements (N, New_List (Block));
5827
5828                Analyze (Block);
5829             end if;
5830
5831          when others                       =>
5832             null;
5833       end case;
5834    end Process_Statements_For_Controlled_Objects;
5835
5836    -------------------------
5837    -- Remove_Side_Effects --
5838    -------------------------
5839
5840    procedure Remove_Side_Effects
5841      (Exp          : Node_Id;
5842       Name_Req     : Boolean := False;
5843       Variable_Ref : Boolean := False)
5844    is
5845       Loc          : constant Source_Ptr     := Sloc (Exp);
5846       Exp_Type     : constant Entity_Id      := Etype (Exp);
5847       Svg_Suppress : constant Suppress_Array := Scope_Suppress;
5848       Def_Id       : Entity_Id;
5849       Ref_Type     : Entity_Id;
5850       Res          : Node_Id;
5851       Ptr_Typ_Decl : Node_Id;
5852       New_Exp      : Node_Id;
5853       E            : Node_Id;
5854
5855       function Side_Effect_Free (N : Node_Id) return Boolean;
5856       --  Determines if the tree N represents an expression that is known not
5857       --  to have side effects, and for which no processing is required.
5858
5859       function Side_Effect_Free (L : List_Id) return Boolean;
5860       --  Determines if all elements of the list L are side effect free
5861
5862       function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
5863       --  The argument N is a construct where the Prefix is dereferenced if it
5864       --  is an access type and the result is a variable. The call returns True
5865       --  if the construct is side effect free (not considering side effects in
5866       --  other than the prefix which are to be tested by the caller).
5867
5868       function Within_In_Parameter (N : Node_Id) return Boolean;
5869       --  Determines if N is a subcomponent of a composite in-parameter. If so,
5870       --  N is not side-effect free when the actual is global and modifiable
5871       --  indirectly from within a subprogram, because it may be passed by
5872       --  reference. The front-end must be conservative here and assume that
5873       --  this may happen with any array or record type. On the other hand, we
5874       --  cannot create temporaries for all expressions for which this
5875       --  condition is true, for various reasons that might require clearing up
5876       --  ??? For example, discriminant references that appear out of place, or
5877       --  spurious type errors with class-wide expressions. As a result, we
5878       --  limit the transformation to loop bounds, which is so far the only
5879       --  case that requires it.
5880
5881       -----------------------------
5882       -- Safe_Prefixed_Reference --
5883       -----------------------------
5884
5885       function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
5886       begin
5887          --  If prefix is not side effect free, definitely not safe
5888
5889          if not Side_Effect_Free (Prefix (N)) then
5890             return False;
5891
5892          --  If the prefix is of an access type that is not access-to-constant,
5893          --  then this construct is a variable reference, which means it is to
5894          --  be considered to have side effects if Variable_Ref is set True.
5895
5896          elsif Is_Access_Type (Etype (Prefix (N)))
5897            and then not Is_Access_Constant (Etype (Prefix (N)))
5898            and then Variable_Ref
5899          then
5900             --  Exception is a prefix that is the result of a previous removal
5901             --  of side-effects.
5902
5903             return Is_Entity_Name (Prefix (N))
5904               and then not Comes_From_Source (Prefix (N))
5905               and then Ekind (Entity (Prefix (N))) = E_Constant
5906               and then Is_Internal_Name (Chars (Entity (Prefix (N))));
5907
5908          --  If the prefix is an explicit dereference then this construct is a
5909          --  variable reference, which means it is to be considered to have
5910          --  side effects if Variable_Ref is True.
5911
5912          --  We do NOT exclude dereferences of access-to-constant types because
5913          --  we handle them as constant view of variables.
5914
5915          elsif Nkind (Prefix (N)) = N_Explicit_Dereference
5916            and then Variable_Ref
5917          then
5918             return False;
5919
5920          --  Note: The following test is the simplest way of solving a complex
5921          --  problem uncovered by the following test (Side effect on loop bound
5922          --  that is a subcomponent of a global variable:
5923
5924          --    with Text_Io; use Text_Io;
5925          --    procedure Tloop is
5926          --      type X is
5927          --        record
5928          --          V : Natural := 4;
5929          --          S : String (1..5) := (others => 'a');
5930          --        end record;
5931          --      X1 : X;
5932
5933          --      procedure Modi;
5934
5935          --      generic
5936          --        with procedure Action;
5937          --      procedure Loop_G (Arg : X; Msg : String)
5938
5939          --      procedure Loop_G (Arg : X; Msg : String) is
5940          --      begin
5941          --        Put_Line ("begin loop_g " & Msg & " will loop till: "
5942          --                  & Natural'Image (Arg.V));
5943          --        for Index in 1 .. Arg.V loop
5944          --          Text_Io.Put_Line
5945          --            (Natural'Image (Index) & " " & Arg.S (Index));
5946          --          if Index > 2 then
5947          --            Modi;
5948          --          end if;
5949          --        end loop;
5950          --        Put_Line ("end loop_g " & Msg);
5951          --      end;
5952
5953          --      procedure Loop1 is new Loop_G (Modi);
5954          --      procedure Modi is
5955          --      begin
5956          --        X1.V := 1;
5957          --        Loop1 (X1, "from modi");
5958          --      end;
5959          --
5960          --    begin
5961          --      Loop1 (X1, "initial");
5962          --    end;
5963
5964          --  The output of the above program should be:
5965
5966          --    begin loop_g initial will loop till:  4
5967          --     1 a
5968          --     2 a
5969          --     3 a
5970          --    begin loop_g from modi will loop till:  1
5971          --     1 a
5972          --    end loop_g from modi
5973          --     4 a
5974          --    begin loop_g from modi will loop till:  1
5975          --     1 a
5976          --    end loop_g from modi
5977          --    end loop_g initial
5978
5979          --  If a loop bound is a subcomponent of a global variable, a
5980          --  modification of that variable within the loop may incorrectly
5981          --  affect the execution of the loop.
5982
5983          elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
5984            and then Within_In_Parameter (Prefix (N))
5985            and then Variable_Ref
5986          then
5987             return False;
5988
5989          --  All other cases are side effect free
5990
5991          else
5992             return True;
5993          end if;
5994       end Safe_Prefixed_Reference;
5995
5996       ----------------------
5997       -- Side_Effect_Free --
5998       ----------------------
5999
6000       function Side_Effect_Free (N : Node_Id) return Boolean is
6001       begin
6002          --  Note on checks that could raise Constraint_Error. Strictly, if we
6003          --  take advantage of 11.6, these checks do not count as side effects.
6004          --  However, we would prefer to consider that they are side effects,
6005          --  since the backend CSE does not work very well on expressions which
6006          --  can raise Constraint_Error. On the other hand if we don't consider
6007          --  them to be side effect free, then we get some awkward expansions
6008          --  in -gnato mode, resulting in code insertions at a point where we
6009          --  do not have a clear model for performing the insertions.
6010
6011          --  Special handling for entity names
6012
6013          if Is_Entity_Name (N) then
6014
6015             --  Variables are considered to be a side effect if Variable_Ref
6016             --  is set or if we have a volatile reference and Name_Req is off.
6017             --  If Name_Req is True then we can't help returning a name which
6018             --  effectively allows multiple references in any case.
6019
6020             if Is_Variable (N, Use_Original_Node => False) then
6021                return not Variable_Ref
6022                  and then (not Is_Volatile_Reference (N) or else Name_Req);
6023
6024             --  Any other entity (e.g. a subtype name) is definitely side
6025             --  effect free.
6026
6027             else
6028                return True;
6029             end if;
6030
6031          --  A value known at compile time is always side effect free
6032
6033          elsif Compile_Time_Known_Value (N) then
6034             return True;
6035
6036          --  A variable renaming is not side-effect free, because the renaming
6037          --  will function like a macro in the front-end in some cases, and an
6038          --  assignment can modify the component designated by N, so we need to
6039          --  create a temporary for it.
6040
6041          --  The guard testing for Entity being present is needed at least in
6042          --  the case of rewritten predicate expressions, and may well also be
6043          --  appropriate elsewhere. Obviously we can't go testing the entity
6044          --  field if it does not exist, so it's reasonable to say that this is
6045          --  not the renaming case if it does not exist.
6046
6047          elsif Is_Entity_Name (Original_Node (N))
6048            and then Present (Entity (Original_Node (N)))
6049            and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
6050            and then Ekind (Entity (Original_Node (N))) /= E_Constant
6051          then
6052             return False;
6053
6054          --  Remove_Side_Effects generates an object renaming declaration to
6055          --  capture the expression of a class-wide expression. In VM targets
6056          --  the frontend performs no expansion for dispatching calls to
6057          --  class- wide types since they are handled by the VM. Hence, we must
6058          --  locate here if this node corresponds to a previous invocation of
6059          --  Remove_Side_Effects to avoid a never ending loop in the frontend.
6060
6061          elsif VM_Target /= No_VM
6062             and then not Comes_From_Source (N)
6063             and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
6064             and then Is_Class_Wide_Type (Etype (N))
6065          then
6066             return True;
6067          end if;
6068
6069          --  For other than entity names and compile time known values,
6070          --  check the node kind for special processing.
6071
6072          case Nkind (N) is
6073
6074             --  An attribute reference is side effect free if its expressions
6075             --  are side effect free and its prefix is side effect free or
6076             --  is an entity reference.
6077
6078             --  Is this right? what about x'first where x is a variable???
6079
6080             when N_Attribute_Reference =>
6081                return Side_Effect_Free (Expressions (N))
6082                  and then Attribute_Name (N) /= Name_Input
6083                  and then (Is_Entity_Name (Prefix (N))
6084                             or else Side_Effect_Free (Prefix (N)));
6085
6086             --  A binary operator is side effect free if and both operands are
6087             --  side effect free. For this purpose binary operators include
6088             --  membership tests and short circuit forms
6089
6090             when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
6091                return Side_Effect_Free (Left_Opnd  (N))
6092                         and then
6093                       Side_Effect_Free (Right_Opnd (N));
6094
6095             --  An explicit dereference is side effect free only if it is
6096             --  a side effect free prefixed reference.
6097
6098             when N_Explicit_Dereference =>
6099                return Safe_Prefixed_Reference (N);
6100
6101             --  A call to _rep_to_pos is side effect free, since we generate
6102             --  this pure function call ourselves. Moreover it is critically
6103             --  important to make this exception, since otherwise we can have
6104             --  discriminants in array components which don't look side effect
6105             --  free in the case of an array whose index type is an enumeration
6106             --  type with an enumeration rep clause.
6107
6108             --  All other function calls are not side effect free
6109
6110             when N_Function_Call =>
6111                return Nkind (Name (N)) = N_Identifier
6112                  and then Is_TSS (Name (N), TSS_Rep_To_Pos)
6113                  and then
6114                    Side_Effect_Free (First (Parameter_Associations (N)));
6115
6116             --  An indexed component is side effect free if it is a side
6117             --  effect free prefixed reference and all the indexing
6118             --  expressions are side effect free.
6119
6120             when N_Indexed_Component =>
6121                return Side_Effect_Free (Expressions (N))
6122                  and then Safe_Prefixed_Reference (N);
6123
6124             --  A type qualification is side effect free if the expression
6125             --  is side effect free.
6126
6127             when N_Qualified_Expression =>
6128                return Side_Effect_Free (Expression (N));
6129
6130             --  A selected component is side effect free only if it is a side
6131             --  effect free prefixed reference. If it designates a component
6132             --  with a rep. clause it must be treated has having a potential
6133             --  side effect, because it may be modified through a renaming, and
6134             --  a subsequent use of the renaming as a macro will yield the
6135             --  wrong value. This complex interaction between renaming and
6136             --  removing side effects is a reminder that the latter has become
6137             --  a headache to maintain, and that it should be removed in favor
6138             --  of the gcc mechanism to capture values ???
6139
6140             when N_Selected_Component =>
6141                if Nkind (Parent (N)) = N_Explicit_Dereference
6142                  and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
6143                then
6144                   return False;
6145                else
6146                   return Safe_Prefixed_Reference (N);
6147                end if;
6148
6149             --  A range is side effect free if the bounds are side effect free
6150
6151             when N_Range =>
6152                return Side_Effect_Free (Low_Bound (N))
6153                  and then Side_Effect_Free (High_Bound (N));
6154
6155             --  A slice is side effect free if it is a side effect free
6156             --  prefixed reference and the bounds are side effect free.
6157
6158             when N_Slice =>
6159                return Side_Effect_Free (Discrete_Range (N))
6160                  and then Safe_Prefixed_Reference (N);
6161
6162             --  A type conversion is side effect free if the expression to be
6163             --  converted is side effect free.
6164
6165             when N_Type_Conversion =>
6166                return Side_Effect_Free (Expression (N));
6167
6168             --  A unary operator is side effect free if the operand
6169             --  is side effect free.
6170
6171             when N_Unary_Op =>
6172                return Side_Effect_Free (Right_Opnd (N));
6173
6174             --  An unchecked type conversion is side effect free only if it
6175             --  is safe and its argument is side effect free.
6176
6177             when N_Unchecked_Type_Conversion =>
6178                return Safe_Unchecked_Type_Conversion (N)
6179                  and then Side_Effect_Free (Expression (N));
6180
6181             --  An unchecked expression is side effect free if its expression
6182             --  is side effect free.
6183
6184             when N_Unchecked_Expression =>
6185                return Side_Effect_Free (Expression (N));
6186
6187             --  A literal is side effect free
6188
6189             when N_Character_Literal    |
6190                  N_Integer_Literal      |
6191                  N_Real_Literal         |
6192                  N_String_Literal       =>
6193                return True;
6194
6195             --  We consider that anything else has side effects. This is a bit
6196             --  crude, but we are pretty close for most common cases, and we
6197             --  are certainly correct (i.e. we never return True when the
6198             --  answer should be False).
6199
6200             when others =>
6201                return False;
6202          end case;
6203       end Side_Effect_Free;
6204
6205       --  A list is side effect free if all elements of the list are side
6206       --  effect free.
6207
6208       function Side_Effect_Free (L : List_Id) return Boolean is
6209          N : Node_Id;
6210
6211       begin
6212          if L = No_List or else L = Error_List then
6213             return True;
6214
6215          else
6216             N := First (L);
6217             while Present (N) loop
6218                if not Side_Effect_Free (N) then
6219                   return False;
6220                else
6221                   Next (N);
6222                end if;
6223             end loop;
6224
6225             return True;
6226          end if;
6227       end Side_Effect_Free;
6228
6229       -------------------------
6230       -- Within_In_Parameter --
6231       -------------------------
6232
6233       function Within_In_Parameter (N : Node_Id) return Boolean is
6234       begin
6235          if not Comes_From_Source (N) then
6236             return False;
6237
6238          elsif Is_Entity_Name (N) then
6239             return Ekind (Entity (N)) = E_In_Parameter;
6240
6241          elsif Nkind (N) = N_Indexed_Component
6242            or else Nkind (N) = N_Selected_Component
6243          then
6244             return Within_In_Parameter (Prefix (N));
6245          else
6246
6247             return False;
6248          end if;
6249       end Within_In_Parameter;
6250
6251    --  Start of processing for Remove_Side_Effects
6252
6253    begin
6254       --  Handle cases in which there is nothing to do
6255
6256       if not Expander_Active then
6257          return;
6258
6259       --  Cannot generate temporaries if the invocation to remove side effects
6260       --  was issued too early and the type of the expression is not resolved
6261       --  (this happens because routines Duplicate_Subexpr_XX implicitly invoke
6262       --  Remove_Side_Effects).
6263
6264       elsif No (Exp_Type)
6265         or else Ekind (Exp_Type) = E_Access_Attribute_Type
6266       then
6267          return;
6268
6269       --  No action needed for side-effect free expressions
6270
6271       elsif Side_Effect_Free (Exp) then
6272          return;
6273       end if;
6274
6275       --  All this must not have any checks
6276
6277       Scope_Suppress := (others => True);
6278
6279       --  If it is a scalar type and we need to capture the value, just make
6280       --  a copy. Likewise for a function call, an attribute reference, an
6281       --  allocator, or an operator. And if we have a volatile reference and
6282       --  Name_Req is not set (see comments above for Side_Effect_Free).
6283
6284       if Is_Elementary_Type (Exp_Type)
6285         and then (Variable_Ref
6286                    or else Nkind (Exp) = N_Function_Call
6287                    or else Nkind (Exp) = N_Attribute_Reference
6288                    or else Nkind (Exp) = N_Allocator
6289                    or else Nkind (Exp) in N_Op
6290                    or else (not Name_Req and then Is_Volatile_Reference (Exp)))
6291       then
6292          Def_Id := Make_Temporary (Loc, 'R', Exp);
6293          Set_Etype (Def_Id, Exp_Type);
6294          Res := New_Reference_To (Def_Id, Loc);
6295
6296          --  If the expression is a packed reference, it must be reanalyzed and
6297          --  expanded, depending on context. This is the case for actuals where
6298          --  a constraint check may capture the actual before expansion of the
6299          --  call is complete.
6300
6301          if Nkind (Exp) = N_Indexed_Component
6302            and then Is_Packed (Etype (Prefix (Exp)))
6303          then
6304             Set_Analyzed (Exp, False);
6305             Set_Analyzed (Prefix (Exp), False);
6306          end if;
6307
6308          E :=
6309            Make_Object_Declaration (Loc,
6310              Defining_Identifier => Def_Id,
6311              Object_Definition   => New_Reference_To (Exp_Type, Loc),
6312              Constant_Present    => True,
6313              Expression          => Relocate_Node (Exp));
6314
6315          Set_Assignment_OK (E);
6316          Insert_Action (Exp, E);
6317
6318       --  If the expression has the form v.all then we can just capture the
6319       --  pointer, and then do an explicit dereference on the result.
6320
6321       elsif Nkind (Exp) = N_Explicit_Dereference then
6322          Def_Id := Make_Temporary (Loc, 'R', Exp);
6323          Res :=
6324            Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
6325
6326          Insert_Action (Exp,
6327            Make_Object_Declaration (Loc,
6328              Defining_Identifier => Def_Id,
6329              Object_Definition   =>
6330                New_Reference_To (Etype (Prefix (Exp)), Loc),
6331              Constant_Present    => True,
6332              Expression          => Relocate_Node (Prefix (Exp))));
6333
6334       --  Similar processing for an unchecked conversion of an expression of
6335       --  the form v.all, where we want the same kind of treatment.
6336
6337       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6338         and then Nkind (Expression (Exp)) = N_Explicit_Dereference
6339       then
6340          Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6341          Scope_Suppress := Svg_Suppress;
6342          return;
6343
6344       --  If this is a type conversion, leave the type conversion and remove
6345       --  the side effects in the expression. This is important in several
6346       --  circumstances: for change of representations, and also when this is a
6347       --  view conversion to a smaller object, where gigi can end up creating
6348       --  its own temporary of the wrong size.
6349
6350       elsif Nkind (Exp) = N_Type_Conversion then
6351          Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6352          Scope_Suppress := Svg_Suppress;
6353          return;
6354
6355       --  If this is an unchecked conversion that Gigi can't handle, make
6356       --  a copy or a use a renaming to capture the value.
6357
6358       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6359         and then not Safe_Unchecked_Type_Conversion (Exp)
6360       then
6361          if CW_Or_Has_Controlled_Part (Exp_Type) then
6362
6363             --  Use a renaming to capture the expression, rather than create
6364             --  a controlled temporary.
6365
6366             Def_Id := Make_Temporary (Loc, 'R', Exp);
6367             Res := New_Reference_To (Def_Id, Loc);
6368
6369             Insert_Action (Exp,
6370               Make_Object_Renaming_Declaration (Loc,
6371                 Defining_Identifier => Def_Id,
6372                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
6373                 Name                => Relocate_Node (Exp)));
6374
6375          else
6376             Def_Id := Make_Temporary (Loc, 'R', Exp);
6377             Set_Etype (Def_Id, Exp_Type);
6378             Res := New_Reference_To (Def_Id, Loc);
6379
6380             E :=
6381               Make_Object_Declaration (Loc,
6382                 Defining_Identifier => Def_Id,
6383                 Object_Definition   => New_Reference_To (Exp_Type, Loc),
6384                 Constant_Present    => not Is_Variable (Exp),
6385                 Expression          => Relocate_Node (Exp));
6386
6387             Set_Assignment_OK (E);
6388             Insert_Action (Exp, E);
6389          end if;
6390
6391       --  For expressions that denote objects, we can use a renaming scheme.
6392       --  This is needed for correctness in the case of a volatile object of a
6393       --  non-volatile type because the Make_Reference call of the "default"
6394       --  approach would generate an illegal access value (an access value
6395       --  cannot designate such an object - see Analyze_Reference). We skip
6396       --  using this scheme if we have an object of a volatile type and we do
6397       --  not have Name_Req set true (see comments above for Side_Effect_Free).
6398
6399       elsif Is_Object_Reference (Exp)
6400         and then Nkind (Exp) /= N_Function_Call
6401         and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
6402       then
6403          Def_Id := Make_Temporary (Loc, 'R', Exp);
6404
6405          if Nkind (Exp) = N_Selected_Component
6406            and then Nkind (Prefix (Exp)) = N_Function_Call
6407            and then Is_Array_Type (Exp_Type)
6408          then
6409             --  Avoid generating a variable-sized temporary, by generating
6410             --  the renaming declaration just for the function call. The
6411             --  transformation could be refined to apply only when the array
6412             --  component is constrained by a discriminant???
6413
6414             Res :=
6415               Make_Selected_Component (Loc,
6416                 Prefix => New_Occurrence_Of (Def_Id, Loc),
6417                 Selector_Name => Selector_Name (Exp));
6418
6419             Insert_Action (Exp,
6420               Make_Object_Renaming_Declaration (Loc,
6421                 Defining_Identifier => Def_Id,
6422                 Subtype_Mark        =>
6423                   New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
6424                 Name                => Relocate_Node (Prefix (Exp))));
6425
6426          else
6427             Res := New_Reference_To (Def_Id, Loc);
6428
6429             Insert_Action (Exp,
6430               Make_Object_Renaming_Declaration (Loc,
6431                 Defining_Identifier => Def_Id,
6432                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
6433                 Name                => Relocate_Node (Exp)));
6434          end if;
6435
6436          --  If this is a packed reference, or a selected component with
6437          --  a non-standard representation, a reference to the temporary
6438          --  will be replaced by a copy of the original expression (see
6439          --  Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
6440          --  elaborated by gigi, and is of course not to be replaced in-line
6441          --  by the expression it renames, which would defeat the purpose of
6442          --  removing the side-effect.
6443
6444          if (Nkind (Exp) = N_Selected_Component
6445               or else Nkind (Exp) = N_Indexed_Component)
6446            and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
6447          then
6448             null;
6449          else
6450             Set_Is_Renaming_Of_Object (Def_Id, False);
6451          end if;
6452
6453       --  Otherwise we generate a reference to the value
6454
6455       else
6456          --  Special processing for function calls that return a limited type.
6457          --  We need to build a declaration that will enable build-in-place
6458          --  expansion of the call. This is not done if the context is already
6459          --  an object declaration, to prevent infinite recursion.
6460
6461          --  This is relevant only in Ada 2005 mode. In Ada 95 programs we have
6462          --  to accommodate functions returning limited objects by reference.
6463
6464          if Nkind (Exp) = N_Function_Call
6465            and then Is_Immutably_Limited_Type (Etype (Exp))
6466            and then Nkind (Parent (Exp)) /= N_Object_Declaration
6467            and then Ada_Version >= Ada_2005
6468          then
6469             declare
6470                Obj  : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
6471                Decl : Node_Id;
6472
6473             begin
6474                Decl :=
6475                  Make_Object_Declaration (Loc,
6476                    Defining_Identifier => Obj,
6477                    Object_Definition   => New_Occurrence_Of (Exp_Type, Loc),
6478                    Expression          => Relocate_Node (Exp));
6479
6480                Insert_Action (Exp, Decl);
6481                Set_Etype (Obj, Exp_Type);
6482                Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
6483                return;
6484             end;
6485          end if;
6486
6487          Ref_Type := Make_Temporary (Loc, 'A');
6488
6489          Ptr_Typ_Decl :=
6490            Make_Full_Type_Declaration (Loc,
6491              Defining_Identifier => Ref_Type,
6492              Type_Definition =>
6493                Make_Access_To_Object_Definition (Loc,
6494                  All_Present => True,
6495                  Subtype_Indication =>
6496                    New_Reference_To (Exp_Type, Loc)));
6497
6498          E := Exp;
6499          Insert_Action (Exp, Ptr_Typ_Decl);
6500
6501          Def_Id := Make_Temporary (Loc, 'R', Exp);
6502          Set_Etype (Def_Id, Exp_Type);
6503
6504          Res :=
6505            Make_Explicit_Dereference (Loc,
6506              Prefix => New_Reference_To (Def_Id, Loc));
6507
6508          if Nkind (E) = N_Explicit_Dereference then
6509             New_Exp := Relocate_Node (Prefix (E));
6510          else
6511             E := Relocate_Node (E);
6512             New_Exp := Make_Reference (Loc, E);
6513          end if;
6514
6515          if Is_Delayed_Aggregate (E) then
6516
6517             --  The expansion of nested aggregates is delayed until the
6518             --  enclosing aggregate is expanded. As aggregates are often
6519             --  qualified, the predicate applies to qualified expressions as
6520             --  well, indicating that the enclosing aggregate has not been
6521             --  expanded yet. At this point the aggregate is part of a
6522             --  stand-alone declaration, and must be fully expanded.
6523
6524             if Nkind (E) = N_Qualified_Expression then
6525                Set_Expansion_Delayed (Expression (E), False);
6526                Set_Analyzed (Expression (E), False);
6527             else
6528                Set_Expansion_Delayed (E, False);
6529             end if;
6530
6531             Set_Analyzed (E, False);
6532          end if;
6533
6534          Insert_Action (Exp,
6535            Make_Object_Declaration (Loc,
6536              Defining_Identifier => Def_Id,
6537              Object_Definition   => New_Reference_To (Ref_Type, Loc),
6538              Constant_Present    => True,
6539              Expression          => New_Exp));
6540       end if;
6541
6542       --  Preserve the Assignment_OK flag in all copies, since at least one
6543       --  copy may be used in a context where this flag must be set (otherwise
6544       --  why would the flag be set in the first place).
6545
6546       Set_Assignment_OK (Res, Assignment_OK (Exp));
6547
6548       --  Finally rewrite the original expression and we are done
6549
6550       Rewrite (Exp, Res);
6551       Analyze_And_Resolve (Exp, Exp_Type);
6552       Scope_Suppress := Svg_Suppress;
6553    end Remove_Side_Effects;
6554
6555    ---------------------------
6556    -- Represented_As_Scalar --
6557    ---------------------------
6558
6559    function Represented_As_Scalar (T : Entity_Id) return Boolean is
6560       UT : constant Entity_Id := Underlying_Type (T);
6561    begin
6562       return Is_Scalar_Type (UT)
6563         or else (Is_Bit_Packed_Array (UT)
6564                    and then Is_Scalar_Type (Packed_Array_Type (UT)));
6565    end Represented_As_Scalar;
6566
6567    ------------------------------
6568    -- Requires_Cleanup_Actions --
6569    ------------------------------
6570
6571    function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
6572       For_Pkg : constant Boolean :=
6573                   Nkind_In (N, N_Package_Body, N_Package_Specification);
6574
6575    begin
6576       case Nkind (N) is
6577          when N_Accept_Statement      |
6578               N_Block_Statement       |
6579               N_Entry_Body            |
6580               N_Package_Body          |
6581               N_Protected_Body        |
6582               N_Subprogram_Body       |
6583               N_Task_Body             =>
6584             return
6585               Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
6586                 or else
6587               (Present (Handled_Statement_Sequence (N))
6588                 and then
6589               Requires_Cleanup_Actions (Statements
6590                 (Handled_Statement_Sequence (N)), For_Pkg, True));
6591
6592          when N_Package_Specification =>
6593             return
6594               Requires_Cleanup_Actions
6595                 (Visible_Declarations (N), For_Pkg, True)
6596                   or else
6597               Requires_Cleanup_Actions
6598                 (Private_Declarations (N), For_Pkg, True);
6599
6600          when others                  =>
6601             return False;
6602       end case;
6603    end Requires_Cleanup_Actions;
6604
6605    ------------------------------
6606    -- Requires_Cleanup_Actions --
6607    ------------------------------
6608
6609    function Requires_Cleanup_Actions
6610      (L                 : List_Id;
6611       For_Package       : Boolean;
6612       Nested_Constructs : Boolean) return Boolean
6613    is
6614       Decl    : Node_Id;
6615       Expr    : Node_Id;
6616       Obj_Id  : Entity_Id;
6617       Obj_Typ : Entity_Id;
6618       Pack_Id : Entity_Id;
6619       Typ     : Entity_Id;
6620
6621    begin
6622       if No (L)
6623         or else Is_Empty_List (L)
6624       then
6625          return False;
6626       end if;
6627
6628       Decl := First (L);
6629       while Present (Decl) loop
6630
6631          --  Library-level tagged types
6632
6633          if Nkind (Decl) = N_Full_Type_Declaration then
6634             Typ := Defining_Identifier (Decl);
6635
6636             if Is_Tagged_Type (Typ)
6637               and then Is_Library_Level_Entity (Typ)
6638               and then Convention (Typ) = Convention_Ada
6639               and then Present (Access_Disp_Table (Typ))
6640               and then RTE_Available (RE_Unregister_Tag)
6641               and then not No_Run_Time_Mode
6642               and then not Is_Abstract_Type (Typ)
6643             then
6644                return True;
6645             end if;
6646
6647          --  Regular object declarations
6648
6649          elsif Nkind (Decl) = N_Object_Declaration then
6650             Obj_Id  := Defining_Identifier (Decl);
6651             Obj_Typ := Base_Type (Etype (Obj_Id));
6652             Expr    := Expression (Decl);
6653
6654             --  Bypass any form of processing for objects which have their
6655             --  finalization disabled. This applies only to objects at the
6656             --  library level.
6657
6658             if For_Package
6659               and then Finalize_Storage_Only (Obj_Typ)
6660             then
6661                null;
6662
6663             --  Transient variables are treated separately in order to minimize
6664             --  the size of the generated code. See Exp_Ch7.Process_Transient_
6665             --  Objects.
6666
6667             elsif Is_Processed_Transient (Obj_Id) then
6668                null;
6669
6670             --  The object is of the form:
6671             --    Obj : Typ [:= Expr];
6672             --
6673             --  Do not process the incomplete view of a deferred constant. Do
6674             --  not consider tag-to-class-wide conversions.
6675
6676             elsif not Is_Imported (Obj_Id)
6677               and then Needs_Finalization (Obj_Typ)
6678               and then not (Ekind (Obj_Id) = E_Constant
6679                               and then not Has_Completion (Obj_Id))
6680               and then not Is_Tag_To_CW_Conversion (Obj_Id)
6681             then
6682                return True;
6683
6684             --  The object is of the form:
6685             --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
6686             --
6687             --    Obj : Access_Typ :=
6688             --            BIP_Function_Call
6689             --              (..., BIPaccess => null, ...)'reference;
6690
6691             elsif Is_Access_Type (Obj_Typ)
6692               and then Needs_Finalization
6693                          (Available_View (Designated_Type (Obj_Typ)))
6694               and then Present (Expr)
6695               and then
6696                 (Is_Null_Access_BIP_Func_Call (Expr)
6697                    or else
6698                 (Is_Non_BIP_Func_Call (Expr)
6699                    and then not Is_Related_To_Func_Return (Obj_Id)))
6700             then
6701                return True;
6702
6703             --  Processing for "hook" objects generated for controlled
6704             --  transients declared inside an Expression_With_Actions.
6705
6706             elsif Is_Access_Type (Obj_Typ)
6707               and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
6708               and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
6709                          N_Object_Declaration
6710               and then Is_Finalizable_Transient
6711                          (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
6712             then
6713                return True;
6714
6715             --  Simple protected objects which use type System.Tasking.
6716             --  Protected_Objects.Protection to manage their locks should be
6717             --  treated as controlled since they require manual cleanup.
6718
6719             elsif Ekind (Obj_Id) = E_Variable
6720               and then
6721                 (Is_Simple_Protected_Type (Obj_Typ)
6722                   or else Has_Simple_Protected_Object (Obj_Typ))
6723             then
6724                return True;
6725             end if;
6726
6727          --  Specific cases of object renamings
6728
6729          elsif Nkind (Decl) = N_Object_Renaming_Declaration
6730            and then Nkind (Name (Decl)) = N_Explicit_Dereference
6731            and then Nkind (Prefix (Name (Decl))) = N_Identifier
6732          then
6733             Obj_Id  := Defining_Identifier (Decl);
6734             Obj_Typ := Base_Type (Etype (Obj_Id));
6735
6736             --  Bypass any form of processing for objects which have their
6737             --  finalization disabled. This applies only to objects at the
6738             --  library level.
6739
6740             if For_Package
6741               and then Finalize_Storage_Only (Obj_Typ)
6742             then
6743                null;
6744
6745             --  Return object of a build-in-place function. This case is
6746             --  recognized and marked by the expansion of an extended return
6747             --  statement (see Expand_N_Extended_Return_Statement).
6748
6749             elsif Needs_Finalization (Obj_Typ)
6750               and then Is_Return_Object (Obj_Id)
6751               and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
6752             then
6753                return True;
6754             end if;
6755
6756          --  Inspect the freeze node of an access-to-controlled type and look
6757          --  for a delayed finalization master. This case arises when the
6758          --  freeze actions are inserted at a later time than the expansion of
6759          --  the context. Since Build_Finalizer is never called on a single
6760          --  construct twice, the master will be ultimately left out and never
6761          --  finalized. This is also needed for freeze actions of designated
6762          --  types themselves, since in some cases the finalization master is
6763          --  associated with a designated type's freeze node rather than that
6764          --  of the access type (see handling for freeze actions in
6765          --  Build_Finalization_Master).
6766
6767          elsif Nkind (Decl) = N_Freeze_Entity
6768            and then Present (Actions (Decl))
6769          then
6770             Typ := Entity (Decl);
6771
6772             if ((Is_Access_Type (Typ)
6773                   and then not Is_Access_Subprogram_Type (Typ)
6774                   and then Needs_Finalization
6775                              (Available_View (Designated_Type (Typ))))
6776                or else
6777                 (Is_Type (Typ)
6778                    and then Needs_Finalization (Typ)))
6779               and then Requires_Cleanup_Actions
6780                          (Actions (Decl), For_Package, Nested_Constructs)
6781             then
6782                return True;
6783             end if;
6784
6785          --  Nested package declarations
6786
6787          elsif Nested_Constructs
6788            and then Nkind (Decl) = N_Package_Declaration
6789          then
6790             Pack_Id := Defining_Unit_Name (Specification (Decl));
6791
6792             if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
6793                Pack_Id := Defining_Identifier (Pack_Id);
6794             end if;
6795
6796             if Ekind (Pack_Id) /= E_Generic_Package
6797               and then Requires_Cleanup_Actions (Specification (Decl))
6798             then
6799                return True;
6800             end if;
6801
6802          --  Nested package bodies
6803
6804          elsif Nested_Constructs
6805            and then Nkind (Decl) = N_Package_Body
6806          then
6807             Pack_Id := Corresponding_Spec (Decl);
6808
6809             if Ekind (Pack_Id) /= E_Generic_Package
6810               and then Requires_Cleanup_Actions (Decl)
6811             then
6812                return True;
6813             end if;
6814          end if;
6815
6816          Next (Decl);
6817       end loop;
6818
6819       return False;
6820    end Requires_Cleanup_Actions;
6821
6822    ------------------------------------
6823    -- Safe_Unchecked_Type_Conversion --
6824    ------------------------------------
6825
6826    --  Note: this function knows quite a bit about the exact requirements of
6827    --  Gigi with respect to unchecked type conversions, and its code must be
6828    --  coordinated with any changes in Gigi in this area.
6829
6830    --  The above requirements should be documented in Sinfo ???
6831
6832    function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
6833       Otyp   : Entity_Id;
6834       Ityp   : Entity_Id;
6835       Oalign : Uint;
6836       Ialign : Uint;
6837       Pexp   : constant Node_Id := Parent (Exp);
6838
6839    begin
6840       --  If the expression is the RHS of an assignment or object declaration
6841       --   we are always OK because there will always be a target.
6842
6843       --  Object renaming declarations, (generated for view conversions of
6844       --  actuals in inlined calls), like object declarations, provide an
6845       --  explicit type, and are safe as well.
6846
6847       if (Nkind (Pexp) = N_Assignment_Statement
6848            and then Expression (Pexp) = Exp)
6849         or else Nkind (Pexp) = N_Object_Declaration
6850         or else Nkind (Pexp) = N_Object_Renaming_Declaration
6851       then
6852          return True;
6853
6854       --  If the expression is the prefix of an N_Selected_Component we should
6855       --  also be OK because GCC knows to look inside the conversion except if
6856       --  the type is discriminated. We assume that we are OK anyway if the
6857       --  type is not set yet or if it is controlled since we can't afford to
6858       --  introduce a temporary in this case.
6859
6860       elsif Nkind (Pexp) = N_Selected_Component
6861          and then Prefix (Pexp) = Exp
6862       then
6863          if No (Etype (Pexp)) then
6864             return True;
6865          else
6866             return
6867               not Has_Discriminants (Etype (Pexp))
6868                 or else Is_Constrained (Etype (Pexp));
6869          end if;
6870       end if;
6871
6872       --  Set the output type, this comes from Etype if it is set, otherwise we
6873       --  take it from the subtype mark, which we assume was already fully
6874       --  analyzed.
6875
6876       if Present (Etype (Exp)) then
6877          Otyp := Etype (Exp);
6878       else
6879          Otyp := Entity (Subtype_Mark (Exp));
6880       end if;
6881
6882       --  The input type always comes from the expression, and we assume
6883       --  this is indeed always analyzed, so we can simply get the Etype.
6884
6885       Ityp := Etype (Expression (Exp));
6886
6887       --  Initialize alignments to unknown so far
6888
6889       Oalign := No_Uint;
6890       Ialign := No_Uint;
6891
6892       --  Replace a concurrent type by its corresponding record type and each
6893       --  type by its underlying type and do the tests on those. The original
6894       --  type may be a private type whose completion is a concurrent type, so
6895       --  find the underlying type first.
6896
6897       if Present (Underlying_Type (Otyp)) then
6898          Otyp := Underlying_Type (Otyp);
6899       end if;
6900
6901       if Present (Underlying_Type (Ityp)) then
6902          Ityp := Underlying_Type (Ityp);
6903       end if;
6904
6905       if Is_Concurrent_Type (Otyp) then
6906          Otyp := Corresponding_Record_Type (Otyp);
6907       end if;
6908
6909       if Is_Concurrent_Type (Ityp) then
6910          Ityp := Corresponding_Record_Type (Ityp);
6911       end if;
6912
6913       --  If the base types are the same, we know there is no problem since
6914       --  this conversion will be a noop.
6915
6916       if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
6917          return True;
6918
6919       --  Same if this is an upwards conversion of an untagged type, and there
6920       --  are no constraints involved (could be more general???)
6921
6922       elsif Etype (Ityp) = Otyp
6923         and then not Is_Tagged_Type (Ityp)
6924         and then not Has_Discriminants (Ityp)
6925         and then No (First_Rep_Item (Base_Type (Ityp)))
6926       then
6927          return True;
6928
6929       --  If the expression has an access type (object or subprogram) we assume
6930       --  that the conversion is safe, because the size of the target is safe,
6931       --  even if it is a record (which might be treated as having unknown size
6932       --  at this point).
6933
6934       elsif Is_Access_Type (Ityp) then
6935          return True;
6936
6937       --  If the size of output type is known at compile time, there is never
6938       --  a problem. Note that unconstrained records are considered to be of
6939       --  known size, but we can't consider them that way here, because we are
6940       --  talking about the actual size of the object.
6941
6942       --  We also make sure that in addition to the size being known, we do not
6943       --  have a case which might generate an embarrassingly large temp in
6944       --  stack checking mode.
6945
6946       elsif Size_Known_At_Compile_Time (Otyp)
6947         and then
6948           (not Stack_Checking_Enabled
6949              or else not May_Generate_Large_Temp (Otyp))
6950         and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
6951       then
6952          return True;
6953
6954       --  If either type is tagged, then we know the alignment is OK so
6955       --  Gigi will be able to use pointer punning.
6956
6957       elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
6958          return True;
6959
6960       --  If either type is a limited record type, we cannot do a copy, so say
6961       --  safe since there's nothing else we can do.
6962
6963       elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
6964          return True;
6965
6966       --  Conversions to and from packed array types are always ignored and
6967       --  hence are safe.
6968
6969       elsif Is_Packed_Array_Type (Otyp)
6970         or else Is_Packed_Array_Type (Ityp)
6971       then
6972          return True;
6973       end if;
6974
6975       --  The only other cases known to be safe is if the input type's
6976       --  alignment is known to be at least the maximum alignment for the
6977       --  target or if both alignments are known and the output type's
6978       --  alignment is no stricter than the input's. We can use the component
6979       --  type alignement for an array if a type is an unpacked array type.
6980
6981       if Present (Alignment_Clause (Otyp)) then
6982          Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
6983
6984       elsif Is_Array_Type (Otyp)
6985         and then Present (Alignment_Clause (Component_Type (Otyp)))
6986       then
6987          Oalign := Expr_Value (Expression (Alignment_Clause
6988                                            (Component_Type (Otyp))));
6989       end if;
6990
6991       if Present (Alignment_Clause (Ityp)) then
6992          Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
6993
6994       elsif Is_Array_Type (Ityp)
6995         and then Present (Alignment_Clause (Component_Type (Ityp)))
6996       then
6997          Ialign := Expr_Value (Expression (Alignment_Clause
6998                                            (Component_Type (Ityp))));
6999       end if;
7000
7001       if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
7002          return True;
7003
7004       elsif Ialign /= No_Uint and then Oalign /= No_Uint
7005         and then Ialign <= Oalign
7006       then
7007          return True;
7008
7009       --   Otherwise, Gigi cannot handle this and we must make a temporary
7010
7011       else
7012          return False;
7013       end if;
7014    end Safe_Unchecked_Type_Conversion;
7015
7016    ---------------------------------
7017    -- Set_Current_Value_Condition --
7018    ---------------------------------
7019
7020    --  Note: the implementation of this procedure is very closely tied to the
7021    --  implementation of Get_Current_Value_Condition. Here we set required
7022    --  Current_Value fields, and in Get_Current_Value_Condition, we interpret
7023    --  them, so they must have a consistent view.
7024
7025    procedure Set_Current_Value_Condition (Cnode : Node_Id) is
7026
7027       procedure Set_Entity_Current_Value (N : Node_Id);
7028       --  If N is an entity reference, where the entity is of an appropriate
7029       --  kind, then set the current value of this entity to Cnode, unless
7030       --  there is already a definite value set there.
7031
7032       procedure Set_Expression_Current_Value (N : Node_Id);
7033       --  If N is of an appropriate form, sets an appropriate entry in current
7034       --  value fields of relevant entities. Multiple entities can be affected
7035       --  in the case of an AND or AND THEN.
7036
7037       ------------------------------
7038       -- Set_Entity_Current_Value --
7039       ------------------------------
7040
7041       procedure Set_Entity_Current_Value (N : Node_Id) is
7042       begin
7043          if Is_Entity_Name (N) then
7044             declare
7045                Ent : constant Entity_Id := Entity (N);
7046
7047             begin
7048                --  Don't capture if not safe to do so
7049
7050                if not Safe_To_Capture_Value (N, Ent, Cond => True) then
7051                   return;
7052                end if;
7053
7054                --  Here we have a case where the Current_Value field may need
7055                --  to be set. We set it if it is not already set to a compile
7056                --  time expression value.
7057
7058                --  Note that this represents a decision that one condition
7059                --  blots out another previous one. That's certainly right if
7060                --  they occur at the same level. If the second one is nested,
7061                --  then the decision is neither right nor wrong (it would be
7062                --  equally OK to leave the outer one in place, or take the new
7063                --  inner one. Really we should record both, but our data
7064                --  structures are not that elaborate.
7065
7066                if Nkind (Current_Value (Ent)) not in N_Subexpr then
7067                   Set_Current_Value (Ent, Cnode);
7068                end if;
7069             end;
7070          end if;
7071       end Set_Entity_Current_Value;
7072
7073       ----------------------------------
7074       -- Set_Expression_Current_Value --
7075       ----------------------------------
7076
7077       procedure Set_Expression_Current_Value (N : Node_Id) is
7078          Cond : Node_Id;
7079
7080       begin
7081          Cond := N;
7082
7083          --  Loop to deal with (ignore for now) any NOT operators present. The
7084          --  presence of NOT operators will be handled properly when we call
7085          --  Get_Current_Value_Condition.
7086
7087          while Nkind (Cond) = N_Op_Not loop
7088             Cond := Right_Opnd (Cond);
7089          end loop;
7090
7091          --  For an AND or AND THEN, recursively process operands
7092
7093          if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
7094             Set_Expression_Current_Value (Left_Opnd (Cond));
7095             Set_Expression_Current_Value (Right_Opnd (Cond));
7096             return;
7097          end if;
7098
7099          --  Check possible relational operator
7100
7101          if Nkind (Cond) in N_Op_Compare then
7102             if Compile_Time_Known_Value (Right_Opnd (Cond)) then
7103                Set_Entity_Current_Value (Left_Opnd (Cond));
7104             elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
7105                Set_Entity_Current_Value (Right_Opnd (Cond));
7106             end if;
7107
7108             --  Check possible boolean variable reference
7109
7110          else
7111             Set_Entity_Current_Value (Cond);
7112          end if;
7113       end Set_Expression_Current_Value;
7114
7115    --  Start of processing for Set_Current_Value_Condition
7116
7117    begin
7118       Set_Expression_Current_Value (Condition (Cnode));
7119    end Set_Current_Value_Condition;
7120
7121    --------------------------
7122    -- Set_Elaboration_Flag --
7123    --------------------------
7124
7125    procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
7126       Loc : constant Source_Ptr := Sloc (N);
7127       Ent : constant Entity_Id  := Elaboration_Entity (Spec_Id);
7128       Asn : Node_Id;
7129
7130    begin
7131       if Present (Ent) then
7132
7133          --  Nothing to do if at the compilation unit level, because in this
7134          --  case the flag is set by the binder generated elaboration routine.
7135
7136          if Nkind (Parent (N)) = N_Compilation_Unit then
7137             null;
7138
7139          --  Here we do need to generate an assignment statement
7140
7141          else
7142             Check_Restriction (No_Elaboration_Code, N);
7143             Asn :=
7144               Make_Assignment_Statement (Loc,
7145                 Name       => New_Occurrence_Of (Ent, Loc),
7146                 Expression => Make_Integer_Literal (Loc, Uint_1));
7147
7148             if Nkind (Parent (N)) = N_Subunit then
7149                Insert_After (Corresponding_Stub (Parent (N)), Asn);
7150             else
7151                Insert_After (N, Asn);
7152             end if;
7153
7154             Analyze (Asn);
7155
7156             --  Kill current value indication. This is necessary because the
7157             --  tests of this flag are inserted out of sequence and must not
7158             --  pick up bogus indications of the wrong constant value.
7159
7160             Set_Current_Value (Ent, Empty);
7161          end if;
7162       end if;
7163    end Set_Elaboration_Flag;
7164
7165    ----------------------------
7166    -- Set_Renamed_Subprogram --
7167    ----------------------------
7168
7169    procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
7170    begin
7171       --  If input node is an identifier, we can just reset it
7172
7173       if Nkind (N) = N_Identifier then
7174          Set_Chars  (N, Chars (E));
7175          Set_Entity (N, E);
7176
7177          --  Otherwise we have to do a rewrite, preserving Comes_From_Source
7178
7179       else
7180          declare
7181             CS : constant Boolean := Comes_From_Source (N);
7182          begin
7183             Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
7184             Set_Entity (N, E);
7185             Set_Comes_From_Source (N, CS);
7186             Set_Analyzed (N, True);
7187          end;
7188       end if;
7189    end Set_Renamed_Subprogram;
7190
7191    ----------------------------------
7192    -- Silly_Boolean_Array_Not_Test --
7193    ----------------------------------
7194
7195    --  This procedure implements an odd and silly test. We explicitly check
7196    --  for the case where the 'First of the component type is equal to the
7197    --  'Last of this component type, and if this is the case, we make sure
7198    --  that constraint error is raised. The reason is that the NOT is bound
7199    --  to cause CE in this case, and we will not otherwise catch it.
7200
7201    --  No such check is required for AND and OR, since for both these cases
7202    --  False op False = False, and True op True = True. For the XOR case,
7203    --  see Silly_Boolean_Array_Xor_Test.
7204
7205    --  Believe it or not, this was reported as a bug. Note that nearly always,
7206    --  the test will evaluate statically to False, so the code will be
7207    --  statically removed, and no extra overhead caused.
7208
7209    procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
7210       Loc : constant Source_Ptr := Sloc (N);
7211       CT  : constant Entity_Id  := Component_Type (T);
7212
7213    begin
7214       --  The check we install is
7215
7216       --    constraint_error when
7217       --      component_type'first = component_type'last
7218       --        and then array_type'Length /= 0)
7219
7220       --  We need the last guard because we don't want to raise CE for empty
7221       --  arrays since no out of range values result. (Empty arrays with a
7222       --  component type of True .. True -- very useful -- even the ACATS
7223       --  does not test that marginal case!)
7224
7225       Insert_Action (N,
7226         Make_Raise_Constraint_Error (Loc,
7227           Condition =>
7228             Make_And_Then (Loc,
7229               Left_Opnd =>
7230                 Make_Op_Eq (Loc,
7231                   Left_Opnd =>
7232                     Make_Attribute_Reference (Loc,
7233                       Prefix         => New_Occurrence_Of (CT, Loc),
7234                       Attribute_Name => Name_First),
7235
7236                   Right_Opnd =>
7237                     Make_Attribute_Reference (Loc,
7238                       Prefix         => New_Occurrence_Of (CT, Loc),
7239                       Attribute_Name => Name_Last)),
7240
7241               Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7242           Reason => CE_Range_Check_Failed));
7243    end Silly_Boolean_Array_Not_Test;
7244
7245    ----------------------------------
7246    -- Silly_Boolean_Array_Xor_Test --
7247    ----------------------------------
7248
7249    --  This procedure implements an odd and silly test. We explicitly check
7250    --  for the XOR case where the component type is True .. True, since this
7251    --  will raise constraint error. A special check is required since CE
7252    --  will not be generated otherwise (cf Expand_Packed_Not).
7253
7254    --  No such check is required for AND and OR, since for both these cases
7255    --  False op False = False, and True op True = True, and no check is
7256    --  required for the case of False .. False, since False xor False = False.
7257    --  See also Silly_Boolean_Array_Not_Test
7258
7259    procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
7260       Loc : constant Source_Ptr := Sloc (N);
7261       CT  : constant Entity_Id  := Component_Type (T);
7262
7263    begin
7264       --  The check we install is
7265
7266       --    constraint_error when
7267       --      Boolean (component_type'First)
7268       --        and then Boolean (component_type'Last)
7269       --        and then array_type'Length /= 0)
7270
7271       --  We need the last guard because we don't want to raise CE for empty
7272       --  arrays since no out of range values result (Empty arrays with a
7273       --  component type of True .. True -- very useful -- even the ACATS
7274       --  does not test that marginal case!).
7275
7276       Insert_Action (N,
7277         Make_Raise_Constraint_Error (Loc,
7278           Condition =>
7279             Make_And_Then (Loc,
7280               Left_Opnd =>
7281                 Make_And_Then (Loc,
7282                   Left_Opnd =>
7283                     Convert_To (Standard_Boolean,
7284                       Make_Attribute_Reference (Loc,
7285                         Prefix         => New_Occurrence_Of (CT, Loc),
7286                         Attribute_Name => Name_First)),
7287
7288                   Right_Opnd =>
7289                     Convert_To (Standard_Boolean,
7290                       Make_Attribute_Reference (Loc,
7291                         Prefix         => New_Occurrence_Of (CT, Loc),
7292                         Attribute_Name => Name_Last))),
7293
7294               Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7295           Reason => CE_Range_Check_Failed));
7296    end Silly_Boolean_Array_Xor_Test;
7297
7298    --------------------------
7299    -- Target_Has_Fixed_Ops --
7300    --------------------------
7301
7302    Integer_Sized_Small : Ureal;
7303    --  Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
7304    --  called (we don't want to compute it more than once!)
7305
7306    Long_Integer_Sized_Small : Ureal;
7307    --  Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
7308    --  is called (we don't want to compute it more than once)
7309
7310    First_Time_For_THFO : Boolean := True;
7311    --  Set to False after first call (if Fractional_Fixed_Ops_On_Target)
7312
7313    function Target_Has_Fixed_Ops
7314      (Left_Typ   : Entity_Id;
7315       Right_Typ  : Entity_Id;
7316       Result_Typ : Entity_Id) return Boolean
7317    is
7318       function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
7319       --  Return True if the given type is a fixed-point type with a small
7320       --  value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
7321       --  an absolute value less than 1.0. This is currently limited to
7322       --  fixed-point types that map to Integer or Long_Integer.
7323
7324       ------------------------
7325       -- Is_Fractional_Type --
7326       ------------------------
7327
7328       function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
7329       begin
7330          if Esize (Typ) = Standard_Integer_Size then
7331             return Small_Value (Typ) = Integer_Sized_Small;
7332
7333          elsif Esize (Typ) = Standard_Long_Integer_Size then
7334             return Small_Value (Typ) = Long_Integer_Sized_Small;
7335
7336          else
7337             return False;
7338          end if;
7339       end Is_Fractional_Type;
7340
7341    --  Start of processing for Target_Has_Fixed_Ops
7342
7343    begin
7344       --  Return False if Fractional_Fixed_Ops_On_Target is false
7345
7346       if not Fractional_Fixed_Ops_On_Target then
7347          return False;
7348       end if;
7349
7350       --  Here the target has Fractional_Fixed_Ops, if first time, compute
7351       --  standard constants used by Is_Fractional_Type.
7352
7353       if First_Time_For_THFO then
7354          First_Time_For_THFO := False;
7355
7356          Integer_Sized_Small :=
7357            UR_From_Components
7358              (Num   => Uint_1,
7359               Den   => UI_From_Int (Standard_Integer_Size - 1),
7360               Rbase => 2);
7361
7362          Long_Integer_Sized_Small :=
7363            UR_From_Components
7364              (Num   => Uint_1,
7365               Den   => UI_From_Int (Standard_Long_Integer_Size - 1),
7366               Rbase => 2);
7367       end if;
7368
7369       --  Return True if target supports fixed-by-fixed multiply/divide for
7370       --  fractional fixed-point types (see Is_Fractional_Type) and the operand
7371       --  and result types are equivalent fractional types.
7372
7373       return Is_Fractional_Type (Base_Type (Left_Typ))
7374         and then Is_Fractional_Type (Base_Type (Right_Typ))
7375         and then Is_Fractional_Type (Base_Type (Result_Typ))
7376         and then Esize (Left_Typ) = Esize (Right_Typ)
7377         and then Esize (Left_Typ) = Esize (Result_Typ);
7378    end Target_Has_Fixed_Ops;
7379
7380    ------------------------------------------
7381    -- Type_May_Have_Bit_Aligned_Components --
7382    ------------------------------------------
7383
7384    function Type_May_Have_Bit_Aligned_Components
7385      (Typ : Entity_Id) return Boolean
7386    is
7387    begin
7388       --  Array type, check component type
7389
7390       if Is_Array_Type (Typ) then
7391          return
7392            Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
7393
7394       --  Record type, check components
7395
7396       elsif Is_Record_Type (Typ) then
7397          declare
7398             E : Entity_Id;
7399
7400          begin
7401             E := First_Component_Or_Discriminant (Typ);
7402             while Present (E) loop
7403                if Component_May_Be_Bit_Aligned (E)
7404                  or else Type_May_Have_Bit_Aligned_Components (Etype (E))
7405                then
7406                   return True;
7407                end if;
7408
7409                Next_Component_Or_Discriminant (E);
7410             end loop;
7411
7412             return False;
7413          end;
7414
7415       --  Type other than array or record is always OK
7416
7417       else
7418          return False;
7419       end if;
7420    end Type_May_Have_Bit_Aligned_Components;
7421
7422    ----------------------------
7423    -- Wrap_Cleanup_Procedure --
7424    ----------------------------
7425
7426    procedure Wrap_Cleanup_Procedure (N : Node_Id) is
7427       Loc   : constant Source_Ptr := Sloc (N);
7428       Stseq : constant Node_Id    := Handled_Statement_Sequence (N);
7429       Stmts : constant List_Id    := Statements (Stseq);
7430
7431    begin
7432       if Abort_Allowed then
7433          Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7434          Append_To  (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7435       end if;
7436    end Wrap_Cleanup_Procedure;
7437
7438 end Exp_Util;