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