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