gcc/ada/exp_ch7.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 7                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2012, 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 --  This package contains virtually all expansion mechanisms related to
  27 --    - controlled types
  28 --    - transient scopes
  29
  30 with Atree;    use Atree;
  31 with Debug;    use Debug;
  32 with Einfo;    use Einfo;
  33 with Elists;   use Elists;
  34 with Errout;   use Errout;
  35 with Exp_Ch6;  use Exp_Ch6;
  36 with Exp_Ch9;  use Exp_Ch9;
  37 with Exp_Ch11; use Exp_Ch11;
  38 with Exp_Dbug; use Exp_Dbug;
  39 with Exp_Dist; use Exp_Dist;
  40 with Exp_Disp; use Exp_Disp;
  41 with Exp_Tss;  use Exp_Tss;
  42 with Exp_Util; use Exp_Util;
  43 with Freeze;   use Freeze;
  44 with Lib;      use Lib;
  45 with Nlists;   use Nlists;
  46 with Nmake;    use Nmake;
  47 with Opt;      use Opt;
  48 with Output;   use Output;
  49 with Restrict; use Restrict;
  50 with Rident;   use Rident;
  51 with Rtsfind;  use Rtsfind;
  52 with Sinfo;    use Sinfo;
  53 with Sem;      use Sem;
  54 with Sem_Aux;  use Sem_Aux;
  55 with Sem_Ch3;  use Sem_Ch3;
  56 with Sem_Ch7;  use Sem_Ch7;
  57 with Sem_Ch8;  use Sem_Ch8;
  58 with Sem_Res;  use Sem_Res;
  59 with Sem_Util; use Sem_Util;
  60 with Snames;   use Snames;
  61 with Stand;    use Stand;
  62 with Targparm; use Targparm;
  63 with Tbuild;   use Tbuild;
  64 with Ttypes;   use Ttypes;
  65 with Uintp;    use Uintp;
  66
  67 package body Exp_Ch7 is
  68
  69    --------------------------------
  70    -- Transient Scope Management --
  71    --------------------------------
  72
  73    --  A transient scope is created when temporary objects are created by the
  74    --  compiler. These temporary objects are allocated on the secondary stack
  75    --  and the transient scope is responsible for finalizing the object when
  76    --  appropriate and reclaiming the memory at the right time. The temporary
  77    --  objects are generally the objects allocated to store the result of a
  78    --  function returning an unconstrained or a tagged value. Expressions
  79    --  needing to be wrapped in a transient scope (functions calls returning
  80    --  unconstrained or tagged values) may appear in 3 different contexts which
  81    --  lead to 3 different kinds of transient scope expansion:
  82
  83    --   1. In a simple statement (procedure call, assignment, ...). In this
  84    --      case the instruction is wrapped into a transient block. See
  85    --      Wrap_Transient_Statement for details.
  86
  87    --   2. In an expression of a control structure (test in a IF statement,
  88    --      expression in a CASE statement, ...). See Wrap_Transient_Expression
  89    --      for details.
  90
  91    --   3. In a expression of an object_declaration. No wrapping is possible
  92    --      here, so the finalization actions, if any, are done right after the
  93    --      declaration and the secondary stack deallocation is done in the
  94    --      proper enclosing scope. See Wrap_Transient_Declaration for details.
  95
  96    --  Note about functions returning tagged types: it has been decided to
  97    --  always allocate their result in the secondary stack, even though is not
  98    --  absolutely mandatory when the tagged type is constrained because the
  99    --  caller knows the size of the returned object and thus could allocate the
 100    --  result in the primary stack. An exception to this is when the function
 101    --  builds its result in place, as is done for functions with inherently
 102    --  limited result types for Ada 2005. In that case, certain callers may
 103    --  pass the address of a constrained object as the target object for the
 104    --  function result.
 105
 106    --  By allocating tagged results in the secondary stack a number of
 107    --  implementation difficulties are avoided:
 108
 109    --    - If it is a dispatching function call, the computation of the size of
 110    --      the result is possible but complex from the outside.
 111
 112    --    - If the returned type is controlled, the assignment of the returned
 113    --      value to the anonymous object involves an Adjust, and we have no
 114    --      easy way to access the anonymous object created by the back end.
 115
 116    --    - If the returned type is class-wide, this is an unconstrained type
 117    --      anyway.
 118
 119    --  Furthermore, the small loss in efficiency which is the result of this
 120    --  decision is not such a big deal because functions returning tagged types
 121    --  are not as common in practice compared to functions returning access to
 122    --  a tagged type.
 123
 124    --------------------------------------------------
 125    -- Transient Blocks and Finalization Management --
 126    --------------------------------------------------
 127
 128    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
 129    --  N is a node which may generate a transient scope. Loop over the parent
 130    --  pointers of N until it find the appropriate node to wrap. If it returns
 131    --  Empty, it means that no transient scope is needed in this context.
 132
 133    procedure Insert_Actions_In_Scope_Around (N : Node_Id);
 134    --  Insert the before-actions kept in the scope stack before N, and the
 135    --  after-actions after N, which must be a member of a list.
 136
 137    function Make_Transient_Block
 138      (Loc    : Source_Ptr;
 139       Action : Node_Id;
 140       Par    : Node_Id) return Node_Id;
 141    --  Action is a single statement or object declaration. Par is the proper
 142    --  parent of the generated block. Create a transient block whose name is
 143    --  the current scope and the only handled statement is Action. If Action
 144    --  involves controlled objects or secondary stack usage, the corresponding
 145    --  cleanup actions are performed at the end of the block.
 146
 147    procedure Set_Node_To_Be_Wrapped (N : Node_Id);
 148    --  Set the field Node_To_Be_Wrapped of the current scope
 149
 150    --  ??? The entire comment needs to be rewritten
 151
 152    -----------------------------
 153    -- Finalization Management --
 154    -----------------------------
 155
 156    --  This part describe how Initialization/Adjustment/Finalization procedures
 157    --  are generated and called. Two cases must be considered, types that are
 158    --  Controlled (Is_Controlled flag set) and composite types that contain
 159    --  controlled components (Has_Controlled_Component flag set). In the first
 160    --  case the procedures to call are the user-defined primitive operations
 161    --  Initialize/Adjust/Finalize. In the second case, GNAT generates
 162    --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
 163    --  of calling the former procedures on the controlled components.
 164
 165    --  For records with Has_Controlled_Component set, a hidden "controller"
 166    --  component is inserted. This controller component contains its own
 167    --  finalization list on which all controlled components are attached
 168    --  creating an indirection on the upper-level Finalization list. This
 169    --  technique facilitates the management of objects whose number of
 170    --  controlled components changes during execution. This controller
 171    --  component is itself controlled and is attached to the upper-level
 172    --  finalization chain. Its adjust primitive is in charge of calling adjust
 173    --  on the components and adjusting the finalization pointer to match their
 174    --  new location (see a-finali.adb).
 175
 176    --  It is not possible to use a similar technique for arrays that have
 177    --  Has_Controlled_Component set. In this case, deep procedures are
 178    --  generated that call initialize/adjust/finalize + attachment or
 179    --  detachment on the finalization list for all component.
 180
 181    --  Initialize calls: they are generated for declarations or dynamic
 182    --  allocations of Controlled objects with no initial value. They are always
 183    --  followed by an attachment to the current Finalization Chain. For the
 184    --  dynamic allocation case this the chain attached to the scope of the
 185    --  access type definition otherwise, this is the chain of the current
 186    --  scope.
 187
 188    --  Adjust Calls: They are generated on 2 occasions: (1) for declarations
 189    --  or dynamic allocations of Controlled objects with an initial value.
 190    --  (2) after an assignment. In the first case they are followed by an
 191    --  attachment to the final chain, in the second case they are not.
 192
 193    --  Finalization Calls: They are generated on (1) scope exit, (2)
 194    --  assignments, (3) unchecked deallocations. In case (3) they have to
 195    --  be detached from the final chain, in case (2) they must not and in
 196    --  case (1) this is not important since we are exiting the scope anyway.
 197
 198    --  Other details:
 199
 200    --    Type extensions will have a new record controller at each derivation
 201    --    level containing controlled components. The record controller for
 202    --    the parent/ancestor is attached to the finalization list of the
 203    --    extension's record controller (i.e. the parent is like a component
 204    --    of the extension).
 205
 206    --    For types that are both Is_Controlled and Has_Controlled_Components,
 207    --    the record controller and the object itself are handled separately.
 208    --    It could seem simpler to attach the object at the end of its record
 209    --    controller but this would not tackle view conversions properly.
 210
 211    --    A classwide type can always potentially have controlled components
 212    --    but the record controller of the corresponding actual type may not
 213    --    be known at compile time so the dispatch table contains a special
 214    --    field that allows to compute the offset of the record controller
 215    --    dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
 216
 217    --  Here is a simple example of the expansion of a controlled block :
 218
 219    --    declare
 220    --       X : Controlled;
 221    --       Y : Controlled := Init;
 222    --
 223    --       type R is record
 224    --          C : Controlled;
 225    --       end record;
 226    --       W : R;
 227    --       Z : R := (C => X);
 228
 229    --    begin
 230    --       X := Y;
 231    --       W := Z;
 232    --    end;
 233    --
 234    --  is expanded into
 235    --
 236    --    declare
 237    --       _L : System.FI.Finalizable_Ptr;
 238
 239    --       procedure _Clean is
 240    --       begin
 241    --          Abort_Defer;
 242    --          System.FI.Finalize_List (_L);
 243    --          Abort_Undefer;
 244    --       end _Clean;
 245
 246    --       X : Controlled;
 247    --       begin
 248    --          Abort_Defer;
 249    --          Initialize (X);
 250    --          Attach_To_Final_List (_L, Finalizable (X), 1);
 251    --       at end: Abort_Undefer;
 252    --       Y : Controlled := Init;
 253    --       Adjust (Y);
 254    --       Attach_To_Final_List (_L, Finalizable (Y), 1);
 255    --
 256    --       type R is record
 257    --          C : Controlled;
 258    --       end record;
 259    --       W : R;
 260    --       begin
 261    --          Abort_Defer;
 262    --          Deep_Initialize (W, _L, 1);
 263    --       at end: Abort_Under;
 264    --       Z : R := (C => X);
 265    --       Deep_Adjust (Z, _L, 1);
 266
 267    --    begin
 268    --       _Assign (X, Y);
 269    --       Deep_Finalize (W, False);
 270    --       <save W's final pointers>
 271    --       W := Z;
 272    --       <restore W's final pointers>
 273    --       Deep_Adjust (W, _L, 0);
 274    --    at end
 275    --       _Clean;
 276    --    end;
 277
 278    type Final_Primitives is
 279      (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
 280    --  This enumeration type is defined in order to ease sharing code for
 281    --  building finalization procedures for composite types.
 282
 283    Name_Of      : constant array (Final_Primitives) of Name_Id :=
 284                     (Initialize_Case => Name_Initialize,
 285                      Adjust_Case     => Name_Adjust,
 286                      Finalize_Case   => Name_Finalize,
 287                      Address_Case    => Name_Finalize_Address);
 288    Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
 289                     (Initialize_Case => TSS_Deep_Initialize,
 290                      Adjust_Case     => TSS_Deep_Adjust,
 291                      Finalize_Case   => TSS_Deep_Finalize,
 292                      Address_Case    => TSS_Finalize_Address);
 293
 294    procedure Build_Array_Deep_Procs (Typ : Entity_Id);
 295    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 296    --  Has_Controlled_Component set and store them using the TSS mechanism.
 297
 298    function Build_Cleanup_Statements (N : Node_Id) return List_Id;
 299    --  Create the clean up calls for an asynchronous call block, task master,
 300    --  protected subprogram body, task allocation block or task body. If the
 301    --  context does not contain the above constructs, the routine returns an
 302    --  empty list.
 303
 304    procedure Build_Finalizer
 305      (N           : Node_Id;
 306       Clean_Stmts : List_Id;
 307       Mark_Id     : Entity_Id;
 308       Top_Decls   : List_Id;
 309       Defer_Abort : Boolean;
 310       Fin_Id      : out Entity_Id);
 311    --  N may denote an accept statement, block, entry body, package body,
 312    --  package spec, protected body, subprogram body, and a task body. Create
 313    --  a procedure which contains finalization calls for all controlled objects
 314    --  declared in the declarative or statement region of N. The calls are
 315    --  built in reverse order relative to the original declarations. In the
 316    --  case of a tack body, the routine delays the creation of the finalizer
 317    --  until all statements have been moved to the task body procedure.
 318    --  Clean_Stmts may contain additional context-dependent code used to abort
 319    --  asynchronous calls or complete tasks (see Build_Cleanup_Statements).
 320    --  Mark_Id is the secondary stack used in the current context or Empty if
 321    --  missing. Top_Decls is the list on which the declaration of the finalizer
 322    --  is attached in the non-package case. Defer_Abort indicates that the
 323    --  statements passed in perform actions that require abort to be deferred,
 324    --  such as for task termination. Fin_Id is the finalizer declaration
 325    --  entity.
 326
 327    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
 328    --  N is a construct which contains a handled sequence of statements, Fin_Id
 329    --  is the entity of a finalizer. Create an At_End handler which covers the
 330    --  statements of N and calls Fin_Id. If the handled statement sequence has
 331    --  an exception handler, the statements will be wrapped in a block to avoid
 332    --  unwanted interaction with the new At_End handler.
 333
 334    procedure Build_Record_Deep_Procs (Typ : Entity_Id);
 335    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 336    --  Has_Component_Component set and store them using the TSS mechanism.
 337
 338    procedure Check_Visibly_Controlled
 339      (Prim : Final_Primitives;
 340       Typ  : Entity_Id;
 341       E    : in out Entity_Id;
 342       Cref : in out Node_Id);
 343    --  The controlled operation declared for a derived type may not be
 344    --  overriding, if the controlled operations of the parent type are hidden,
 345    --  for example when the parent is a private type whose full view is
 346    --  controlled. For other primitive operations we modify the name of the
 347    --  operation to indicate that it is not overriding, but this is not
 348    --  possible for Initialize, etc. because they have to be retrievable by
 349    --  name. Before generating the proper call to one of these operations we
 350    --  check whether Typ is known to be controlled at the point of definition.
 351    --  If it is not then we must retrieve the hidden operation of the parent
 352    --  and use it instead.  This is one case that might be solved more cleanly
 353    --  once Overriding pragmas or declarations are in place.
 354
 355    function Convert_View
 356      (Proc : Entity_Id;
 357       Arg  : Node_Id;
 358       Ind  : Pos := 1) return Node_Id;
 359    --  Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
 360    --  argument being passed to it. Ind indicates which formal of procedure
 361    --  Proc we are trying to match. This function will, if necessary, generate
 362    --  a conversion between the partial and full view of Arg to match the type
 363    --  of the formal of Proc, or force a conversion to the class-wide type in
 364    --  the case where the operation is abstract.
 365
 366    function Enclosing_Function (E : Entity_Id) return Entity_Id;
 367    --  Given an arbitrary entity, traverse the scope chain looking for the
 368    --  first enclosing function. Return Empty if no function was found.
 369
 370    function Make_Call
 371      (Loc        : Source_Ptr;
 372       Proc_Id    : Entity_Id;
 373       Param      : Node_Id;
 374       For_Parent : Boolean := False) return Node_Id;
 375    --  Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
 376    --  routine [Deep_]Adjust / Finalize and an object parameter, create an
 377    --  adjust / finalization call. Flag For_Parent should be set when field
 378    --  _parent is being processed.
 379
 380    function Make_Deep_Proc
 381      (Prim  : Final_Primitives;
 382       Typ   : Entity_Id;
 383       Stmts : List_Id) return Node_Id;
 384    --  This function generates the tree for Deep_Initialize, Deep_Adjust or
 385    --  Deep_Finalize procedures according to the first parameter, these
 386    --  procedures operate on the type Typ. The Stmts parameter gives the body
 387    --  of the procedure.
 388
 389    function Make_Deep_Array_Body
 390      (Prim : Final_Primitives;
 391       Typ  : Entity_Id) return List_Id;
 392    --  This function generates the list of statements for implementing
 393    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
 394    --  the first parameter, these procedures operate on the array type Typ.
 395
 396    function Make_Deep_Record_Body
 397      (Prim     : Final_Primitives;
 398       Typ      : Entity_Id;
 399       Is_Local : Boolean := False) return List_Id;
 400    --  This function generates the list of statements for implementing
 401    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
 402    --  the first parameter, these procedures operate on the record type Typ.
 403    --  Flag Is_Local is used in conjunction with Deep_Finalize to designate
 404    --  whether the inner logic should be dictated by state counters.
 405
 406    function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
 407    --  Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
 408    --  Make_Deep_Record_Body. Generate the following statements:
 409    --
 410    --    declare
 411    --       type Acc_Typ is access all Typ;
 412    --       for Acc_Typ'Storage_Size use 0;
 413    --    begin
 414    --       [Deep_]Finalize (Acc_Typ (V).all);
 415    --    end;
 416
 417    ----------------------------
 418    -- Build_Array_Deep_Procs --
 419    ----------------------------
 420
 421    procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
 422    begin
 423       Set_TSS (Typ,
 424         Make_Deep_Proc
 425           (Prim  => Initialize_Case,
 426            Typ   => Typ,
 427            Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 428
 429       if not Is_Immutably_Limited_Type (Typ) then
 430          Set_TSS (Typ,
 431            Make_Deep_Proc
 432              (Prim  => Adjust_Case,
 433               Typ   => Typ,
 434               Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
 435       end if;
 436
 437       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
 438       --  suppressed since these routine will not be used.
 439
 440       if not Restriction_Active (No_Finalization) then
 441          Set_TSS (Typ,
 442            Make_Deep_Proc
 443              (Prim  => Finalize_Case,
 444               Typ   => Typ,
 445               Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
 446
 447          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
 448          --  .NET do not support address arithmetic and unchecked conversions.
 449
 450          if VM_Target = No_VM then
 451             Set_TSS (Typ,
 452               Make_Deep_Proc
 453                 (Prim  => Address_Case,
 454                  Typ   => Typ,
 455                  Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
 456          end if;
 457       end if;
 458    end Build_Array_Deep_Procs;
 459
 460    ------------------------------
 461    -- Build_Cleanup_Statements --
 462    ------------------------------
 463
 464    function Build_Cleanup_Statements (N : Node_Id) return List_Id is
 465       Is_Asynchronous_Call : constant Boolean :=
 466                                Nkind (N) = N_Block_Statement
 467                                  and then Is_Asynchronous_Call_Block (N);
 468       Is_Master            : constant Boolean :=
 469                                Nkind (N) /= N_Entry_Body
 470                                  and then Is_Task_Master (N);
 471       Is_Protected_Body    : constant Boolean :=
 472                                Nkind (N) = N_Subprogram_Body
 473                                  and then Is_Protected_Subprogram_Body (N);
 474       Is_Task_Allocation   : constant Boolean :=
 475                                Nkind (N) = N_Block_Statement
 476                                  and then Is_Task_Allocation_Block (N);
 477       Is_Task_Body         : constant Boolean :=
 478                                Nkind (Original_Node (N)) = N_Task_Body;
 479
 480       Loc   : constant Source_Ptr := Sloc (N);
 481       Stmts : constant List_Id    := New_List;
 482
 483    begin
 484       if Is_Task_Body then
 485          if Restricted_Profile then
 486             Append_To (Stmts,
 487               Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
 488          else
 489             Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
 490          end if;
 491
 492       elsif Is_Master then
 493          if Restriction_Active (No_Task_Hierarchy) = False then
 494             Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
 495          end if;
 496
 497       --  Add statements to unlock the protected object parameter and to
 498       --  undefer abort. If the context is a protected procedure and the object
 499       --  has entries, call the entry service routine.
 500
 501       --  NOTE: The generated code references _object, a parameter to the
 502       --  procedure.
 503
 504       elsif Is_Protected_Body then
 505          declare
 506             Spec      : constant Node_Id := Parent (Corresponding_Spec (N));
 507             Conc_Typ  : Entity_Id;
 508             Nam       : Node_Id;
 509             Param     : Node_Id;
 510             Param_Typ : Entity_Id;
 511
 512          begin
 513             --  Find the _object parameter representing the protected object
 514
 515             Param := First (Parameter_Specifications (Spec));
 516             loop
 517                Param_Typ := Etype (Parameter_Type (Param));
 518
 519                if Ekind (Param_Typ) = E_Record_Type then
 520                   Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
 521                end if;
 522
 523                exit when No (Param) or else Present (Conc_Typ);
 524                Next (Param);
 525             end loop;
 526
 527             pragma Assert (Present (Param));
 528
 529             --  If the associated protected object has entries, a protected
 530             --  procedure has to service entry queues. In this case generate:
 531
 532             --    Service_Entries (_object._object'Access);
 533
 534             if Nkind (Specification (N)) = N_Procedure_Specification
 535               and then Has_Entries (Conc_Typ)
 536             then
 537                case Corresponding_Runtime_Package (Conc_Typ) is
 538                   when System_Tasking_Protected_Objects_Entries =>
 539                      Nam := New_Reference_To (RTE (RE_Service_Entries), Loc);
 540
 541                   when System_Tasking_Protected_Objects_Single_Entry =>
 542                      Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);
 543
 544                   when others =>
 545                      raise Program_Error;
 546                end case;
 547
 548                Append_To (Stmts,
 549                  Make_Procedure_Call_Statement (Loc,
 550                    Name                   => Nam,
 551                    Parameter_Associations => New_List (
 552                      Make_Attribute_Reference (Loc,
 553                        Prefix         =>
 554                          Make_Selected_Component (Loc,
 555                            Prefix        => New_Reference_To (
 556                              Defining_Identifier (Param), Loc),
 557                            Selector_Name =>
 558                              Make_Identifier (Loc, Name_uObject)),
 559                        Attribute_Name => Name_Unchecked_Access))));
 560
 561             else
 562                --  Generate:
 563                --    Unlock (_object._object'Access);
 564
 565                case Corresponding_Runtime_Package (Conc_Typ) is
 566                   when System_Tasking_Protected_Objects_Entries =>
 567                      Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
 568
 569                   when System_Tasking_Protected_Objects_Single_Entry =>
 570                      Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
 571
 572                   when System_Tasking_Protected_Objects =>
 573                      Nam := New_Reference_To (RTE (RE_Unlock), Loc);
 574
 575                   when others =>
 576                      raise Program_Error;
 577                end case;
 578
 579                Append_To (Stmts,
 580                  Make_Procedure_Call_Statement (Loc,
 581                    Name                   => Nam,
 582                    Parameter_Associations => New_List (
 583                      Make_Attribute_Reference (Loc,
 584                        Prefix         =>
 585                          Make_Selected_Component (Loc,
 586                            Prefix        =>
 587                              New_Reference_To
 588                                (Defining_Identifier (Param), Loc),
 589                            Selector_Name =>
 590                              Make_Identifier (Loc, Name_uObject)),
 591                        Attribute_Name => Name_Unchecked_Access))));
 592             end if;
 593
 594             --  Generate:
 595             --    Abort_Undefer;
 596
 597             if Abort_Allowed then
 598                Append_To (Stmts,
 599                  Make_Procedure_Call_Statement (Loc,
 600                    Name                   =>
 601                      New_Reference_To (RTE (RE_Abort_Undefer), Loc),
 602                    Parameter_Associations => Empty_List));
 603             end if;
 604          end;
 605
 606       --  Add a call to Expunge_Unactivated_Tasks for dynamically allocated
 607       --  tasks. Other unactivated tasks are completed by Complete_Task or
 608       --  Complete_Master.
 609
 610       --  NOTE: The generated code references _chain, a local object
 611
 612       elsif Is_Task_Allocation then
 613
 614          --  Generate:
 615          --     Expunge_Unactivated_Tasks (_chain);
 616
 617          --  where _chain is the list of tasks created by the allocator but not
 618          --  yet activated. This list will be empty unless the block completes
 619          --  abnormally.
 620
 621          Append_To (Stmts,
 622            Make_Procedure_Call_Statement (Loc,
 623              Name =>
 624                New_Reference_To
 625                  (RTE (RE_Expunge_Unactivated_Tasks), Loc),
 626              Parameter_Associations => New_List (
 627                New_Reference_To (Activation_Chain_Entity (N), Loc))));
 628
 629       --  Attempt to cancel an asynchronous entry call whenever the block which
 630       --  contains the abortable part is exited.
 631
 632       --  NOTE: The generated code references Cnn, a local object
 633
 634       elsif Is_Asynchronous_Call then
 635          declare
 636             Cancel_Param : constant Entity_Id :=
 637                              Entry_Cancel_Parameter (Entity (Identifier (N)));
 638
 639          begin
 640             --  If it is of type Communication_Block, this must be a protected
 641             --  entry call. Generate:
 642
 643             --    if Enqueued (Cancel_Param) then
 644             --       Cancel_Protected_Entry_Call (Cancel_Param);
 645             --    end if;
 646
 647             if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
 648                Append_To (Stmts,
 649                  Make_If_Statement (Loc,
 650                    Condition =>
 651                      Make_Function_Call (Loc,
 652                        Name                   =>
 653                          New_Reference_To (RTE (RE_Enqueued), Loc),
 654                        Parameter_Associations => New_List (
 655                          New_Reference_To (Cancel_Param, Loc))),
 656
 657                    Then_Statements => New_List (
 658                      Make_Procedure_Call_Statement (Loc,
 659                        Name =>
 660                          New_Reference_To
 661                            (RTE (RE_Cancel_Protected_Entry_Call), Loc),
 662                          Parameter_Associations => New_List (
 663                            New_Reference_To (Cancel_Param, Loc))))));
 664
 665             --  Asynchronous delay, generate:
 666             --    Cancel_Async_Delay (Cancel_Param);
 667
 668             elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
 669                Append_To (Stmts,
 670                  Make_Procedure_Call_Statement (Loc,
 671                    Name                   =>
 672                      New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
 673                    Parameter_Associations => New_List (
 674                      Make_Attribute_Reference (Loc,
 675                        Prefix         =>
 676                          New_Reference_To (Cancel_Param, Loc),
 677                        Attribute_Name => Name_Unchecked_Access))));
 678
 679             --  Task entry call, generate:
 680             --    Cancel_Task_Entry_Call (Cancel_Param);
 681
 682             else
 683                Append_To (Stmts,
 684                  Make_Procedure_Call_Statement (Loc,
 685                    Name                   =>
 686                      New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc),
 687                    Parameter_Associations => New_List (
 688                      New_Reference_To (Cancel_Param, Loc))));
 689             end if;
 690          end;
 691       end if;
 692
 693       return Stmts;
 694    end Build_Cleanup_Statements;
 695
 696    -----------------------------
 697    -- Build_Controlling_Procs --
 698    -----------------------------
 699
 700    procedure Build_Controlling_Procs (Typ : Entity_Id) is
 701    begin
 702       if Is_Array_Type (Typ) then
 703          Build_Array_Deep_Procs (Typ);
 704       else pragma Assert (Is_Record_Type (Typ));
 705          Build_Record_Deep_Procs (Typ);
 706       end if;
 707    end Build_Controlling_Procs;
 708
 709    -----------------------------
 710    -- Build_Exception_Handler --
 711    -----------------------------
 712
 713    function Build_Exception_Handler
 714      (Data        : Finalization_Exception_Data;
 715       For_Library : Boolean := False) return Node_Id
 716    is
 717       Actuals      : List_Id;
 718       Proc_To_Call : Entity_Id;
 719
 720    begin
 721       pragma Assert (Present (Data.E_Id));
 722       pragma Assert (Present (Data.Raised_Id));
 723
 724       --  Generate:
 725       --    Get_Current_Excep.all.all
 726
 727       Actuals := New_List (
 728         Make_Explicit_Dereference (Data.Loc,
 729           Prefix =>
 730             Make_Function_Call (Data.Loc,
 731               Name =>
 732                 Make_Explicit_Dereference (Data.Loc,
 733                   Prefix =>
 734                     New_Reference_To (RTE (RE_Get_Current_Excep),
 735                                       Data.Loc)))));
 736
 737       if For_Library and then not Restricted_Profile then
 738          Proc_To_Call := RTE (RE_Save_Library_Occurrence);
 739
 740       else
 741          Proc_To_Call := RTE (RE_Save_Occurrence);
 742          Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc));
 743       end if;
 744
 745       --  Generate:
 746       --    when others =>
 747       --       if not Raised_Id then
 748       --          Raised_Id := True;
 749
 750       --          Save_Occurrence (E_Id, Get_Current_Excep.all.all);
 751       --            or
 752       --          Save_Library_Occurrence (Get_Current_Excep.all.all);
 753       --       end if;
 754
 755       return
 756         Make_Exception_Handler (Data.Loc,
 757           Exception_Choices =>
 758             New_List (Make_Others_Choice (Data.Loc)),
 759           Statements => New_List (
 760             Make_If_Statement (Data.Loc,
 761               Condition       =>
 762                 Make_Op_Not (Data.Loc,
 763                   Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),
 764
 765               Then_Statements => New_List (
 766                 Make_Assignment_Statement (Data.Loc,
 767                   Name       => New_Reference_To (Data.Raised_Id, Data.Loc),
 768                   Expression => New_Reference_To (Standard_True, Data.Loc)),
 769
 770                 Make_Procedure_Call_Statement (Data.Loc,
 771                   Name                   =>
 772                     New_Reference_To (Proc_To_Call, Data.Loc),
 773                   Parameter_Associations => Actuals)))));
 774    end Build_Exception_Handler;
 775
 776    -------------------------------
 777    -- Build_Finalization_Master --
 778    -------------------------------
 779
 780    procedure Build_Finalization_Master
 781      (Typ        : Entity_Id;
 782       Ins_Node   : Node_Id := Empty;
 783       Encl_Scope : Entity_Id := Empty)
 784    is
 785       Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
 786       Ptr_Typ   : Entity_Id := Root_Type (Base_Type (Typ));
 787
 788       function In_Deallocation_Instance (E : Entity_Id) return Boolean;
 789       --  Determine whether entity E is inside a wrapper package created for
 790       --  an instance of Ada.Unchecked_Deallocation.
 791
 792       ------------------------------
 793       -- In_Deallocation_Instance --
 794       ------------------------------
 795
 796       function In_Deallocation_Instance (E : Entity_Id) return Boolean is
 797          Pkg : constant Entity_Id := Scope (E);
 798          Par : Node_Id := Empty;
 799
 800       begin
 801          if Ekind (Pkg) = E_Package
 802            and then Present (Related_Instance (Pkg))
 803            and then Ekind (Related_Instance (Pkg)) = E_Procedure
 804          then
 805             Par := Generic_Parent (Parent (Related_Instance (Pkg)));
 806
 807             return
 808               Present (Par)
 809                 and then Chars (Par) = Name_Unchecked_Deallocation
 810                 and then Chars (Scope (Par)) = Name_Ada
 811                 and then Scope (Scope (Par)) = Standard_Standard;
 812          end if;
 813
 814          return False;
 815       end In_Deallocation_Instance;
 816
 817    --  Start of processing for Build_Finalization_Master
 818
 819    begin
 820       if Is_Private_Type (Ptr_Typ)
 821         and then Present (Full_View (Ptr_Typ))
 822       then
 823          Ptr_Typ := Full_View (Ptr_Typ);
 824       end if;
 825
 826       --  Certain run-time configurations and targets do not provide support
 827       --  for controlled types.
 828
 829       if Restriction_Active (No_Finalization) then
 830          return;
 831
 832       --  Do not process C, C++, CIL and Java types since it is assumend that
 833       --  the non-Ada side will handle their clean up.
 834
 835       elsif Convention (Desig_Typ) = Convention_C
 836         or else Convention (Desig_Typ) = Convention_CIL
 837         or else Convention (Desig_Typ) = Convention_CPP
 838         or else Convention (Desig_Typ) = Convention_Java
 839       then
 840          return;
 841
 842       --  Various machinery such as freezing may have already created a
 843       --  finalization master.
 844
 845       elsif Present (Finalization_Master (Ptr_Typ)) then
 846          return;
 847
 848       --  Do not process types that return on the secondary stack
 849
 850       elsif Present (Associated_Storage_Pool (Ptr_Typ))
 851         and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
 852       then
 853          return;
 854
 855       --  Do not process types which may never allocate an object
 856
 857       elsif No_Pool_Assigned (Ptr_Typ) then
 858          return;
 859
 860       --  Do not process access types coming from Ada.Unchecked_Deallocation
 861       --  instances. Even though the designated type may be controlled, the
 862       --  access type will never participate in allocation.
 863
 864       elsif In_Deallocation_Instance (Ptr_Typ) then
 865          return;
 866
 867       --  Ignore the general use of anonymous access types unless the context
 868       --  requires a finalization master.
 869
 870       elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
 871         and then No (Ins_Node)
 872       then
 873          return;
 874
 875       --  Do not process non-library access types when restriction No_Nested_
 876       --  Finalization is in effect since masters are controlled objects.
 877
 878       elsif Restriction_Active (No_Nested_Finalization)
 879         and then not Is_Library_Level_Entity (Ptr_Typ)
 880       then
 881          return;
 882
 883       --  For .NET/JVM targets, allow the processing of access-to-controlled
 884       --  types where the designated type is explicitly derived from [Limited_]
 885       --  Controlled.
 886
 887       elsif VM_Target /= No_VM
 888         and then not Is_Controlled (Desig_Typ)
 889       then
 890          return;
 891
 892       --  Do not create finalization masters in Alfa mode because they result
 893       --  in unwanted expansion.
 894
 895       elsif Alfa_Mode then
 896          return;
 897       end if;
 898
 899       declare
 900          Loc        : constant Source_Ptr := Sloc (Ptr_Typ);
 901          Actions    : constant List_Id := New_List;
 902          Fin_Mas_Id : Entity_Id;
 903          Pool_Id    : Entity_Id;
 904
 905       begin
 906          --  Generate:
 907          --    Fnn : aliased Finalization_Master;
 908
 909          --  Source access types use fixed master names since the master is
 910          --  inserted in the same source unit only once. The only exception to
 911          --  this are instances using the same access type as generic actual.
 912
 913          if Comes_From_Source (Ptr_Typ)
 914            and then not Inside_A_Generic
 915          then
 916             Fin_Mas_Id :=
 917               Make_Defining_Identifier (Loc,
 918                 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
 919
 920          --  Internally generated access types use temporaries as their names
 921          --  due to possible collision with identical names coming from other
 922          --  packages.
 923
 924          else
 925             Fin_Mas_Id := Make_Temporary (Loc, 'F');
 926          end if;
 927
 928          Append_To (Actions,
 929            Make_Object_Declaration (Loc,
 930              Defining_Identifier => Fin_Mas_Id,
 931              Aliased_Present     => True,
 932              Object_Definition   =>
 933                New_Reference_To (RTE (RE_Finalization_Master), Loc)));
 934
 935          --  Storage pool selection and attribute decoration of the generated
 936          --  master. Since .NET/JVM compilers do not support pools, this step
 937          --  is skipped.
 938
 939          if VM_Target = No_VM then
 940
 941             --  If the access type has a user-defined pool, use it as the base
 942             --  storage medium for the finalization pool.
 943
 944             if Present (Associated_Storage_Pool (Ptr_Typ)) then
 945                Pool_Id := Associated_Storage_Pool (Ptr_Typ);
 946
 947             --  The default choice is the global pool
 948
 949             else
 950                Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
 951                Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
 952             end if;
 953
 954             --  Generate:
 955             --    Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
 956
 957             Append_To (Actions,
 958               Make_Procedure_Call_Statement (Loc,
 959                 Name                   =>
 960                   New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
 961                 Parameter_Associations => New_List (
 962                   New_Reference_To (Fin_Mas_Id, Loc),
 963                   Make_Attribute_Reference (Loc,
 964                     Prefix         => New_Reference_To (Pool_Id, Loc),
 965                     Attribute_Name => Name_Unrestricted_Access))));
 966          end if;
 967
 968          Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
 969
 970          --  A finalization master created for an anonymous access type must be
 971          --  inserted before a context-dependent node.
 972
 973          if Present (Ins_Node) then
 974             Push_Scope (Encl_Scope);
 975
 976             --  Treat use clauses as declarations and insert directly in front
 977             --  of them.
 978
 979             if Nkind_In (Ins_Node, N_Use_Package_Clause,
 980                                    N_Use_Type_Clause)
 981             then
 982                Insert_List_Before_And_Analyze (Ins_Node, Actions);
 983             else
 984                Insert_Actions (Ins_Node, Actions);
 985             end if;
 986
 987             Pop_Scope;
 988
 989          elsif Ekind (Desig_Typ) = E_Incomplete_Type
 990            and then Has_Completion_In_Body (Desig_Typ)
 991          then
 992             Insert_Actions (Parent (Ptr_Typ), Actions);
 993
 994          --  If the designated type is not yet frozen, then append the actions
 995          --  to that type's freeze actions. The actions need to be appended to
 996          --  whichever type is frozen later, similarly to what Freeze_Type does
 997          --  for appending the storage pool declaration for an access type.
 998          --  Otherwise, the call to Set_Storage_Pool_Ptr might reference the
 999          --  pool object before it's declared. However, it's not clear that
1000          --  this is exactly the right test to accomplish that here. ???
1001
1002          elsif Present (Freeze_Node (Desig_Typ))
1003            and then not Analyzed (Freeze_Node (Desig_Typ))
1004          then
1005             Append_Freeze_Actions (Desig_Typ, Actions);
1006
1007          elsif Present (Freeze_Node (Ptr_Typ))
1008            and then not Analyzed (Freeze_Node (Ptr_Typ))
1009          then
1010             Append_Freeze_Actions (Ptr_Typ, Actions);
1011
1012          --  If there's a pool created locally for the access type, then we
1013          --  need to ensure that the master gets created after the pool object,
1014          --  because otherwise we can have a forward reference, so we force the
1015          --  master actions to be inserted and analyzed after the pool entity.
1016          --  Note that both the access type and its designated type may have
1017          --  already been frozen and had their freezing actions analyzed at
1018          --  this point. (This seems a little unclean.???)
1019
1020          elsif VM_Target = No_VM
1021            and then Scope (Pool_Id) = Scope (Ptr_Typ)
1022          then
1023             Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
1024
1025          else
1026             Insert_Actions (Parent (Ptr_Typ), Actions);
1027          end if;
1028       end;
1029    end Build_Finalization_Master;
1030
1031    ---------------------
1032    -- Build_Finalizer --
1033    ---------------------
1034
1035    procedure Build_Finalizer
1036      (N           : Node_Id;
1037       Clean_Stmts : List_Id;
1038       Mark_Id     : Entity_Id;
1039       Top_Decls   : List_Id;
1040       Defer_Abort : Boolean;
1041       Fin_Id      : out Entity_Id)
1042    is
1043       Acts_As_Clean    : constant Boolean :=
1044                            Present (Mark_Id)
1045                              or else
1046                                (Present (Clean_Stmts)
1047                                  and then Is_Non_Empty_List (Clean_Stmts));
1048       Exceptions_OK    : constant Boolean :=
1049                            not Restriction_Active (No_Exception_Propagation);
1050       For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1051       For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1052       For_Package      : constant Boolean :=
1053                            For_Package_Body or else For_Package_Spec;
1054       Loc              : constant Source_Ptr := Sloc (N);
1055
1056       --  NOTE: Local variable declarations are conservative and do not create
1057       --  structures right from the start. Entities and lists are created once
1058       --  it has been established that N has at least one controlled object.
1059
1060       Components_Built : Boolean := False;
1061       --  A flag used to avoid double initialization of entities and lists. If
1062       --  the flag is set then the following variables have been initialized:
1063       --    Counter_Id
1064       --    Finalizer_Decls
1065       --    Finalizer_Stmts
1066       --    Jump_Alts
1067
1068       Counter_Id  : Entity_Id := Empty;
1069       Counter_Val : Int       := 0;
1070       --  Name and value of the state counter
1071
1072       Decls : List_Id := No_List;
1073       --  Declarative region of N (if available). If N is a package declaration
1074       --  Decls denotes the visible declarations.
1075
1076       Finalizer_Data : Finalization_Exception_Data;
1077       --  Data for the exception
1078
1079       Finalizer_Decls : List_Id := No_List;
1080       --  Local variable declarations. This list holds the label declarations
1081       --  of all jump block alternatives as well as the declaration of the
1082       --  local exception occurence and the raised flag:
1083       --     E : Exception_Occurrence;
1084       --     Raised : Boolean := False;
1085       --     L<counter value> : label;
1086
1087       Finalizer_Insert_Nod : Node_Id := Empty;
1088       --  Insertion point for the finalizer body. Depending on the context
1089       --  (Nkind of N) and the individual grouping of controlled objects, this
1090       --  node may denote a package declaration or body, package instantiation,
1091       --  block statement or a counter update statement.
1092
1093       Finalizer_Stmts : List_Id := No_List;
1094       --  The statement list of the finalizer body. It contains the following:
1095       --
1096       --    Abort_Defer;               --  Added if abort is allowed
1097       --    <call to Prev_At_End>      --  Added if exists
1098       --    <cleanup statements>       --  Added if Acts_As_Clean
1099       --    <jump block>               --  Added if Has_Ctrl_Objs
1100       --    <finalization statements>  --  Added if Has_Ctrl_Objs
1101       --    <stack release>            --  Added if Mark_Id exists
1102       --    Abort_Undefer;             --  Added if abort is allowed
1103
1104       Has_Ctrl_Objs : Boolean := False;
1105       --  A general flag which denotes whether N has at least one controlled
1106       --  object.
1107
1108       Has_Tagged_Types : Boolean := False;
1109       --  A general flag which indicates whether N has at least one library-
1110       --  level tagged type declaration.
1111
1112       HSS : Node_Id := Empty;
1113       --  The sequence of statements of N (if available)
1114
1115       Jump_Alts : List_Id := No_List;
1116       --  Jump block alternatives. Depending on the value of the state counter,
1117       --  the control flow jumps to a sequence of finalization statements. This
1118       --  list contains the following:
1119       --
1120       --     when <counter value> =>
1121       --        goto L<counter value>;
1122
1123       Jump_Block_Insert_Nod : Node_Id := Empty;
1124       --  Specific point in the finalizer statements where the jump block is
1125       --  inserted.
1126
1127       Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1128       --  The last controlled construct encountered when processing the top
1129       --  level lists of N. This can be a nested package, an instantiation or
1130       --  an object declaration.
1131
1132       Prev_At_End : Entity_Id := Empty;
1133       --  The previous at end procedure of the handled statements block of N
1134
1135       Priv_Decls : List_Id := No_List;
1136       --  The private declarations of N if N is a package declaration
1137
1138       Spec_Id    : Entity_Id := Empty;
1139       Spec_Decls : List_Id   := Top_Decls;
1140       Stmts      : List_Id   := No_List;
1141
1142       Tagged_Type_Stmts : List_Id := No_List;
1143       --  Contains calls to Ada.Tags.Unregister_Tag for all library-level
1144       --  tagged types found in N.
1145
1146       -----------------------
1147       -- Local subprograms --
1148       -----------------------
1149
1150       procedure Build_Components;
1151       --  Create all entites and initialize all lists used in the creation of
1152       --  the finalizer.
1153
1154       procedure Create_Finalizer;
1155       --  Create the spec and body of the finalizer and insert them in the
1156       --  proper place in the tree depending on the context.
1157
1158       procedure Process_Declarations
1159         (Decls      : List_Id;
1160          Preprocess : Boolean := False;
1161          Top_Level  : Boolean := False);
1162       --  Inspect a list of declarations or statements which may contain
1163       --  objects that need finalization. When flag Preprocess is set, the
1164       --  routine will simply count the total number of controlled objects in
1165       --  Decls. Flag Top_Level denotes whether the processing is done for
1166       --  objects in nested package declarations or instances.
1167
1168       procedure Process_Object_Declaration
1169         (Decl         : Node_Id;
1170          Has_No_Init  : Boolean := False;
1171          Is_Protected : Boolean := False);
1172       --  Generate all the machinery associated with the finalization of a
1173       --  single object. Flag Has_No_Init is used to denote certain contexts
1174       --  where Decl does not have initialization call(s). Flag Is_Protected
1175       --  is set when Decl denotes a simple protected object.
1176
1177       procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1178       --  Generate all the code necessary to unregister the external tag of a
1179       --  tagged type.
1180
1181       ----------------------
1182       -- Build_Components --
1183       ----------------------
1184
1185       procedure Build_Components is
1186          Counter_Decl     : Node_Id;
1187          Counter_Typ      : Entity_Id;
1188          Counter_Typ_Decl : Node_Id;
1189
1190       begin
1191          pragma Assert (Present (Decls));
1192
1193          --  This routine might be invoked several times when dealing with
1194          --  constructs that have two lists (either two declarative regions
1195          --  or declarations and statements). Avoid double initialization.
1196
1197          if Components_Built then
1198             return;
1199          end if;
1200
1201          Components_Built := True;
1202
1203          if Has_Ctrl_Objs then
1204
1205             --  Create entities for the counter, its type, the local exception
1206             --  and the raised flag.
1207
1208             Counter_Id  := Make_Temporary (Loc, 'C');
1209             Counter_Typ := Make_Temporary (Loc, 'T');
1210
1211             Finalizer_Decls := New_List;
1212
1213             Build_Object_Declarations
1214               (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1215
1216             --  Since the total number of controlled objects is always known,
1217             --  build a subtype of Natural with precise bounds. This allows
1218             --  the backend to optimize the case statement. Generate:
1219             --
1220             --    subtype Tnn is Natural range 0 .. Counter_Val;
1221
1222             Counter_Typ_Decl :=
1223               Make_Subtype_Declaration (Loc,
1224                 Defining_Identifier => Counter_Typ,
1225                 Subtype_Indication  =>
1226                   Make_Subtype_Indication (Loc,
1227                     Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
1228                     Constraint   =>
1229                       Make_Range_Constraint (Loc,
1230                         Range_Expression =>
1231                           Make_Range (Loc,
1232                             Low_Bound  =>
1233                               Make_Integer_Literal (Loc, Uint_0),
1234                             High_Bound =>
1235                               Make_Integer_Literal (Loc, Counter_Val)))));
1236
1237             --  Generate the declaration of the counter itself:
1238             --
1239             --    Counter : Integer := 0;
1240
1241             Counter_Decl :=
1242               Make_Object_Declaration (Loc,
1243                 Defining_Identifier => Counter_Id,
1244                 Object_Definition   => New_Reference_To (Counter_Typ, Loc),
1245                 Expression          => Make_Integer_Literal (Loc, 0));
1246
1247             --  Set the type of the counter explicitly to prevent errors when
1248             --  examining object declarations later on.
1249
1250             Set_Etype (Counter_Id, Counter_Typ);
1251
1252             --  The counter and its type are inserted before the source
1253             --  declarations of N.
1254
1255             Prepend_To (Decls, Counter_Decl);
1256             Prepend_To (Decls, Counter_Typ_Decl);
1257
1258             --  The counter and its associated type must be manually analized
1259             --  since N has already been analyzed. Use the scope of the spec
1260             --  when inserting in a package.
1261
1262             if For_Package then
1263                Push_Scope (Spec_Id);
1264                Analyze (Counter_Typ_Decl);
1265                Analyze (Counter_Decl);
1266                Pop_Scope;
1267
1268             else
1269                Analyze (Counter_Typ_Decl);
1270                Analyze (Counter_Decl);
1271             end if;
1272
1273             Jump_Alts := New_List;
1274          end if;
1275
1276          --  If the context requires additional clean up, the finalization
1277          --  machinery is added after the clean up code.
1278
1279          if Acts_As_Clean then
1280             Finalizer_Stmts       := Clean_Stmts;
1281             Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1282          else
1283             Finalizer_Stmts := New_List;
1284          end if;
1285
1286          if Has_Tagged_Types then
1287             Tagged_Type_Stmts := New_List;
1288          end if;
1289       end Build_Components;
1290
1291       ----------------------
1292       -- Create_Finalizer --
1293       ----------------------
1294
1295       procedure Create_Finalizer is
1296          Body_Id    : Entity_Id;
1297          Fin_Body   : Node_Id;
1298          Fin_Spec   : Node_Id;
1299          Jump_Block : Node_Id;
1300          Label      : Node_Id;
1301          Label_Id   : Entity_Id;
1302
1303          function New_Finalizer_Name return Name_Id;
1304          --  Create a fully qualified name of a package spec or body finalizer.
1305          --  The generated name is of the form: xx__yy__finalize_[spec|body].
1306
1307          ------------------------
1308          -- New_Finalizer_Name --
1309          ------------------------
1310
1311          function New_Finalizer_Name return Name_Id is
1312             procedure New_Finalizer_Name (Id : Entity_Id);
1313             --  Place "__<name-of-Id>" in the name buffer. If the identifier
1314             --  has a non-standard scope, process the scope first.
1315
1316             ------------------------
1317             -- New_Finalizer_Name --
1318             ------------------------
1319
1320             procedure New_Finalizer_Name (Id : Entity_Id) is
1321             begin
1322                if Scope (Id) = Standard_Standard then
1323                   Get_Name_String (Chars (Id));
1324
1325                else
1326                   New_Finalizer_Name (Scope (Id));
1327                   Add_Str_To_Name_Buffer ("__");
1328                   Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1329                end if;
1330             end New_Finalizer_Name;
1331
1332          --  Start of processing for New_Finalizer_Name
1333
1334          begin
1335             --  Create the fully qualified name of the enclosing scope
1336
1337             New_Finalizer_Name (Spec_Id);
1338
1339             --  Generate:
1340             --    __finalize_[spec|body]
1341
1342             Add_Str_To_Name_Buffer ("__finalize_");
1343
1344             if For_Package_Spec then
1345                Add_Str_To_Name_Buffer ("spec");
1346             else
1347                Add_Str_To_Name_Buffer ("body");
1348             end if;
1349
1350             return Name_Find;
1351          end New_Finalizer_Name;
1352
1353       --  Start of processing for Create_Finalizer
1354
1355       begin
1356          --  Step 1: Creation of the finalizer name
1357
1358          --  Packages must use a distinct name for their finalizers since the
1359          --  binder will have to generate calls to them by name. The name is
1360          --  of the following form:
1361
1362          --    xx__yy__finalize_[spec|body]
1363
1364          if For_Package then
1365             Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1366             Set_Has_Qualified_Name       (Fin_Id);
1367             Set_Has_Fully_Qualified_Name (Fin_Id);
1368
1369          --  The default name is _finalizer
1370
1371          else
1372             Fin_Id :=
1373               Make_Defining_Identifier (Loc,
1374                 Chars => New_External_Name (Name_uFinalizer));
1375          end if;
1376
1377          --  Step 2: Creation of the finalizer specification
1378
1379          --  Generate:
1380          --    procedure Fin_Id;
1381
1382          Fin_Spec :=
1383            Make_Subprogram_Declaration (Loc,
1384              Specification =>
1385                Make_Procedure_Specification (Loc,
1386                  Defining_Unit_Name => Fin_Id));
1387
1388          --  Step 3: Creation of the finalizer body
1389
1390          if Has_Ctrl_Objs then
1391
1392             --  Add L0, the default destination to the jump block
1393
1394             Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1395             Set_Entity (Label_Id,
1396               Make_Defining_Identifier (Loc, Chars (Label_Id)));
1397             Label := Make_Label (Loc, Label_Id);
1398
1399             --  Generate:
1400             --    L0 : label;
1401
1402             Prepend_To (Finalizer_Decls,
1403               Make_Implicit_Label_Declaration (Loc,
1404                 Defining_Identifier => Entity (Label_Id),
1405                 Label_Construct     => Label));
1406
1407             --  Generate:
1408             --    when others =>
1409             --       goto L0;
1410
1411             Append_To (Jump_Alts,
1412               Make_Case_Statement_Alternative (Loc,
1413                 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1414                 Statements       => New_List (
1415                   Make_Goto_Statement (Loc,
1416                     Name => New_Reference_To (Entity (Label_Id), Loc)))));
1417
1418             --  Generate:
1419             --    <<L0>>
1420
1421             Append_To (Finalizer_Stmts, Label);
1422
1423             --  The local exception does not need to be reraised for library-
1424             --  level finalizers. Generate:
1425             --
1426             --    if Raised and then not Abort then
1427             --       Raise_From_Controlled_Operation (E);
1428             --    end if;
1429
1430             if not For_Package
1431               and then Exceptions_OK
1432             then
1433                Append_To (Finalizer_Stmts,
1434                  Build_Raise_Statement (Finalizer_Data));
1435             end if;
1436
1437             --  Create the jump block which controls the finalization flow
1438             --  depending on the value of the state counter.
1439
1440             Jump_Block :=
1441               Make_Case_Statement (Loc,
1442                 Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
1443                 Alternatives => Jump_Alts);
1444
1445             if Acts_As_Clean
1446               and then Present (Jump_Block_Insert_Nod)
1447             then
1448                Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1449             else
1450                Prepend_To (Finalizer_Stmts, Jump_Block);
1451             end if;
1452          end if;
1453
1454          --  Add the library-level tagged type unregistration machinery before
1455          --  the jump block circuitry. This ensures that external tags will be
1456          --  removed even if a finalization exception occurs at some point.
1457
1458          if Has_Tagged_Types then
1459             Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1460          end if;
1461
1462          --  Add a call to the previous At_End handler if it exists. The call
1463          --  must always precede the jump block.
1464
1465          if Present (Prev_At_End) then
1466             Prepend_To (Finalizer_Stmts,
1467               Make_Procedure_Call_Statement (Loc, Prev_At_End));
1468
1469             --  Clear the At_End handler since we have already generated the
1470             --  proper replacement call for it.
1471
1472             Set_At_End_Proc (HSS, Empty);
1473          end if;
1474
1475          --  Release the secondary stack mark
1476
1477          if Present (Mark_Id) then
1478             Append_To (Finalizer_Stmts,
1479               Make_Procedure_Call_Statement (Loc,
1480                 Name                   =>
1481                   New_Reference_To (RTE (RE_SS_Release), Loc),
1482                 Parameter_Associations => New_List (
1483                   New_Reference_To (Mark_Id, Loc))));
1484          end if;
1485
1486          --  Protect the statements with abort defer/undefer. This is only when
1487          --  aborts are allowed and the clean up statements require deferral or
1488          --  there are controlled objects to be finalized.
1489
1490          if Abort_Allowed
1491            and then
1492              (Defer_Abort or else Has_Ctrl_Objs)
1493          then
1494             Prepend_To (Finalizer_Stmts,
1495               Make_Procedure_Call_Statement (Loc,
1496                 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc)));
1497
1498             Append_To (Finalizer_Stmts,
1499               Make_Procedure_Call_Statement (Loc,
1500                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
1501          end if;
1502
1503          --  Generate:
1504          --    procedure Fin_Id is
1505          --       Abort  : constant Boolean := Triggered_By_Abort;
1506          --         <or>
1507          --       Abort  : constant Boolean := False;  --  no abort
1508
1509          --       E      : Exception_Occurrence;  --  All added if flag
1510          --       Raised : Boolean := False;      --  Has_Ctrl_Objs is set
1511          --       L0     : label;
1512          --       ...
1513          --       Lnn    : label;
1514
1515          --    begin
1516          --       Abort_Defer;               --  Added if abort is allowed
1517          --       <call to Prev_At_End>      --  Added if exists
1518          --       <cleanup statements>       --  Added if Acts_As_Clean
1519          --       <jump block>               --  Added if Has_Ctrl_Objs
1520          --       <finalization statements>  --  Added if Has_Ctrl_Objs
1521          --       <stack release>            --  Added if Mark_Id exists
1522          --       Abort_Undefer;             --  Added if abort is allowed
1523          --    end Fin_Id;
1524
1525          --  Create the body of the finalizer
1526
1527          Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1528
1529          if For_Package then
1530             Set_Has_Qualified_Name       (Body_Id);
1531             Set_Has_Fully_Qualified_Name (Body_Id);
1532          end if;
1533
1534          Fin_Body :=
1535            Make_Subprogram_Body (Loc,
1536              Specification              =>
1537                Make_Procedure_Specification (Loc,
1538                  Defining_Unit_Name => Body_Id),
1539              Declarations               => Finalizer_Decls,
1540              Handled_Statement_Sequence =>
1541                Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
1542
1543          --  Step 4: Spec and body insertion, analysis
1544
1545          if For_Package then
1546
1547             --  If the package spec has private declarations, the finalizer
1548             --  body must be added to the end of the list in order to have
1549             --  visibility of all private controlled objects.
1550
1551             if For_Package_Spec then
1552                if Present (Priv_Decls) then
1553                   Append_To (Priv_Decls, Fin_Spec);
1554                   Append_To (Priv_Decls, Fin_Body);
1555                else
1556                   Append_To (Decls, Fin_Spec);
1557                   Append_To (Decls, Fin_Body);
1558                end if;
1559
1560             --  For package bodies, both the finalizer spec and body are
1561             --  inserted at the end of the package declarations.
1562
1563             else
1564                Append_To (Decls, Fin_Spec);
1565                Append_To (Decls, Fin_Body);
1566             end if;
1567
1568             --  Push the name of the package
1569
1570             Push_Scope (Spec_Id);
1571             Analyze (Fin_Spec);
1572             Analyze (Fin_Body);
1573             Pop_Scope;
1574
1575          --  Non-package case
1576
1577          else
1578             --  Create the spec for the finalizer. The At_End handler must be
1579             --  able to call the body which resides in a nested structure.
1580
1581             --  Generate:
1582             --    declare
1583             --       procedure Fin_Id;                  --  Spec
1584             --    begin
1585             --       <objects and possibly statements>
1586             --       procedure Fin_Id is ...            --  Body
1587             --       <statements>
1588             --    at end
1589             --       Fin_Id;                            --  At_End handler
1590             --    end;
1591
1592             pragma Assert (Present (Spec_Decls));
1593
1594             Append_To (Spec_Decls, Fin_Spec);
1595             Analyze (Fin_Spec);
1596
1597             --  When the finalizer acts solely as a clean up routine, the body
1598             --  is inserted right after the spec.
1599
1600             if Acts_As_Clean
1601               and then not Has_Ctrl_Objs
1602             then
1603                Insert_After (Fin_Spec, Fin_Body);
1604
1605             --  In all other cases the body is inserted after either:
1606             --
1607             --    1) The counter update statement of the last controlled object
1608             --    2) The last top level nested controlled package
1609             --    3) The last top level controlled instantiation
1610
1611             else
1612                --  Manually freeze the spec. This is somewhat of a hack because
1613                --  a subprogram is frozen when its body is seen and the freeze
1614                --  node appears right before the body. However, in this case,
1615                --  the spec must be frozen earlier since the At_End handler
1616                --  must be able to call it.
1617                --
1618                --    declare
1619                --       procedure Fin_Id;               --  Spec
1620                --       [Fin_Id]                        --  Freeze node
1621                --    begin
1622                --       ...
1623                --    at end
1624                --       Fin_Id;                         --  At_End handler
1625                --    end;
1626
1627                Ensure_Freeze_Node (Fin_Id);
1628                Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1629                Set_Is_Frozen (Fin_Id);
1630
1631                --  In the case where the last construct to contain a controlled
1632                --  object is either a nested package, an instantiation or a
1633                --  freeze node, the body must be inserted directly after the
1634                --  construct.
1635
1636                if Nkind_In (Last_Top_Level_Ctrl_Construct,
1637                               N_Freeze_Entity,
1638                               N_Package_Declaration,
1639                               N_Package_Body)
1640                then
1641                   Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1642                end if;
1643
1644                Insert_After (Finalizer_Insert_Nod, Fin_Body);
1645             end if;
1646
1647             Analyze (Fin_Body);
1648          end if;
1649       end Create_Finalizer;
1650
1651       --------------------------
1652       -- Process_Declarations --
1653       --------------------------
1654
1655       procedure Process_Declarations
1656         (Decls      : List_Id;
1657          Preprocess : Boolean := False;
1658          Top_Level  : Boolean := False)
1659       is
1660          Decl    : Node_Id;
1661          Expr    : Node_Id;
1662          Obj_Id  : Entity_Id;
1663          Obj_Typ : Entity_Id;
1664          Pack_Id : Entity_Id;
1665          Spec    : Node_Id;
1666          Typ     : Entity_Id;
1667
1668          Old_Counter_Val : Int;
1669          --  This variable is used to determine whether a nested package or
1670          --  instance contains at least one controlled object.
1671
1672          procedure Processing_Actions
1673            (Has_No_Init  : Boolean := False;
1674             Is_Protected : Boolean := False);
1675          --  Depending on the mode of operation of Process_Declarations, either
1676          --  increment the controlled object counter, set the controlled object
1677          --  flag and store the last top level construct or process the current
1678          --  declaration. Flag Has_No_Init is used to propagate scenarios where
1679          --  the current declaration may not have initialization proc(s). Flag
1680          --  Is_Protected should be set when the current declaration denotes a
1681          --  simple protected object.
1682
1683          ------------------------
1684          -- Processing_Actions --
1685          ------------------------
1686
1687          procedure Processing_Actions
1688            (Has_No_Init  : Boolean := False;
1689             Is_Protected : Boolean := False)
1690          is
1691          begin
1692             --  Library-level tagged type
1693
1694             if Nkind (Decl) = N_Full_Type_Declaration then
1695                if Preprocess then
1696                   Has_Tagged_Types := True;
1697
1698                   if Top_Level
1699                     and then No (Last_Top_Level_Ctrl_Construct)
1700                   then
1701                      Last_Top_Level_Ctrl_Construct := Decl;
1702                   end if;
1703
1704                else
1705                   Process_Tagged_Type_Declaration (Decl);
1706                end if;
1707
1708             --  Controlled object declaration
1709
1710             else
1711                if Preprocess then
1712                   Counter_Val   := Counter_Val + 1;
1713                   Has_Ctrl_Objs := True;
1714
1715                   if Top_Level
1716                     and then No (Last_Top_Level_Ctrl_Construct)
1717                   then
1718                      Last_Top_Level_Ctrl_Construct := Decl;
1719                   end if;
1720
1721                else
1722                   Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
1723                end if;
1724             end if;
1725          end Processing_Actions;
1726
1727       --  Start of processing for Process_Declarations
1728
1729       begin
1730          if No (Decls) or else Is_Empty_List (Decls) then
1731             return;
1732          end if;
1733
1734          --  Process all declarations in reverse order
1735
1736          Decl := Last_Non_Pragma (Decls);
1737          while Present (Decl) loop
1738
1739             --  Library-level tagged types
1740
1741             if Nkind (Decl) = N_Full_Type_Declaration then
1742                Typ := Defining_Identifier (Decl);
1743
1744                if Is_Tagged_Type (Typ)
1745                  and then Is_Library_Level_Entity (Typ)
1746                  and then Convention (Typ) = Convention_Ada
1747                  and then Present (Access_Disp_Table (Typ))
1748                  and then RTE_Available (RE_Register_Tag)
1749                  and then not No_Run_Time_Mode
1750                  and then not Is_Abstract_Type (Typ)
1751                then
1752                   Processing_Actions;
1753                end if;
1754
1755             --  Regular object declarations
1756
1757             elsif Nkind (Decl) = N_Object_Declaration then
1758                Obj_Id  := Defining_Identifier (Decl);
1759                Obj_Typ := Base_Type (Etype (Obj_Id));
1760                Expr    := Expression (Decl);
1761
1762                --  Bypass any form of processing for objects which have their
1763                --  finalization disabled. This applies only to objects at the
1764                --  library level.
1765
1766                if For_Package
1767                  and then Finalize_Storage_Only (Obj_Typ)
1768                then
1769                   null;
1770
1771                --  Transient variables are treated separately in order to
1772                --  minimize the size of the generated code. For details, see
1773                --  Process_Transient_Objects.
1774
1775                elsif Is_Processed_Transient (Obj_Id) then
1776                   null;
1777
1778                --  The object is of the form:
1779                --    Obj : Typ [:= Expr];
1780
1781                --  Do not process the incomplete view of a deferred constant.
1782                --  Do not consider tag-to-class-wide conversions.
1783
1784                elsif not Is_Imported (Obj_Id)
1785                  and then Needs_Finalization (Obj_Typ)
1786                  and then not (Ekind (Obj_Id) = E_Constant
1787                                 and then not Has_Completion (Obj_Id))
1788                  and then not Is_Tag_To_CW_Conversion (Obj_Id)
1789                then
1790                   Processing_Actions;
1791
1792                --  The object is of the form:
1793                --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
1794
1795                --    Obj : Access_Typ :=
1796                --            BIP_Function_Call
1797                --              (..., BIPaccess => null, ...)'reference;
1798
1799                elsif Is_Access_Type (Obj_Typ)
1800                  and then Needs_Finalization
1801                             (Available_View (Designated_Type (Obj_Typ)))
1802                  and then Present (Expr)
1803                  and then
1804                    (Is_Null_Access_BIP_Func_Call (Expr)
1805                      or else
1806                        (Is_Non_BIP_Func_Call (Expr)
1807                          and then not Is_Related_To_Func_Return (Obj_Id)))
1808                then
1809                   Processing_Actions (Has_No_Init => True);
1810
1811                --  Processing for "hook" objects generated for controlled
1812                --  transients declared inside an Expression_With_Actions.
1813
1814                elsif Is_Access_Type (Obj_Typ)
1815                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1816                  and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
1817                                    N_Object_Declaration
1818                  and then Is_Finalizable_Transient
1819                             (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
1820                then
1821                   Processing_Actions (Has_No_Init => True);
1822
1823                --  Simple protected objects which use type System.Tasking.
1824                --  Protected_Objects.Protection to manage their locks should
1825                --  be treated as controlled since they require manual cleanup.
1826                --  The only exception is illustrated in the following example:
1827
1828                --     package Pkg is
1829                --        type Ctrl is new Controlled ...
1830                --        procedure Finalize (Obj : in out Ctrl);
1831                --        Lib_Obj : Ctrl;
1832                --     end Pkg;
1833
1834                --     package body Pkg is
1835                --        protected Prot is
1836                --           procedure Do_Something (Obj : in out Ctrl);
1837                --        end Prot;
1838
1839                --        protected body Prot is
1840                --           procedure Do_Something (Obj : in out Ctrl) is ...
1841                --        end Prot;
1842
1843                --        procedure Finalize (Obj : in out Ctrl) is
1844                --        begin
1845                --           Prot.Do_Something (Obj);
1846                --        end Finalize;
1847                --     end Pkg;
1848
1849                --  Since for the most part entities in package bodies depend on
1850                --  those in package specs, Prot's lock should be cleaned up
1851                --  first. The subsequent cleanup of the spec finalizes Lib_Obj.
1852                --  This act however attempts to invoke Do_Something and fails
1853                --  because the lock has disappeared.
1854
1855                elsif Ekind (Obj_Id) = E_Variable
1856                  and then not In_Library_Level_Package_Body (Obj_Id)
1857                  and then
1858                    (Is_Simple_Protected_Type (Obj_Typ)
1859                      or else Has_Simple_Protected_Object (Obj_Typ))
1860                then
1861                   Processing_Actions (Is_Protected => True);
1862                end if;
1863
1864             --  Specific cases of object renamings
1865
1866             elsif Nkind (Decl) = N_Object_Renaming_Declaration
1867               and then Nkind (Name (Decl)) = N_Explicit_Dereference
1868               and then Nkind (Prefix (Name (Decl))) = N_Identifier
1869             then
1870                Obj_Id  := Defining_Identifier (Decl);
1871                Obj_Typ := Base_Type (Etype (Obj_Id));
1872
1873                --  Bypass any form of processing for objects which have their
1874                --  finalization disabled. This applies only to objects at the
1875                --  library level.
1876
1877                if For_Package
1878                  and then Finalize_Storage_Only (Obj_Typ)
1879                then
1880                   null;
1881
1882                --  Return object of a build-in-place function. This case is
1883                --  recognized and marked by the expansion of an extended return
1884                --  statement (see Expand_N_Extended_Return_Statement).
1885
1886                elsif Needs_Finalization (Obj_Typ)
1887                  and then Is_Return_Object (Obj_Id)
1888                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1889                then
1890                   Processing_Actions (Has_No_Init => True);
1891                end if;
1892
1893             --  Inspect the freeze node of an access-to-controlled type and
1894             --  look for a delayed finalization master. This case arises when
1895             --  the freeze actions are inserted at a later time than the
1896             --  expansion of the context. Since Build_Finalizer is never called
1897             --  on a single construct twice, the master will be ultimately
1898             --  left out and never finalized. This is also needed for freeze
1899             --  actions of designated types themselves, since in some cases the
1900             --  finalization master is associated with a designated type's
1901             --  freeze node rather than that of the access type (see handling
1902             --  for freeze actions in Build_Finalization_Master).
1903
1904             elsif Nkind (Decl) = N_Freeze_Entity
1905               and then Present (Actions (Decl))
1906             then
1907                Typ := Entity (Decl);
1908
1909                if (Is_Access_Type (Typ)
1910                     and then not Is_Access_Subprogram_Type (Typ)
1911                     and then Needs_Finalization
1912                                (Available_View (Designated_Type (Typ))))
1913                  or else (Is_Type (Typ) and then Needs_Finalization (Typ))
1914                then
1915                   Old_Counter_Val := Counter_Val;
1916
1917                   --  Freeze nodes are considered to be identical to packages
1918                   --  and blocks in terms of nesting. The difference is that
1919                   --  a finalization master created inside the freeze node is
1920                   --  at the same nesting level as the node itself.
1921
1922                   Process_Declarations (Actions (Decl), Preprocess);
1923
1924                   --  The freeze node contains a finalization master
1925
1926                   if Preprocess
1927                     and then Top_Level
1928                     and then No (Last_Top_Level_Ctrl_Construct)
1929                     and then Counter_Val > Old_Counter_Val
1930                   then
1931                      Last_Top_Level_Ctrl_Construct := Decl;
1932                   end if;
1933                end if;
1934
1935             --  Nested package declarations, avoid generics
1936
1937             elsif Nkind (Decl) = N_Package_Declaration then
1938                Spec    := Specification (Decl);
1939                Pack_Id := Defining_Unit_Name (Spec);
1940
1941                if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
1942                   Pack_Id := Defining_Identifier (Pack_Id);
1943                end if;
1944
1945                if Ekind (Pack_Id) /= E_Generic_Package then
1946                   Old_Counter_Val := Counter_Val;
1947                   Process_Declarations
1948                     (Private_Declarations (Spec), Preprocess);
1949                   Process_Declarations
1950                     (Visible_Declarations (Spec), Preprocess);
1951
1952                   --  Either the visible or the private declarations contain a
1953                   --  controlled object. The nested package declaration is the
1954                   --  last such construct.
1955
1956                   if Preprocess
1957                     and then Top_Level
1958                     and then No (Last_Top_Level_Ctrl_Construct)
1959                     and then Counter_Val > Old_Counter_Val
1960                   then
1961                      Last_Top_Level_Ctrl_Construct := Decl;
1962                   end if;
1963                end if;
1964
1965             --  Nested package bodies, avoid generics
1966
1967             elsif Nkind (Decl) = N_Package_Body then
1968                Spec := Corresponding_Spec (Decl);
1969
1970                if Ekind (Spec) /= E_Generic_Package then
1971                   Old_Counter_Val := Counter_Val;
1972                   Process_Declarations (Declarations (Decl), Preprocess);
1973
1974                   --  The nested package body is the last construct to contain
1975                   --  a controlled object.
1976
1977                   if Preprocess
1978                     and then Top_Level
1979                     and then No (Last_Top_Level_Ctrl_Construct)
1980                     and then Counter_Val > Old_Counter_Val
1981                   then
1982                      Last_Top_Level_Ctrl_Construct := Decl;
1983                   end if;
1984                end if;
1985
1986             --  Handle a rare case caused by a controlled transient variable
1987             --  created as part of a record init proc. The variable is wrapped
1988             --  in a block, but the block is not associated with a transient
1989             --  scope.
1990
1991             elsif Nkind (Decl) = N_Block_Statement
1992               and then Inside_Init_Proc
1993             then
1994                Old_Counter_Val := Counter_Val;
1995
1996                if Present (Handled_Statement_Sequence (Decl)) then
1997                   Process_Declarations
1998                     (Statements (Handled_Statement_Sequence (Decl)),
1999                      Preprocess);
2000                end if;
2001
2002                Process_Declarations (Declarations (Decl), Preprocess);
2003
2004                --  Either the declaration or statement list of the block has a
2005                --  controlled object.
2006
2007                if Preprocess
2008                  and then Top_Level
2009                  and then No (Last_Top_Level_Ctrl_Construct)
2010                  and then Counter_Val > Old_Counter_Val
2011                then
2012                   Last_Top_Level_Ctrl_Construct := Decl;
2013                end if;
2014             end if;
2015
2016             Prev_Non_Pragma (Decl);
2017          end loop;
2018       end Process_Declarations;
2019
2020       --------------------------------
2021       -- Process_Object_Declaration --
2022       --------------------------------
2023
2024       procedure Process_Object_Declaration
2025         (Decl         : Node_Id;
2026          Has_No_Init  : Boolean := False;
2027          Is_Protected : Boolean := False)
2028       is
2029          Obj_Id    : constant Entity_Id := Defining_Identifier (Decl);
2030          Loc       : constant Source_Ptr := Sloc (Decl);
2031          Body_Ins  : Node_Id;
2032          Count_Ins : Node_Id;
2033          Fin_Call  : Node_Id;
2034          Fin_Stmts : List_Id;
2035          Inc_Decl  : Node_Id;
2036          Label     : Node_Id;
2037          Label_Id  : Entity_Id;
2038          Obj_Ref   : Node_Id;
2039          Obj_Typ   : Entity_Id;
2040
2041          function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2042          --  Once it has been established that the current object is in fact a
2043          --  return object of build-in-place function Func_Id, generate the
2044          --  following cleanup code:
2045          --
2046          --    if BIPallocfrom > Secondary_Stack'Pos
2047          --      and then BIPfinalizationmaster /= null
2048          --    then
2049          --       declare
2050          --          type Ptr_Typ is access Obj_Typ;
2051          --          for Ptr_Typ'Storage_Pool
2052          --            use Base_Pool (BIPfinalizationmaster);
2053          --       begin
2054          --          Free (Ptr_Typ (Temp));
2055          --       end;
2056          --    end if;
2057          --
2058          --  Obj_Typ is the type of the current object, Temp is the original
2059          --  allocation which Obj_Id renames.
2060
2061          procedure Find_Last_Init
2062            (Decl        : Node_Id;
2063             Typ         : Entity_Id;
2064             Last_Init   : out Node_Id;
2065             Body_Insert : out Node_Id);
2066          --  An object declaration has at least one and at most two init calls:
2067          --  that of the type and the user-defined initialize. Given an object
2068          --  declaration, Last_Init denotes the last initialization call which
2069          --  follows the declaration. Body_Insert denotes the place where the
2070          --  finalizer body could be potentially inserted.
2071
2072          -----------------------------
2073          -- Build_BIP_Cleanup_Stmts --
2074          -----------------------------
2075
2076          function Build_BIP_Cleanup_Stmts
2077            (Func_Id : Entity_Id) return Node_Id
2078          is
2079             Decls      : constant List_Id := New_List;
2080             Fin_Mas_Id : constant Entity_Id :=
2081                            Build_In_Place_Formal
2082                              (Func_Id, BIP_Finalization_Master);
2083             Obj_Typ    : constant Entity_Id := Etype (Func_Id);
2084             Temp_Id    : constant Entity_Id :=
2085                            Entity (Prefix (Name (Parent (Obj_Id))));
2086
2087             Cond      : Node_Id;
2088             Free_Blk  : Node_Id;
2089             Free_Stmt : Node_Id;
2090             Pool_Id   : Entity_Id;
2091             Ptr_Typ   : Entity_Id;
2092
2093          begin
2094             --  Generate:
2095             --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2096
2097             Pool_Id := Make_Temporary (Loc, 'P');
2098
2099             Append_To (Decls,
2100               Make_Object_Renaming_Declaration (Loc,
2101                 Defining_Identifier => Pool_Id,
2102                 Subtype_Mark        =>
2103                   New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
2104                 Name                =>
2105                   Make_Explicit_Dereference (Loc,
2106                     Prefix =>
2107                       Make_Function_Call (Loc,
2108                         Name                   =>
2109                           New_Reference_To (RTE (RE_Base_Pool), Loc),
2110                         Parameter_Associations => New_List (
2111                           Make_Explicit_Dereference (Loc,
2112                             Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
2113
2114             --  Create an access type which uses the storage pool of the
2115             --  caller's finalization master.
2116
2117             --  Generate:
2118             --    type Ptr_Typ is access Obj_Typ;
2119
2120             Ptr_Typ := Make_Temporary (Loc, 'P');
2121
2122             Append_To (Decls,
2123               Make_Full_Type_Declaration (Loc,
2124                 Defining_Identifier => Ptr_Typ,
2125                 Type_Definition     =>
2126                   Make_Access_To_Object_Definition (Loc,
2127                     Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
2128
2129             --  Perform minor decoration in order to set the master and the
2130             --  storage pool attributes.
2131
2132             Set_Ekind (Ptr_Typ, E_Access_Type);
2133             Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
2134             Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2135
2136             --  Create an explicit free statement. Note that the free uses the
2137             --  caller's pool expressed as a renaming.
2138
2139             Free_Stmt :=
2140               Make_Free_Statement (Loc,
2141                 Expression =>
2142                   Unchecked_Convert_To (Ptr_Typ,
2143                     New_Reference_To (Temp_Id, Loc)));
2144
2145             Set_Storage_Pool (Free_Stmt, Pool_Id);
2146
2147             --  Create a block to house the dummy type and the instantiation as
2148             --  well as to perform the cleanup the temporary.
2149
2150             --  Generate:
2151             --    declare
2152             --       <Decls>
2153             --    begin
2154             --       Free (Ptr_Typ (Temp_Id));
2155             --    end;
2156
2157             Free_Blk :=
2158               Make_Block_Statement (Loc,
2159                 Declarations               => Decls,
2160                 Handled_Statement_Sequence =>
2161                   Make_Handled_Sequence_Of_Statements (Loc,
2162                     Statements => New_List (Free_Stmt)));
2163
2164             --  Generate:
2165             --    if BIPfinalizationmaster /= null then
2166
2167             Cond :=
2168               Make_Op_Ne (Loc,
2169                 Left_Opnd  => New_Reference_To (Fin_Mas_Id, Loc),
2170                 Right_Opnd => Make_Null (Loc));
2171
2172             --  For constrained or tagged results escalate the condition to
2173             --  include the allocation format. Generate:
2174             --
2175             --    if BIPallocform > Secondary_Stack'Pos
2176             --      and then BIPfinalizationmaster /= null
2177             --    then
2178
2179             if not Is_Constrained (Obj_Typ)
2180               or else Is_Tagged_Type (Obj_Typ)
2181             then
2182                declare
2183                   Alloc : constant Entity_Id :=
2184                             Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2185                begin
2186                   Cond :=
2187                     Make_And_Then (Loc,
2188                       Left_Opnd  =>
2189                         Make_Op_Gt (Loc,
2190                           Left_Opnd  => New_Reference_To (Alloc, Loc),
2191                           Right_Opnd =>
2192                             Make_Integer_Literal (Loc,
2193                               UI_From_Int
2194                                 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2195
2196                       Right_Opnd => Cond);
2197                end;
2198             end if;
2199
2200             --  Generate:
2201             --    if <Cond> then
2202             --       <Free_Blk>
2203             --    end if;
2204
2205             return
2206               Make_If_Statement (Loc,
2207                 Condition       => Cond,
2208                 Then_Statements => New_List (Free_Blk));
2209          end Build_BIP_Cleanup_Stmts;
2210
2211          --------------------
2212          -- Find_Last_Init --
2213          --------------------
2214
2215          procedure Find_Last_Init
2216            (Decl        : Node_Id;
2217             Typ         : Entity_Id;
2218             Last_Init   : out Node_Id;
2219             Body_Insert : out Node_Id)
2220          is
2221             Nod_1 : Node_Id := Empty;
2222             Nod_2 : Node_Id := Empty;
2223             Utyp  : Entity_Id;
2224
2225             function Is_Init_Call
2226               (N   : Node_Id;
2227                Typ : Entity_Id) return Boolean;
2228             --  Given an arbitrary node, determine whether N is a procedure
2229             --  call and if it is, try to match the name of the call with the
2230             --  [Deep_]Initialize proc of Typ.
2231
2232             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2233             --  Given a statement which is part of a list, return the next
2234             --  real statement while skipping over dynamic elab checks.
2235
2236             ------------------
2237             -- Is_Init_Call --
2238             ------------------
2239
2240             function Is_Init_Call
2241               (N   : Node_Id;
2242                Typ : Entity_Id) return Boolean
2243             is
2244             begin
2245                --  A call to [Deep_]Initialize is always direct
2246
2247                if Nkind (N) = N_Procedure_Call_Statement
2248                  and then Nkind (Name (N)) = N_Identifier
2249                then
2250                   declare
2251                      Call_Ent  : constant Entity_Id := Entity (Name (N));
2252                      Deep_Init : constant Entity_Id :=
2253                                    TSS (Typ, TSS_Deep_Initialize);
2254                      Init      : Entity_Id := Empty;
2255
2256                   begin
2257                      --  A type may have controlled components but not be
2258                      --  controlled.
2259
2260                      if Is_Controlled (Typ) then
2261                         Init := Find_Prim_Op (Typ, Name_Initialize);
2262
2263                         if Present (Init) then
2264                            Init := Ultimate_Alias (Init);
2265                         end if;
2266                      end if;
2267
2268                      return
2269                        (Present (Deep_Init) and then Call_Ent = Deep_Init)
2270                          or else
2271                        (Present (Init)      and then Call_Ent = Init);
2272                   end;
2273                end if;
2274
2275                return False;
2276             end Is_Init_Call;
2277
2278             -----------------------------
2279             -- Next_Suitable_Statement --
2280             -----------------------------
2281
2282             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2283                Result : Node_Id := Next (Stmt);
2284
2285             begin
2286                --  Skip over access-before-elaboration checks
2287
2288                if Dynamic_Elaboration_Checks
2289                  and then Nkind (Result) = N_Raise_Program_Error
2290                then
2291                   Result := Next (Result);
2292                end if;
2293
2294                return Result;
2295             end Next_Suitable_Statement;
2296
2297          --  Start of processing for Find_Last_Init
2298
2299          begin
2300             Last_Init   := Decl;
2301             Body_Insert := Empty;
2302
2303             --  Object renamings and objects associated with controlled
2304             --  function results do not have initialization calls.
2305
2306             if Has_No_Init then
2307                return;
2308             end if;
2309
2310             if Is_Concurrent_Type (Typ) then
2311                Utyp := Corresponding_Record_Type (Typ);
2312             else
2313                Utyp := Typ;
2314             end if;
2315
2316             if Is_Private_Type (Utyp)
2317               and then Present (Full_View (Utyp))
2318             then
2319                Utyp := Full_View (Utyp);
2320             end if;
2321
2322             --  The init procedures are arranged as follows:
2323
2324             --    Object : Controlled_Type;
2325             --    Controlled_TypeIP (Object);
2326             --    [[Deep_]Initialize (Object);]
2327
2328             --  where the user-defined initialize may be optional or may appear
2329             --  inside a block when abort deferral is needed.
2330
2331             Nod_1 := Next_Suitable_Statement (Decl);
2332             if Present (Nod_1) then
2333                Nod_2 := Next_Suitable_Statement (Nod_1);
2334
2335                --  The statement following an object declaration is always a
2336                --  call to the type init proc.
2337
2338                Last_Init := Nod_1;
2339             end if;
2340
2341             --  Optional user-defined init or deep init processing
2342
2343             if Present (Nod_2) then
2344
2345                --  The statement following the type init proc may be a block
2346                --  statement in cases where abort deferral is required.
2347
2348                if Nkind (Nod_2) = N_Block_Statement then
2349                   declare
2350                      HSS  : constant Node_Id :=
2351                               Handled_Statement_Sequence (Nod_2);
2352                      Stmt : Node_Id;
2353
2354                   begin
2355                      if Present (HSS)
2356                        and then Present (Statements (HSS))
2357                      then
2358                         Stmt := First (Statements (HSS));
2359
2360                         --  Examine individual block statements and locate the
2361                         --  call to [Deep_]Initialze.
2362
2363                         while Present (Stmt) loop
2364                            if Is_Init_Call (Stmt, Utyp) then
2365                               Last_Init   := Stmt;
2366                               Body_Insert := Nod_2;
2367
2368                               exit;
2369                            end if;
2370
2371                            Next (Stmt);
2372                         end loop;
2373                      end if;
2374                   end;
2375
2376                elsif Is_Init_Call (Nod_2, Utyp) then
2377                   Last_Init := Nod_2;
2378                end if;
2379             end if;
2380          end Find_Last_Init;
2381
2382       --  Start of processing for Process_Object_Declaration
2383
2384       begin
2385          Obj_Ref := New_Reference_To (Obj_Id, Loc);
2386          Obj_Typ := Base_Type (Etype (Obj_Id));
2387
2388          --  Handle access types
2389
2390          if Is_Access_Type (Obj_Typ) then
2391             Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2392             Obj_Typ := Directly_Designated_Type (Obj_Typ);
2393          end if;
2394
2395          Set_Etype (Obj_Ref, Obj_Typ);
2396
2397          --  Set a new value for the state counter and insert the statement
2398          --  after the object declaration. Generate:
2399          --
2400          --    Counter := <value>;
2401
2402          Inc_Decl :=
2403            Make_Assignment_Statement (Loc,
2404              Name       => New_Reference_To (Counter_Id, Loc),
2405              Expression => Make_Integer_Literal (Loc, Counter_Val));
2406
2407          --  Insert the counter after all initialization has been done. The
2408          --  place of insertion depends on the context. When dealing with a
2409          --  controlled function, the counter is inserted directly after the
2410          --  declaration because such objects lack init calls.
2411
2412          Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
2413
2414          Insert_After (Count_Ins, Inc_Decl);
2415          Analyze (Inc_Decl);
2416
2417          --  If the current declaration is the last in the list, the finalizer
2418          --  body needs to be inserted after the set counter statement for the
2419          --  current object declaration. This is complicated by the fact that
2420          --  the set counter statement may appear in abort deferred block. In
2421          --  that case, the proper insertion place is after the block.
2422
2423          if No (Finalizer_Insert_Nod) then
2424
2425             --  Insertion after an abort deffered block
2426
2427             if Present (Body_Ins) then
2428                Finalizer_Insert_Nod := Body_Ins;
2429             else
2430                Finalizer_Insert_Nod := Inc_Decl;
2431             end if;
2432          end if;
2433
2434          --  Create the associated label with this object, generate:
2435          --
2436          --    L<counter> : label;
2437
2438          Label_Id :=
2439            Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2440          Set_Entity
2441            (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
2442          Label := Make_Label (Loc, Label_Id);
2443
2444          Prepend_To (Finalizer_Decls,
2445            Make_Implicit_Label_Declaration (Loc,
2446              Defining_Identifier => Entity (Label_Id),
2447              Label_Construct     => Label));
2448
2449          --  Create the associated jump with this object, generate:
2450          --
2451          --    when <counter> =>
2452          --       goto L<counter>;
2453
2454          Prepend_To (Jump_Alts,
2455            Make_Case_Statement_Alternative (Loc,
2456              Discrete_Choices => New_List (
2457                Make_Integer_Literal (Loc, Counter_Val)),
2458              Statements       => New_List (
2459                Make_Goto_Statement (Loc,
2460                  Name => New_Reference_To (Entity (Label_Id), Loc)))));
2461
2462          --  Insert the jump destination, generate:
2463          --
2464          --     <<L<counter>>>
2465
2466          Append_To (Finalizer_Stmts, Label);
2467
2468          --  Processing for simple protected objects. Such objects require
2469          --  manual finalization of their lock managers.
2470
2471          if Is_Protected then
2472             Fin_Stmts := No_List;
2473
2474             if Is_Simple_Protected_Type (Obj_Typ) then
2475                Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
2476
2477                if Present (Fin_Call) then
2478                   Fin_Stmts := New_List (Fin_Call);
2479                end if;
2480
2481             elsif Has_Simple_Protected_Object (Obj_Typ) then
2482                if Is_Record_Type (Obj_Typ) then
2483                   Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
2484                elsif Is_Array_Type (Obj_Typ) then
2485                   Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
2486                end if;
2487             end if;
2488
2489             --  Generate:
2490             --    begin
2491             --       System.Tasking.Protected_Objects.Finalize_Protection
2492             --         (Obj._object);
2493
2494             --    exception
2495             --       when others =>
2496             --          null;
2497             --    end;
2498
2499             if Present (Fin_Stmts) then
2500                Append_To (Finalizer_Stmts,
2501                  Make_Block_Statement (Loc,
2502                    Handled_Statement_Sequence =>
2503                      Make_Handled_Sequence_Of_Statements (Loc,
2504                        Statements         => Fin_Stmts,
2505
2506                        Exception_Handlers => New_List (
2507                          Make_Exception_Handler (Loc,
2508                            Exception_Choices => New_List (
2509                              Make_Others_Choice (Loc)),
2510
2511                            Statements     => New_List (
2512                              Make_Null_Statement (Loc)))))));
2513             end if;
2514
2515          --  Processing for regular controlled objects
2516
2517          else
2518             --  Generate:
2519             --    [Deep_]Finalize (Obj);  --  No_Exception_Propagation
2520
2521             --    begin                   --  Exception handlers allowed
2522             --       [Deep_]Finalize (Obj);
2523
2524             --    exception
2525             --       when Id : others =>
2526             --          if not Raised then
2527             --             Raised := True;
2528             --             Save_Occurrence (E, Id);
2529             --          end if;
2530             --    end;
2531
2532             Fin_Call :=
2533               Make_Final_Call (
2534                 Obj_Ref => Obj_Ref,
2535                 Typ     => Obj_Typ);
2536
2537             if Exceptions_OK then
2538                Fin_Stmts := New_List (
2539                  Make_Block_Statement (Loc,
2540                    Handled_Statement_Sequence =>
2541                      Make_Handled_Sequence_Of_Statements (Loc,
2542                        Statements => New_List (Fin_Call),
2543
2544                     Exception_Handlers => New_List (
2545                       Build_Exception_Handler
2546                         (Finalizer_Data, For_Package)))));
2547
2548             --  When exception handlers are prohibited, the finalization call
2549             --  appears unprotected. Any exception raised during finalization
2550             --  will bypass the circuitry which ensures the cleanup of all
2551             --  remaining objects.
2552
2553             else
2554                Fin_Stmts := New_List (Fin_Call);
2555             end if;
2556
2557             --  If we are dealing with a return object of a build-in-place
2558             --  function, generate the following cleanup statements:
2559
2560             --    if BIPallocfrom > Secondary_Stack'Pos
2561             --      and then BIPfinalizationmaster /= null
2562             --    then
2563             --       declare
2564             --          type Ptr_Typ is access Obj_Typ;
2565             --          for Ptr_Typ'Storage_Pool use
2566             --                Base_Pool (BIPfinalizationmaster.all).all;
2567             --       begin
2568             --          Free (Ptr_Typ (Temp));
2569             --       end;
2570             --    end if;
2571             --
2572             --  The generated code effectively detaches the temporary from the
2573             --  caller finalization master and deallocates the object. This is
2574             --  disabled on .NET/JVM because pools are not supported.
2575
2576             if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
2577                declare
2578                   Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
2579                begin
2580                   if Is_Build_In_Place_Function (Func_Id)
2581                     and then Needs_BIP_Finalization_Master (Func_Id)
2582                   then
2583                      Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
2584                   end if;
2585                end;
2586             end if;
2587
2588             if Ekind_In (Obj_Id, E_Constant, E_Variable)
2589               and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
2590             then
2591                --  Return objects use a flag to aid their potential
2592                --  finalization when the enclosing function fails to return
2593                --  properly. Generate:
2594
2595                --    if not Flag then
2596                --       <object finalization statements>
2597                --    end if;
2598
2599                if Is_Return_Object (Obj_Id) then
2600                   Fin_Stmts := New_List (
2601                     Make_If_Statement (Loc,
2602                       Condition     =>
2603                         Make_Op_Not (Loc,
2604                           Right_Opnd =>
2605                             New_Reference_To
2606                               (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)),
2607
2608                     Then_Statements => Fin_Stmts));
2609
2610                --  Temporaries created for the purpose of "exporting" a
2611                --  controlled transient out of an Expression_With_Actions (EWA)
2612                --  need guards. The following illustrates the usage of such
2613                --  temporaries.
2614
2615                --    Access_Typ : access [all] Obj_Typ;
2616                --    Temp       : Access_Typ := null;
2617                --    <Counter>  := ...;
2618
2619                --    do
2620                --       Ctrl_Trans : [access [all]] Obj_Typ := ...;
2621                --       Temp := Access_Typ (Ctrl_Trans);  --  when a pointer
2622                --         <or>
2623                --       Temp := Ctrl_Trans'Unchecked_Access;
2624                --    in ... end;
2625
2626                --  The finalization machinery does not process EWA nodes as
2627                --  this may lead to premature finalization of expressions. Note
2628                --  that Temp is marked as being properly initialized regardless
2629                --  of whether the initialization of Ctrl_Trans succeeded. Since
2630                --  a failed initialization may leave Temp with a value of null,
2631                --  add a guard to handle this case:
2632
2633                --    if Obj /= null then
2634                --       <object finalization statements>
2635                --    end if;
2636
2637                else
2638                   pragma Assert
2639                     (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
2640                        N_Object_Declaration);
2641
2642                   Fin_Stmts := New_List (
2643                     Make_If_Statement (Loc,
2644                       Condition       =>
2645                         Make_Op_Ne (Loc,
2646                           Left_Opnd  => New_Reference_To (Obj_Id, Loc),
2647                           Right_Opnd => Make_Null (Loc)),
2648
2649                       Then_Statements => Fin_Stmts));
2650                end if;
2651             end if;
2652          end if;
2653
2654          Append_List_To (Finalizer_Stmts, Fin_Stmts);
2655
2656          --  Since the declarations are examined in reverse, the state counter
2657          --  must be decremented in order to keep with the true position of
2658          --  objects.
2659
2660          Counter_Val := Counter_Val - 1;
2661       end Process_Object_Declaration;
2662
2663       -------------------------------------
2664       -- Process_Tagged_Type_Declaration --
2665       -------------------------------------
2666
2667       procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
2668          Typ    : constant Entity_Id := Defining_Identifier (Decl);
2669          DT_Ptr : constant Entity_Id :=
2670                     Node (First_Elmt (Access_Disp_Table (Typ)));
2671       begin
2672          --  Generate:
2673          --    Ada.Tags.Unregister_Tag (<Typ>P);
2674
2675          Append_To (Tagged_Type_Stmts,
2676            Make_Procedure_Call_Statement (Loc,
2677              Name                   =>
2678                New_Reference_To (RTE (RE_Unregister_Tag), Loc),
2679              Parameter_Associations => New_List (
2680                New_Reference_To (DT_Ptr, Loc))));
2681       end Process_Tagged_Type_Declaration;
2682
2683    --  Start of processing for Build_Finalizer
2684
2685    begin
2686       Fin_Id := Empty;
2687
2688       --  Do not perform this expansion in Alfa mode because it is not
2689       --  necessary.
2690
2691       if Alfa_Mode then
2692          return;
2693       end if;
2694
2695       --  Step 1: Extract all lists which may contain controlled objects or
2696       --  library-level tagged types.
2697
2698       if For_Package_Spec then
2699          Decls      := Visible_Declarations (Specification (N));
2700          Priv_Decls := Private_Declarations (Specification (N));
2701
2702          --  Retrieve the package spec id
2703
2704          Spec_Id := Defining_Unit_Name (Specification (N));
2705
2706          if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
2707             Spec_Id := Defining_Identifier (Spec_Id);
2708          end if;
2709
2710       --  Accept statement, block, entry body, package body, protected body,
2711       --  subprogram body or task body.
2712
2713       else
2714          Decls := Declarations (N);
2715          HSS   := Handled_Statement_Sequence (N);
2716
2717          if Present (HSS) then
2718             if Present (Statements (HSS)) then
2719                Stmts := Statements (HSS);
2720             end if;
2721
2722             if Present (At_End_Proc (HSS)) then
2723                Prev_At_End := At_End_Proc (HSS);
2724             end if;
2725          end if;
2726
2727          --  Retrieve the package spec id for package bodies
2728
2729          if For_Package_Body then
2730             Spec_Id := Corresponding_Spec (N);
2731          end if;
2732       end if;
2733
2734       --  Do not process nested packages since those are handled by the
2735       --  enclosing scope's finalizer. Do not process non-expanded package
2736       --  instantiations since those will be re-analyzed and re-expanded.
2737
2738       if For_Package
2739         and then
2740           (not Is_Library_Level_Entity (Spec_Id)
2741
2742              --  Nested packages are considered to be library level entities,
2743              --  but do not need to be processed separately. True library level
2744              --  packages have a scope value of 1.
2745
2746              or else Scope_Depth_Value (Spec_Id) /= Uint_1
2747              or else (Is_Generic_Instance (Spec_Id)
2748                        and then Package_Instantiation (Spec_Id) /= N))
2749       then
2750          return;
2751       end if;
2752
2753       --  Step 2: Object [pre]processing
2754
2755       if For_Package then
2756
2757          --  Preprocess the visible declarations now in order to obtain the
2758          --  correct number of controlled object by the time the private
2759          --  declarations are processed.
2760
2761          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2762
2763          --  From all the possible contexts, only package specifications may
2764          --  have private declarations.
2765
2766          if For_Package_Spec then
2767             Process_Declarations
2768               (Priv_Decls, Preprocess => True, Top_Level => True);
2769          end if;
2770
2771          --  The current context may lack controlled objects, but require some
2772          --  other form of completion (task termination for instance). In such
2773          --  cases, the finalizer must be created and carry the additional
2774          --  statements.
2775
2776          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2777             Build_Components;
2778          end if;
2779
2780          --  The preprocessing has determined that the context has controlled
2781          --  objects or library-level tagged types.
2782
2783          if Has_Ctrl_Objs or Has_Tagged_Types then
2784
2785             --  Private declarations are processed first in order to preserve
2786             --  possible dependencies between public and private objects.
2787
2788             if For_Package_Spec then
2789                Process_Declarations (Priv_Decls);
2790             end if;
2791
2792             Process_Declarations (Decls);
2793          end if;
2794
2795       --  Non-package case
2796
2797       else
2798          --  Preprocess both declarations and statements
2799
2800          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2801          Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
2802
2803          --  At this point it is known that N has controlled objects. Ensure
2804          --  that N has a declarative list since the finalizer spec will be
2805          --  attached to it.
2806
2807          if Has_Ctrl_Objs and then No (Decls) then
2808             Set_Declarations (N, New_List);
2809             Decls      := Declarations (N);
2810             Spec_Decls := Decls;
2811          end if;
2812
2813          --  The current context may lack controlled objects, but require some
2814          --  other form of completion (task termination for instance). In such
2815          --  cases, the finalizer must be created and carry the additional
2816          --  statements.
2817
2818          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2819             Build_Components;
2820          end if;
2821
2822          if Has_Ctrl_Objs or Has_Tagged_Types then
2823             Process_Declarations (Stmts);
2824             Process_Declarations (Decls);
2825          end if;
2826       end if;
2827
2828       --  Step 3: Finalizer creation
2829
2830       if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2831          Create_Finalizer;
2832       end if;
2833    end Build_Finalizer;
2834
2835    --------------------------
2836    -- Build_Finalizer_Call --
2837    --------------------------
2838
2839    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
2840       Is_Prot_Body : constant Boolean :=
2841                        Nkind (N) = N_Subprogram_Body
2842                          and then Is_Protected_Subprogram_Body (N);
2843       --  Determine whether N denotes the protected version of a subprogram
2844       --  which belongs to a protected type.
2845
2846       Loc : constant Source_Ptr := Sloc (N);
2847       HSS : Node_Id;
2848
2849    begin
2850       --  Do not perform this expansion in Alfa mode because we do not create
2851       --  finalizers in the first place.
2852
2853       if Alfa_Mode then
2854          return;
2855       end if;
2856
2857       --  The At_End handler should have been assimilated by the finalizer
2858
2859       HSS := Handled_Statement_Sequence (N);
2860       pragma Assert (No (At_End_Proc (HSS)));
2861
2862       --  If the construct to be cleaned up is a protected subprogram body, the
2863       --  finalizer call needs to be associated with the block which wraps the
2864       --  unprotected version of the subprogram. The following illustrates this
2865       --  scenario:
2866
2867       --     procedure Prot_SubpP is
2868       --        procedure finalizer is
2869       --        begin
2870       --           Service_Entries (Prot_Obj);
2871       --           Abort_Undefer;
2872       --        end finalizer;
2873
2874       --     begin
2875       --        . . .
2876       --        begin
2877       --           Prot_SubpN (Prot_Obj);
2878       --        at end
2879       --           finalizer;
2880       --        end;
2881       --     end Prot_SubpP;
2882
2883       if Is_Prot_Body then
2884          HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
2885
2886       --  An At_End handler and regular exception handlers cannot coexist in
2887       --  the same statement sequence. Wrap the original statements in a block.
2888
2889       elsif Present (Exception_Handlers (HSS)) then
2890          declare
2891             End_Lab : constant Node_Id := End_Label (HSS);
2892             Block   : Node_Id;
2893
2894          begin
2895             Block :=
2896               Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
2897
2898             Set_Handled_Statement_Sequence (N,
2899               Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
2900
2901             HSS := Handled_Statement_Sequence (N);
2902             Set_End_Label (HSS, End_Lab);
2903          end;
2904       end if;
2905
2906       Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc));
2907
2908       Analyze (At_End_Proc (HSS));
2909       Expand_At_End_Handler (HSS, Empty);
2910    end Build_Finalizer_Call;
2911
2912    ---------------------
2913    -- Build_Late_Proc --
2914    ---------------------
2915
2916    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
2917    begin
2918       for Final_Prim in Name_Of'Range loop
2919          if Name_Of (Final_Prim) = Nam then
2920             Set_TSS (Typ,
2921               Make_Deep_Proc
2922                 (Prim  => Final_Prim,
2923                  Typ   => Typ,
2924                  Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
2925          end if;
2926       end loop;
2927    end Build_Late_Proc;
2928
2929    -------------------------------
2930    -- Build_Object_Declarations --
2931    -------------------------------
2932
2933    procedure Build_Object_Declarations
2934      (Data        : out Finalization_Exception_Data;
2935       Decls       : List_Id;
2936       Loc         : Source_Ptr;
2937       For_Package : Boolean := False)
2938    is
2939       A_Expr : Node_Id;
2940       E_Decl : Node_Id;
2941
2942    begin
2943       pragma Assert (Decls /= No_List);
2944
2945       --  Always set the proper location as it may be needed even when
2946       --  exception propagation is forbidden.
2947
2948       Data.Loc := Loc;
2949
2950       if Restriction_Active (No_Exception_Propagation) then
2951          Data.Abort_Id  := Empty;
2952          Data.E_Id      := Empty;
2953          Data.Raised_Id := Empty;
2954          return;
2955       end if;
2956
2957       Data.Abort_Id  := Make_Temporary (Loc, 'A');
2958       Data.E_Id      := Make_Temporary (Loc, 'E');
2959       Data.Raised_Id := Make_Temporary (Loc, 'R');
2960
2961       --  In certain scenarios, finalization can be triggered by an abort. If
2962       --  the finalization itself fails and raises an exception, the resulting
2963       --  Program_Error must be supressed and replaced by an abort signal. In
2964       --  order to detect this scenario, save the state of entry into the
2965       --  finalization code.
2966
2967       --  No need to do this for VM case, since VM version of Ada.Exceptions
2968       --  does not include routine Raise_From_Controlled_Operation which is the
2969       --  the sole user of flag Abort.
2970
2971       --  This is not needed for library-level finalizers as they are called
2972       --  by the environment task and cannot be aborted.
2973
2974       if Abort_Allowed
2975         and then VM_Target = No_VM
2976         and then not For_Package
2977       then
2978          A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
2979
2980       --  No abort, .NET/JVM or library-level finalizers
2981
2982       else
2983          A_Expr := New_Reference_To (Standard_False, Loc);
2984       end if;
2985
2986       --  Generate:
2987       --    Abort_Id : constant Boolean := <A_Expr>;
2988
2989       Append_To (Decls,
2990         Make_Object_Declaration (Loc,
2991           Defining_Identifier => Data.Abort_Id,
2992           Constant_Present    => True,
2993           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
2994           Expression          => A_Expr));
2995
2996       --  Generate:
2997       --    E_Id : Exception_Occurrence;
2998
2999       E_Decl :=
3000         Make_Object_Declaration (Loc,
3001           Defining_Identifier => Data.E_Id,
3002           Object_Definition   =>
3003             New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
3004       Set_No_Initialization (E_Decl);
3005
3006       Append_To (Decls, E_Decl);
3007
3008       --  Generate:
3009       --    Raised_Id : Boolean := False;
3010
3011       Append_To (Decls,
3012         Make_Object_Declaration (Loc,
3013           Defining_Identifier => Data.Raised_Id,
3014           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
3015           Expression          => New_Reference_To (Standard_False, Loc)));
3016    end Build_Object_Declarations;
3017
3018    ---------------------------
3019    -- Build_Raise_Statement --
3020    ---------------------------
3021
3022    function Build_Raise_Statement
3023      (Data : Finalization_Exception_Data) return Node_Id
3024    is
3025       Stmt : Node_Id;
3026
3027    begin
3028       --  Standard run-time and .NET/JVM targets use the specialized routine
3029       --  Raise_From_Controlled_Operation.
3030
3031       if RTE_Available (RE_Raise_From_Controlled_Operation) then
3032          Stmt :=
3033            Make_Procedure_Call_Statement (Data.Loc,
3034               Name                   =>
3035                 New_Reference_To
3036                   (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3037               Parameter_Associations =>
3038                 New_List (New_Reference_To (Data.E_Id, Data.Loc)));
3039
3040       --  Restricted run-time: exception messages are not supported and hence
3041       --  Raise_From_Controlled_Operation is not supported. Raise Program_Error
3042       --  instead.
3043
3044       else
3045          Stmt :=
3046            Make_Raise_Program_Error (Data.Loc,
3047              Reason => PE_Finalize_Raised_Exception);
3048       end if;
3049
3050       --  Generate:
3051       --    if Raised_Id and then not Abort_Id then
3052       --       Raise_From_Controlled_Operation (E_Id);
3053       --         <or>
3054       --       raise Program_Error;  --  restricted runtime
3055       --    end if;
3056
3057       return
3058         Make_If_Statement (Data.Loc,
3059           Condition       =>
3060             Make_And_Then (Data.Loc,
3061               Left_Opnd  => New_Reference_To (Data.Raised_Id, Data.Loc),
3062               Right_Opnd =>
3063                 Make_Op_Not (Data.Loc,
3064                   Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))),
3065
3066           Then_Statements => New_List (Stmt));
3067    end Build_Raise_Statement;
3068
3069    -----------------------------
3070    -- Build_Record_Deep_Procs --
3071    -----------------------------
3072
3073    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3074    begin
3075       Set_TSS (Typ,
3076         Make_Deep_Proc
3077           (Prim  => Initialize_Case,
3078            Typ   => Typ,
3079            Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3080
3081       if not Is_Immutably_Limited_Type (Typ) then
3082          Set_TSS (Typ,
3083            Make_Deep_Proc
3084              (Prim  => Adjust_Case,
3085               Typ   => Typ,
3086               Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3087       end if;
3088
3089       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
3090       --  suppressed since these routine will not be used.
3091
3092       if not Restriction_Active (No_Finalization) then
3093          Set_TSS (Typ,
3094            Make_Deep_Proc
3095              (Prim  => Finalize_Case,
3096               Typ   => Typ,
3097               Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3098
3099          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
3100          --  .NET do not support address arithmetic and unchecked conversions.
3101
3102          if VM_Target = No_VM then
3103             Set_TSS (Typ,
3104               Make_Deep_Proc
3105                 (Prim  => Address_Case,
3106                  Typ   => Typ,
3107                  Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3108          end if;
3109       end if;
3110    end Build_Record_Deep_Procs;
3111
3112    -------------------
3113    -- Cleanup_Array --
3114    -------------------
3115
3116    function Cleanup_Array
3117      (N    : Node_Id;
3118       Obj  : Node_Id;
3119       Typ  : Entity_Id) return List_Id
3120    is
3121       Loc        : constant Source_Ptr := Sloc (N);
3122       Index_List : constant List_Id := New_List;
3123
3124       function Free_Component return List_Id;
3125       --  Generate the code to finalize the task or protected  subcomponents
3126       --  of a single component of the array.
3127
3128       function Free_One_Dimension (Dim : Int) return List_Id;
3129       --  Generate a loop over one dimension of the array
3130
3131       --------------------
3132       -- Free_Component --
3133       --------------------
3134
3135       function Free_Component return List_Id is
3136          Stmts : List_Id := New_List;
3137          Tsk   : Node_Id;
3138          C_Typ : constant Entity_Id := Component_Type (Typ);
3139
3140       begin
3141          --  Component type is known to contain tasks or protected objects
3142
3143          Tsk :=
3144            Make_Indexed_Component (Loc,
3145              Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3146              Expressions   => Index_List);
3147
3148          Set_Etype (Tsk, C_Typ);
3149
3150          if Is_Task_Type (C_Typ) then
3151             Append_To (Stmts, Cleanup_Task (N, Tsk));
3152
3153          elsif Is_Simple_Protected_Type (C_Typ) then
3154             Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3155
3156          elsif Is_Record_Type (C_Typ) then
3157             Stmts := Cleanup_Record (N, Tsk, C_Typ);
3158
3159          elsif Is_Array_Type (C_Typ) then
3160             Stmts := Cleanup_Array (N, Tsk, C_Typ);
3161          end if;
3162
3163          return Stmts;
3164       end Free_Component;
3165
3166       ------------------------
3167       -- Free_One_Dimension --
3168       ------------------------
3169
3170       function Free_One_Dimension (Dim : Int) return List_Id is
3171          Index : Entity_Id;
3172
3173       begin
3174          if Dim > Number_Dimensions (Typ) then
3175             return Free_Component;
3176
3177          --  Here we generate the required loop
3178
3179          else
3180             Index := Make_Temporary (Loc, 'J');
3181             Append (New_Reference_To (Index, Loc), Index_List);
3182
3183             return New_List (
3184               Make_Implicit_Loop_Statement (N,
3185                 Identifier       => Empty,
3186                 Iteration_Scheme =>
3187                   Make_Iteration_Scheme (Loc,
3188                     Loop_Parameter_Specification =>
3189                       Make_Loop_Parameter_Specification (Loc,
3190                         Defining_Identifier         => Index,
3191                         Discrete_Subtype_Definition =>
3192                           Make_Attribute_Reference (Loc,
3193                             Prefix          => Duplicate_Subexpr (Obj),
3194                             Attribute_Name  => Name_Range,
3195                             Expressions     => New_List (
3196                               Make_Integer_Literal (Loc, Dim))))),
3197                 Statements       =>  Free_One_Dimension (Dim + 1)));
3198          end if;
3199       end Free_One_Dimension;
3200
3201    --  Start of processing for Cleanup_Array
3202
3203    begin
3204       return Free_One_Dimension (1);
3205    end Cleanup_Array;
3206
3207    --------------------
3208    -- Cleanup_Record --
3209    --------------------
3210
3211    function Cleanup_Record
3212      (N    : Node_Id;
3213       Obj  : Node_Id;
3214       Typ  : Entity_Id) return List_Id
3215    is
3216       Loc   : constant Source_Ptr := Sloc (N);
3217       Tsk   : Node_Id;
3218       Comp  : Entity_Id;
3219       Stmts : constant List_Id    := New_List;
3220       U_Typ : constant Entity_Id  := Underlying_Type (Typ);
3221
3222    begin
3223       if Has_Discriminants (U_Typ)
3224         and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3225         and then
3226           Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3227         and then
3228           Present
3229             (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3230       then
3231          --  For now, do not attempt to free a component that may appear in a
3232          --  variant, and instead issue a warning. Doing this "properly" would
3233          --  require building a case statement and would be quite a mess. Note
3234          --  that the RM only requires that free "work" for the case of a task
3235          --  access value, so already we go way beyond this in that we deal
3236          --  with the array case and non-discriminated record cases.
3237
3238          Error_Msg_N
3239            ("task/protected object in variant record will not be freed?", N);
3240          return New_List (Make_Null_Statement (Loc));
3241       end if;
3242
3243       Comp := First_Component (Typ);
3244       while Present (Comp) loop
3245          if Has_Task (Etype (Comp))
3246            or else Has_Simple_Protected_Object (Etype (Comp))
3247          then
3248             Tsk :=
3249               Make_Selected_Component (Loc,
3250                 Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3251                 Selector_Name => New_Occurrence_Of (Comp, Loc));
3252             Set_Etype (Tsk, Etype (Comp));
3253
3254             if Is_Task_Type (Etype (Comp)) then
3255                Append_To (Stmts, Cleanup_Task (N, Tsk));
3256
3257             elsif Is_Simple_Protected_Type (Etype (Comp)) then
3258                Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3259
3260             elsif Is_Record_Type (Etype (Comp)) then
3261
3262                --  Recurse, by generating the prefix of the argument to
3263                --  the eventual cleanup call.
3264
3265                Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3266
3267             elsif Is_Array_Type (Etype (Comp)) then
3268                Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3269             end if;
3270          end if;
3271
3272          Next_Component (Comp);
3273       end loop;
3274
3275       return Stmts;
3276    end Cleanup_Record;
3277
3278    ------------------------------
3279    -- Cleanup_Protected_Object --
3280    ------------------------------
3281
3282    function Cleanup_Protected_Object
3283      (N   : Node_Id;
3284       Ref : Node_Id) return Node_Id
3285    is
3286       Loc : constant Source_Ptr := Sloc (N);
3287
3288    begin
3289       --  For restricted run-time libraries (Ravenscar), tasks are
3290       --  non-terminating, and protected objects can only appear at library
3291       --  level, so we do not want finalization of protected objects.
3292
3293       if Restricted_Profile then
3294          return Empty;
3295
3296       else
3297          return
3298            Make_Procedure_Call_Statement (Loc,
3299              Name                   =>
3300                New_Reference_To (RTE (RE_Finalize_Protection), Loc),
3301              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3302       end if;
3303    end Cleanup_Protected_Object;
3304
3305    ------------------
3306    -- Cleanup_Task --
3307    ------------------
3308
3309    function Cleanup_Task
3310      (N   : Node_Id;
3311       Ref : Node_Id) return Node_Id
3312    is
3313       Loc  : constant Source_Ptr := Sloc (N);
3314
3315    begin
3316       --  For restricted run-time libraries (Ravenscar), tasks are
3317       --  non-terminating and they can only appear at library level, so we do
3318       --  not want finalization of task objects.
3319
3320       if Restricted_Profile then
3321          return Empty;
3322
3323       else
3324          return
3325            Make_Procedure_Call_Statement (Loc,
3326              Name                   =>
3327                New_Reference_To (RTE (RE_Free_Task), Loc),
3328              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3329       end if;
3330    end Cleanup_Task;
3331
3332    ------------------------------
3333    -- Check_Visibly_Controlled --
3334    ------------------------------
3335
3336    procedure Check_Visibly_Controlled
3337      (Prim : Final_Primitives;
3338       Typ  : Entity_Id;
3339       E    : in out Entity_Id;
3340       Cref : in out Node_Id)
3341    is
3342       Parent_Type : Entity_Id;
3343       Op          : Entity_Id;
3344
3345    begin
3346       if Is_Derived_Type (Typ)
3347         and then Comes_From_Source (E)
3348         and then not Present (Overridden_Operation (E))
3349       then
3350          --  We know that the explicit operation on the type does not override
3351          --  the inherited operation of the parent, and that the derivation
3352          --  is from a private type that is not visibly controlled.
3353
3354          Parent_Type := Etype (Typ);
3355          Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
3356
3357          if Present (Op) then
3358             E := Op;
3359
3360             --  Wrap the object to be initialized into the proper
3361             --  unchecked conversion, to be compatible with the operation
3362             --  to be called.
3363
3364             if Nkind (Cref) = N_Unchecked_Type_Conversion then
3365                Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
3366             else
3367                Cref := Unchecked_Convert_To (Parent_Type, Cref);
3368             end if;
3369          end if;
3370       end if;
3371    end Check_Visibly_Controlled;
3372
3373    -------------------------------
3374    -- CW_Or_Has_Controlled_Part --
3375    -------------------------------
3376
3377    function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
3378    begin
3379       return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
3380    end CW_Or_Has_Controlled_Part;
3381
3382    ------------------
3383    -- Convert_View --
3384    ------------------
3385
3386    function Convert_View
3387      (Proc : Entity_Id;
3388       Arg  : Node_Id;
3389       Ind  : Pos := 1) return Node_Id
3390    is
3391       Fent : Entity_Id := First_Entity (Proc);
3392       Ftyp : Entity_Id;
3393       Atyp : Entity_Id;
3394
3395    begin
3396       for J in 2 .. Ind loop
3397          Next_Entity (Fent);
3398       end loop;
3399
3400       Ftyp := Etype (Fent);
3401
3402       if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3403          Atyp := Entity (Subtype_Mark (Arg));
3404       else
3405          Atyp := Etype (Arg);
3406       end if;
3407
3408       if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
3409          return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
3410
3411       elsif Ftyp /= Atyp
3412         and then Present (Atyp)
3413         and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
3414         and then Base_Type (Underlying_Type (Atyp)) =
3415                  Base_Type (Underlying_Type (Ftyp))
3416       then
3417          return Unchecked_Convert_To (Ftyp, Arg);
3418
3419       --  If the argument is already a conversion, as generated by
3420       --  Make_Init_Call, set the target type to the type of the formal
3421       --  directly, to avoid spurious typing problems.
3422
3423       elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
3424         and then not Is_Class_Wide_Type (Atyp)
3425       then
3426          Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
3427          Set_Etype (Arg, Ftyp);
3428          return Arg;
3429
3430       else
3431          return Arg;
3432       end if;
3433    end Convert_View;
3434
3435    ------------------------
3436    -- Enclosing_Function --
3437    ------------------------
3438
3439    function Enclosing_Function (E : Entity_Id) return Entity_Id is
3440       Func_Id : Entity_Id;
3441
3442    begin
3443       Func_Id := E;
3444       while Present (Func_Id)
3445         and then Func_Id /= Standard_Standard
3446       loop
3447          if Ekind (Func_Id) = E_Function then
3448             return Func_Id;
3449          end if;
3450
3451          Func_Id := Scope (Func_Id);
3452       end loop;
3453
3454       return Empty;
3455    end Enclosing_Function;
3456
3457    -------------------------------
3458    -- Establish_Transient_Scope --
3459    -------------------------------
3460
3461    --  This procedure is called each time a transient block has to be inserted
3462    --  that is to say for each call to a function with unconstrained or tagged
3463    --  result. It creates a new scope on the stack scope in order to enclose
3464    --  all transient variables generated
3465
3466    procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
3467       Loc       : constant Source_Ptr := Sloc (N);
3468       Wrap_Node : Node_Id;
3469
3470    begin
3471       --  Do not create a transient scope if we are already inside one
3472
3473       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
3474          if Scope_Stack.Table (S).Is_Transient then
3475             if Sec_Stack then
3476                Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
3477             end if;
3478
3479             return;
3480
3481          --  If we have encountered Standard there are no enclosing
3482          --  transient scopes.
3483
3484          elsif Scope_Stack.Table (S).Entity = Standard_Standard then
3485             exit;
3486          end if;
3487       end loop;
3488
3489       Wrap_Node := Find_Node_To_Be_Wrapped (N);
3490
3491       --  Case of no wrap node, false alert, no transient scope needed
3492
3493       if No (Wrap_Node) then
3494          null;
3495
3496       --  If the node to wrap is an iteration_scheme, the expression is
3497       --  one of the bounds, and the expansion will make an explicit
3498       --  declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3499       --  so do not apply any transformations here.
3500
3501       elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
3502          null;
3503
3504       --  In formal verification mode, if the node to wrap is a pragma check,
3505       --  this node and enclosed expression are not expanded, so do not apply
3506       --  any transformations here.
3507
3508       elsif Alfa_Mode
3509         and then Nkind (Wrap_Node) = N_Pragma
3510         and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
3511       then
3512          null;
3513
3514       else
3515          Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
3516          Set_Scope_Is_Transient;
3517
3518          if Sec_Stack then
3519             Set_Uses_Sec_Stack (Current_Scope);
3520             Check_Restriction (No_Secondary_Stack, N);
3521          end if;
3522
3523          Set_Etype (Current_Scope, Standard_Void_Type);
3524          Set_Node_To_Be_Wrapped (Wrap_Node);
3525
3526          if Debug_Flag_W then
3527             Write_Str ("    <Transient>");
3528             Write_Eol;
3529          end if;
3530       end if;
3531    end Establish_Transient_Scope;
3532
3533    ----------------------------
3534    -- Expand_Cleanup_Actions --
3535    ----------------------------
3536
3537    procedure Expand_Cleanup_Actions (N : Node_Id) is
3538       Scop : constant Entity_Id := Current_Scope;
3539
3540       Is_Asynchronous_Call : constant Boolean :=
3541                                Nkind (N) = N_Block_Statement
3542                                  and then Is_Asynchronous_Call_Block (N);
3543       Is_Master            : constant Boolean :=
3544                                Nkind (N) /= N_Entry_Body
3545                                  and then Is_Task_Master (N);
3546       Is_Protected_Body    : constant Boolean :=
3547                                Nkind (N) = N_Subprogram_Body
3548                                  and then Is_Protected_Subprogram_Body (N);
3549       Is_Task_Allocation   : constant Boolean :=
3550                                Nkind (N) = N_Block_Statement
3551                                  and then Is_Task_Allocation_Block (N);
3552       Is_Task_Body         : constant Boolean :=
3553                                Nkind (Original_Node (N)) = N_Task_Body;
3554       Needs_Sec_Stack_Mark : constant Boolean :=
3555                                Uses_Sec_Stack (Scop)
3556                                  and then
3557                                    not Sec_Stack_Needed_For_Return (Scop)
3558                                  and then VM_Target = No_VM;
3559
3560       Actions_Required     : constant Boolean :=
3561                                Requires_Cleanup_Actions (N)
3562                                  or else Is_Asynchronous_Call
3563                                  or else Is_Master
3564                                  or else Is_Protected_Body
3565                                  or else Is_Task_Allocation
3566                                  or else Is_Task_Body
3567                                  or else Needs_Sec_Stack_Mark;
3568
3569       HSS : Node_Id := Handled_Statement_Sequence (N);
3570       Loc : Source_Ptr;
3571
3572       procedure Wrap_HSS_In_Block;
3573       --  Move HSS inside a new block along with the original exception
3574       --  handlers. Make the newly generated block the sole statement of HSS.
3575
3576       -----------------------
3577       -- Wrap_HSS_In_Block --
3578       -----------------------
3579
3580       procedure Wrap_HSS_In_Block is
3581          Block   : Node_Id;
3582          End_Lab : Node_Id;
3583
3584       begin
3585          --  Preserve end label to provide proper cross-reference information
3586
3587          End_Lab := End_Label (HSS);
3588          Block :=
3589            Make_Block_Statement (Loc,
3590              Handled_Statement_Sequence => HSS);
3591
3592          Set_Handled_Statement_Sequence (N,
3593            Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3594          HSS := Handled_Statement_Sequence (N);
3595
3596          Set_First_Real_Statement (HSS, Block);
3597          Set_End_Label (HSS, End_Lab);
3598
3599          --  Comment needed here, see RH for 1.306 ???
3600
3601          if Nkind (N) = N_Subprogram_Body then
3602             Set_Has_Nested_Block_With_Handler (Scop);
3603          end if;
3604       end Wrap_HSS_In_Block;
3605
3606    --  Start of processing for Expand_Cleanup_Actions
3607
3608    begin
3609       --  The current construct does not need any form of servicing
3610
3611       if not Actions_Required then
3612          return;
3613
3614       --  If the current node is a rewritten task body and the descriptors have
3615       --  not been delayed (due to some nested instantiations), do not generate
3616       --  redundant cleanup actions.
3617
3618       elsif Is_Task_Body
3619         and then Nkind (N) = N_Subprogram_Body
3620         and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
3621       then
3622          return;
3623       end if;
3624
3625       declare
3626          Decls     : List_Id := Declarations (N);
3627          Fin_Id    : Entity_Id;
3628          Mark      : Entity_Id := Empty;
3629          New_Decls : List_Id;
3630          Old_Poll  : Boolean;
3631
3632       begin
3633          --  If we are generating expanded code for debugging purposes, use the
3634          --  Sloc of the point of insertion for the cleanup code. The Sloc will
3635          --  be updated subsequently to reference the proper line in .dg files.
3636          --  If we are not debugging generated code, use No_Location instead,
3637          --  so that no debug information is generated for the cleanup code.
3638          --  This makes the behavior of the NEXT command in GDB monotonic, and
3639          --  makes the placement of breakpoints more accurate.
3640
3641          if Debug_Generated_Code then
3642             Loc := Sloc (Scop);
3643          else
3644             Loc := No_Location;
3645          end if;
3646
3647          --  Set polling off. The finalization and cleanup code is executed
3648          --  with aborts deferred.
3649
3650          Old_Poll := Polling_Required;
3651          Polling_Required := False;
3652
3653          --  A task activation call has already been built for a task
3654          --  allocation block.
3655
3656          if not Is_Task_Allocation then
3657             Build_Task_Activation_Call (N);
3658          end if;
3659
3660          if Is_Master then
3661             Establish_Task_Master (N);
3662          end if;
3663
3664          New_Decls := New_List;
3665
3666          --  If secondary stack is in use, generate:
3667          --
3668          --    Mnn : constant Mark_Id := SS_Mark;
3669
3670          --  Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3671          --  secondary stack is never used on a VM.
3672
3673          if Needs_Sec_Stack_Mark then
3674             Mark := Make_Temporary (Loc, 'M');
3675
3676             Append_To (New_Decls,
3677               Make_Object_Declaration (Loc,
3678                 Defining_Identifier => Mark,
3679                 Object_Definition   =>
3680                   New_Reference_To (RTE (RE_Mark_Id), Loc),
3681                 Expression          =>
3682                   Make_Function_Call (Loc,
3683                     Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
3684
3685             Set_Uses_Sec_Stack (Scop, False);
3686          end if;
3687
3688          --  If exception handlers are present, wrap the sequence of statements
3689          --  in a block since it is not possible to have exception handlers and
3690          --  an At_End handler in the same construct.
3691
3692          if Present (Exception_Handlers (HSS)) then
3693             Wrap_HSS_In_Block;
3694
3695          --  Ensure that the First_Real_Statement field is set
3696
3697          elsif No (First_Real_Statement (HSS)) then
3698             Set_First_Real_Statement (HSS, First (Statements (HSS)));
3699          end if;
3700
3701          --  Do not move the Activation_Chain declaration in the context of
3702          --  task allocation blocks. Task allocation blocks use _chain in their
3703          --  cleanup handlers and gigi complains if it is declared in the
3704          --  sequence of statements of the scope that declares the handler.
3705
3706          if Is_Task_Allocation then
3707             declare
3708                Chain : constant Entity_Id := Activation_Chain_Entity (N);
3709                Decl  : Node_Id;
3710
3711             begin
3712                Decl := First (Decls);
3713                while Nkind (Decl) /= N_Object_Declaration
3714                  or else Defining_Identifier (Decl) /= Chain
3715                loop
3716                   Next (Decl);
3717
3718                   --  A task allocation block should always include a _chain
3719                   --  declaration.
3720
3721                   pragma Assert (Present (Decl));
3722                end loop;
3723
3724                Remove (Decl);
3725                Prepend_To (New_Decls, Decl);
3726             end;
3727          end if;
3728
3729          --  Ensure the presence of a declaration list in order to successfully
3730          --  append all original statements to it.
3731
3732          if No (Decls) then
3733             Set_Declarations (N, New_List);
3734             Decls := Declarations (N);
3735          end if;
3736
3737          --  Move the declarations into the sequence of statements in order to
3738          --  have them protected by the At_End handler. It may seem weird to
3739          --  put declarations in the sequence of statement but in fact nothing
3740          --  forbids that at the tree level.
3741
3742          Append_List_To (Decls, Statements (HSS));
3743          Set_Statements (HSS, Decls);
3744
3745          --  Reset the Sloc of the handled statement sequence to properly
3746          --  reflect the new initial "statement" in the sequence.
3747
3748          Set_Sloc (HSS, Sloc (First (Decls)));
3749
3750          --  The declarations of finalizer spec and auxiliary variables replace
3751          --  the old declarations that have been moved inward.
3752
3753          Set_Declarations (N, New_Decls);
3754          Analyze_Declarations (New_Decls);
3755
3756          --  Generate finalization calls for all controlled objects appearing
3757          --  in the statements of N. Add context specific cleanup for various
3758          --  constructs.
3759
3760          Build_Finalizer
3761            (N           => N,
3762             Clean_Stmts => Build_Cleanup_Statements (N),
3763             Mark_Id     => Mark,
3764             Top_Decls   => New_Decls,
3765             Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
3766                              or else Is_Master,
3767             Fin_Id      => Fin_Id);
3768
3769          if Present (Fin_Id) then
3770             Build_Finalizer_Call (N, Fin_Id);
3771          end if;
3772
3773          --  Restore saved polling mode
3774
3775          Polling_Required := Old_Poll;
3776       end;
3777    end Expand_Cleanup_Actions;
3778
3779    ---------------------------
3780    -- Expand_N_Package_Body --
3781    ---------------------------
3782
3783    --  Add call to Activate_Tasks if body is an activator (actual processing
3784    --  is in chapter 9).
3785
3786    --  Generate subprogram descriptor for elaboration routine
3787
3788    --  Encode entity names in package body
3789
3790    procedure Expand_N_Package_Body (N : Node_Id) is
3791       Spec_Ent : constant Entity_Id := Corresponding_Spec (N);
3792       Fin_Id   : Entity_Id;
3793
3794    begin
3795       --  This is done only for non-generic packages
3796
3797       if Ekind (Spec_Ent) = E_Package then
3798          Push_Scope (Corresponding_Spec (N));
3799
3800          --  Build dispatch tables of library level tagged types
3801
3802          if Tagged_Type_Expansion
3803            and then Is_Library_Level_Entity (Spec_Ent)
3804          then
3805             Build_Static_Dispatch_Tables (N);
3806          end if;
3807
3808          Build_Task_Activation_Call (N);
3809          Pop_Scope;
3810       end if;
3811
3812       Set_Elaboration_Flag (N, Corresponding_Spec (N));
3813       Set_In_Package_Body (Spec_Ent, False);
3814
3815       --  Set to encode entity names in package body before gigi is called
3816
3817       Qualify_Entity_Names (N);
3818
3819       if Ekind (Spec_Ent) /= E_Generic_Package then
3820          Build_Finalizer
3821            (N           => N,
3822             Clean_Stmts => No_List,
3823             Mark_Id     => Empty,
3824             Top_Decls   => No_List,
3825             Defer_Abort => False,
3826             Fin_Id      => Fin_Id);
3827
3828          if Present (Fin_Id) then
3829             declare
3830                Body_Ent : Node_Id := Defining_Unit_Name (N);
3831
3832             begin
3833                if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
3834                   Body_Ent := Defining_Identifier (Body_Ent);
3835                end if;
3836
3837                Set_Finalizer (Body_Ent, Fin_Id);
3838             end;
3839          end if;
3840       end if;
3841    end Expand_N_Package_Body;
3842
3843    ----------------------------------
3844    -- Expand_N_Package_Declaration --
3845    ----------------------------------
3846
3847    --  Add call to Activate_Tasks if there are tasks declared and the package
3848    --  has no body. Note that in Ada 83 this may result in premature activation
3849    --  of some tasks, given that we cannot tell whether a body will eventually
3850    --  appear.
3851
3852    procedure Expand_N_Package_Declaration (N : Node_Id) is
3853       Id     : constant Entity_Id := Defining_Entity (N);
3854       Spec   : constant Node_Id   := Specification (N);
3855       Decls  : List_Id;
3856       Fin_Id : Entity_Id;
3857
3858       No_Body : Boolean := False;
3859       --  True in the case of a package declaration that is a compilation
3860       --  unit and for which no associated body will be compiled in this
3861       --  compilation.
3862
3863    begin
3864       --  Case of a package declaration other than a compilation unit
3865
3866       if Nkind (Parent (N)) /= N_Compilation_Unit then
3867          null;
3868
3869       --  Case of a compilation unit that does not require a body
3870
3871       elsif not Body_Required (Parent (N))
3872         and then not Unit_Requires_Body (Id)
3873       then
3874          No_Body := True;
3875
3876       --  Special case of generating calling stubs for a remote call interface
3877       --  package: even though the package declaration requires one, the body
3878       --  won't be processed in this compilation (so any stubs for RACWs
3879       --  declared in the package must be generated here, along with the spec).
3880
3881       elsif Parent (N) = Cunit (Main_Unit)
3882         and then Is_Remote_Call_Interface (Id)
3883         and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
3884       then
3885          No_Body := True;
3886       end if;
3887
3888       --  For a nested instance, delay processing until freeze point
3889
3890       if Has_Delayed_Freeze (Id)
3891         and then Nkind (Parent (N)) /= N_Compilation_Unit
3892       then
3893          return;
3894       end if;
3895
3896       --  For a package declaration that implies no associated body, generate
3897       --  task activation call and RACW supporting bodies now (since we won't
3898       --  have a specific separate compilation unit for that).
3899
3900       if No_Body then
3901          Push_Scope (Id);
3902
3903          if Has_RACW (Id) then
3904
3905             --  Generate RACW subprogram bodies
3906
3907             Decls := Private_Declarations (Spec);
3908
3909             if No (Decls) then
3910                Decls := Visible_Declarations (Spec);
3911             end if;
3912
3913             if No (Decls) then
3914                Decls := New_List;
3915                Set_Visible_Declarations (Spec, Decls);
3916             end if;
3917
3918             Append_RACW_Bodies (Decls, Id);
3919             Analyze_List (Decls);
3920          end if;
3921
3922          if Present (Activation_Chain_Entity (N)) then
3923
3924             --  Generate task activation call as last step of elaboration
3925
3926             Build_Task_Activation_Call (N);
3927          end if;
3928
3929          Pop_Scope;
3930       end if;
3931
3932       --  Build dispatch tables of library level tagged types
3933
3934       if Tagged_Type_Expansion
3935         and then (Is_Compilation_Unit (Id)
3936                    or else (Is_Generic_Instance (Id)
3937                              and then Is_Library_Level_Entity (Id)))
3938       then
3939          Build_Static_Dispatch_Tables (N);
3940       end if;
3941
3942       --  Note: it is not necessary to worry about generating a subprogram
3943       --  descriptor, since the only way to get exception handlers into a
3944       --  package spec is to include instantiations, and that would cause
3945       --  generation of subprogram descriptors to be delayed in any case.
3946
3947       --  Set to encode entity names in package spec before gigi is called
3948
3949       Qualify_Entity_Names (N);
3950
3951       if Ekind (Id) /= E_Generic_Package then
3952          Build_Finalizer
3953            (N           => N,
3954             Clean_Stmts => No_List,
3955             Mark_Id     => Empty,
3956             Top_Decls   => No_List,
3957             Defer_Abort => False,
3958             Fin_Id      => Fin_Id);
3959
3960          Set_Finalizer (Id, Fin_Id);
3961       end if;
3962    end Expand_N_Package_Declaration;
3963
3964    -----------------------------
3965    -- Find_Node_To_Be_Wrapped --
3966    -----------------------------
3967
3968    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
3969       P          : Node_Id;
3970       The_Parent : Node_Id;
3971
3972    begin
3973       The_Parent := N;
3974       loop
3975          P := The_Parent;
3976          pragma Assert (P /= Empty);
3977          The_Parent := Parent (P);
3978
3979          case Nkind (The_Parent) is
3980
3981             --  Simple statement can be wrapped
3982
3983             when N_Pragma =>
3984                return The_Parent;
3985
3986             --  Usually assignments are good candidate for wrapping except
3987             --  when they have been generated as part of a controlled aggregate
3988             --  where the wrapping should take place more globally.
3989
3990             when N_Assignment_Statement =>
3991                if No_Ctrl_Actions (The_Parent) then
3992                   null;
3993                else
3994                   return The_Parent;
3995                end if;
3996
3997             --  An entry call statement is a special case if it occurs in the
3998             --  context of a Timed_Entry_Call. In this case we wrap the entire
3999             --  timed entry call.
4000
4001             when N_Entry_Call_Statement     |
4002                  N_Procedure_Call_Statement =>
4003                if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
4004                  and then Nkind_In (Parent (Parent (The_Parent)),
4005                                     N_Timed_Entry_Call,
4006                                     N_Conditional_Entry_Call)
4007                then
4008                   return Parent (Parent (The_Parent));
4009                else
4010                   return The_Parent;
4011                end if;
4012
4013             --  Object declarations are also a boundary for the transient scope
4014             --  even if they are not really wrapped. For further details, see
4015             --  Wrap_Transient_Declaration.
4016
4017             when N_Object_Declaration          |
4018                  N_Object_Renaming_Declaration |
4019                  N_Subtype_Declaration         =>
4020                return The_Parent;
4021
4022             --  The expression itself is to be wrapped if its parent is a
4023             --  compound statement or any other statement where the expression
4024             --  is known to be scalar
4025
4026             when N_Accept_Alternative               |
4027                  N_Attribute_Definition_Clause      |
4028                  N_Case_Statement                   |
4029                  N_Code_Statement                   |
4030                  N_Delay_Alternative                |
4031                  N_Delay_Until_Statement            |
4032                  N_Delay_Relative_Statement         |
4033                  N_Discriminant_Association         |
4034                  N_Elsif_Part                       |
4035                  N_Entry_Body_Formal_Part           |
4036                  N_Exit_Statement                   |
4037                  N_If_Statement                     |
4038                  N_Iteration_Scheme                 |
4039                  N_Terminate_Alternative            =>
4040                return P;
4041
4042             when N_Attribute_Reference =>
4043
4044                if Is_Procedure_Attribute_Name
4045                     (Attribute_Name (The_Parent))
4046                then
4047                   return The_Parent;
4048                end if;
4049
4050             --  A raise statement can be wrapped. This will arise when the
4051             --  expression in a raise_with_expression uses the secondary
4052             --  stack, for example.
4053
4054             when N_Raise_Statement =>
4055                return The_Parent;
4056
4057             --  If the expression is within the iteration scheme of a loop,
4058             --  we must create a declaration for it, followed by an assignment
4059             --  in order to have a usable statement to wrap.
4060
4061             when N_Loop_Parameter_Specification =>
4062                return Parent (The_Parent);
4063
4064             --  The following nodes contains "dummy calls" which don't need to
4065             --  be wrapped.
4066
4067             when N_Parameter_Specification     |
4068                  N_Discriminant_Specification  |
4069                  N_Component_Declaration       =>
4070                return Empty;
4071
4072             --  The return statement is not to be wrapped when the function
4073             --  itself needs wrapping at the outer-level
4074
4075             when N_Simple_Return_Statement =>
4076                declare
4077                   Applies_To : constant Entity_Id :=
4078                                  Return_Applies_To
4079                                    (Return_Statement_Entity (The_Parent));
4080                   Return_Type : constant Entity_Id := Etype (Applies_To);
4081                begin
4082                   if Requires_Transient_Scope (Return_Type) then
4083                      return Empty;
4084                   else
4085                      return The_Parent;
4086                   end if;
4087                end;
4088
4089             --  If we leave a scope without having been able to find a node to
4090             --  wrap, something is going wrong but this can happen in error
4091             --  situation that are not detected yet (such as a dynamic string
4092             --  in a pragma export)
4093
4094             when N_Subprogram_Body     |
4095                  N_Package_Declaration |
4096                  N_Package_Body        |
4097                  N_Block_Statement     =>
4098                return Empty;
4099
4100             --  Otherwise continue the search
4101
4102             when others =>
4103                null;
4104          end case;
4105       end loop;
4106    end Find_Node_To_Be_Wrapped;
4107
4108    -------------------------------------
4109    -- Get_Global_Pool_For_Access_Type --
4110    -------------------------------------
4111
4112    function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is
4113    begin
4114       --  Access types whose size is smaller than System.Address size can exist
4115       --  only on VMS. We can't use the usual global pool which returns an
4116       --  object of type Address as truncation will make it invalid. To handle
4117       --  this case, VMS has a dedicated global pool that returns addresses
4118       --  that fit into 32 bit accesses.
4119
4120       if Opt.True_VMS_Target and then Esize (T) = 32 then
4121          return RTE (RE_Global_Pool_32_Object);
4122       else
4123          return RTE (RE_Global_Pool_Object);
4124       end if;
4125    end Get_Global_Pool_For_Access_Type;
4126
4127    ----------------------------------
4128    -- Has_New_Controlled_Component --
4129    ----------------------------------
4130
4131    function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
4132       Comp : Entity_Id;
4133
4134    begin
4135       if not Is_Tagged_Type (E) then
4136          return Has_Controlled_Component (E);
4137       elsif not Is_Derived_Type (E) then
4138          return Has_Controlled_Component (E);
4139       end if;
4140
4141       Comp := First_Component (E);
4142       while Present (Comp) loop
4143          if Chars (Comp) = Name_uParent then
4144             null;
4145
4146          elsif Scope (Original_Record_Component (Comp)) = E
4147            and then Needs_Finalization (Etype (Comp))
4148          then
4149             return True;
4150          end if;
4151
4152          Next_Component (Comp);
4153       end loop;
4154
4155       return False;
4156    end Has_New_Controlled_Component;
4157
4158    ---------------------------------
4159    -- Has_Simple_Protected_Object --
4160    ---------------------------------
4161
4162    function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
4163    begin
4164       if Has_Task (T) then
4165          return False;
4166
4167       elsif Is_Simple_Protected_Type (T) then
4168          return True;
4169
4170       elsif Is_Array_Type (T) then
4171          return Has_Simple_Protected_Object (Component_Type (T));
4172
4173       elsif Is_Record_Type (T) then
4174          declare
4175             Comp : Entity_Id;
4176
4177          begin
4178             Comp := First_Component (T);
4179             while Present (Comp) loop
4180                if Has_Simple_Protected_Object (Etype (Comp)) then
4181                   return True;
4182                end if;
4183
4184                Next_Component (Comp);
4185             end loop;
4186
4187             return False;
4188          end;
4189
4190       else
4191          return False;
4192       end if;
4193    end Has_Simple_Protected_Object;
4194
4195    ------------------------------------
4196    -- Insert_Actions_In_Scope_Around --
4197    ------------------------------------
4198
4199    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
4200       SE     : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
4201       After  : List_Id renames SE.Actions_To_Be_Wrapped_After;
4202       Before : List_Id renames SE.Actions_To_Be_Wrapped_Before;
4203
4204       procedure Process_Transient_Objects
4205         (First_Object : Node_Id;
4206          Last_Object  : Node_Id;
4207          Related_Node : Node_Id);
4208       --  First_Object and Last_Object define a list which contains potential
4209       --  controlled transient objects. Finalization flags are inserted before
4210       --  First_Object and finalization calls are inserted after Last_Object.
4211       --  Related_Node is the node for which transient objects have been
4212       --  created.
4213
4214       -------------------------------
4215       -- Process_Transient_Objects --
4216       -------------------------------
4217
4218       procedure Process_Transient_Objects
4219         (First_Object : Node_Id;
4220          Last_Object  : Node_Id;
4221          Related_Node : Node_Id)
4222       is
4223          Requires_Hooking : constant Boolean :=
4224                               Nkind_In (N, N_Function_Call,
4225                                            N_Procedure_Call_Statement);
4226
4227          Built     : Boolean := False;
4228          Desig_Typ : Entity_Id;
4229          Fin_Block : Node_Id;
4230          Fin_Data  : Finalization_Exception_Data;
4231          Fin_Decls : List_Id;
4232          Last_Fin  : Node_Id := Empty;
4233          Loc       : Source_Ptr;
4234          Obj_Id    : Entity_Id;
4235          Obj_Ref   : Node_Id;
4236          Obj_Typ   : Entity_Id;
4237          Stmt      : Node_Id;
4238          Stmts     : List_Id;
4239          Temp_Id   : Entity_Id;
4240
4241       begin
4242          --  Examine all objects in the list First_Object .. Last_Object
4243
4244          Stmt := First_Object;
4245          while Present (Stmt) loop
4246             if Nkind (Stmt) = N_Object_Declaration
4247               and then Analyzed (Stmt)
4248               and then Is_Finalizable_Transient (Stmt, N)
4249
4250               --  Do not process the node to be wrapped since it will be
4251               --  handled by the enclosing finalizer.
4252
4253               and then Stmt /= Related_Node
4254             then
4255                Loc       := Sloc (Stmt);
4256                Obj_Id    := Defining_Identifier (Stmt);
4257                Obj_Typ   := Base_Type (Etype (Obj_Id));
4258                Desig_Typ := Obj_Typ;
4259
4260                Set_Is_Processed_Transient (Obj_Id);
4261
4262                --  Handle access types
4263
4264                if Is_Access_Type (Desig_Typ) then
4265                   Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4266                end if;
4267
4268                --  Create the necessary entities and declarations the first
4269                --  time around.
4270
4271                if not Built then
4272                   Fin_Decls := New_List;
4273
4274                   Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
4275                   Insert_List_Before_And_Analyze (First_Object, Fin_Decls);
4276
4277                   Built := True;
4278                end if;
4279
4280                --  Transient variables associated with subprogram calls need
4281                --  extra processing. These variables are usually created right
4282                --  before the call and finalized immediately after the call.
4283                --  If an exception occurs during the call, the clean up code
4284                --  is skipped due to the sudden change in control and the
4285                --  transient is never finalized.
4286
4287                --  To handle this case, such variables are "exported" to the
4288                --  enclosing sequence of statements where their corresponding
4289                --  "hooks" are picked up by the finalization machinery.
4290
4291                if Requires_Hooking then
4292                   declare
4293                      Expr   : Node_Id;
4294                      Ptr_Id : Entity_Id;
4295
4296                   begin
4297                      --  Step 1: Create an access type which provides a
4298                      --  reference to the transient object. Generate:
4299
4300                      --    Ann : access [all] <Desig_Typ>;
4301
4302                      Ptr_Id := Make_Temporary (Loc, 'A');
4303
4304                      Insert_Action (Stmt,
4305                        Make_Full_Type_Declaration (Loc,
4306                          Defining_Identifier => Ptr_Id,
4307                          Type_Definition     =>
4308                            Make_Access_To_Object_Definition (Loc,
4309                              All_Present        =>
4310                                Ekind (Obj_Typ) = E_General_Access_Type,
4311                              Subtype_Indication =>
4312                                New_Reference_To (Desig_Typ, Loc))));
4313
4314                      --  Step 2: Create a temporary which acts as a hook to
4315                      --  the transient object. Generate:
4316
4317                      --    Temp : Ptr_Id := null;
4318
4319                      Temp_Id := Make_Temporary (Loc, 'T');
4320
4321                      Insert_Action (Stmt,
4322                        Make_Object_Declaration (Loc,
4323                          Defining_Identifier => Temp_Id,
4324                          Object_Definition   =>
4325                            New_Reference_To (Ptr_Id, Loc)));
4326
4327                      --  Mark the temporary as a transient hook. This signals
4328                      --  the machinery in Build_Finalizer to recognize this
4329                      --  special case.
4330
4331                      Set_Return_Flag_Or_Transient_Decl (Temp_Id, Stmt);
4332
4333                      --  Step 3: Hook the transient object to the temporary
4334
4335                      if Is_Access_Type (Obj_Typ) then
4336                         Expr :=
4337                           Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
4338                      else
4339                         Expr :=
4340                           Make_Attribute_Reference (Loc,
4341                             Prefix         => New_Reference_To (Obj_Id, Loc),
4342                             Attribute_Name => Name_Unrestricted_Access);
4343                      end if;
4344
4345                      --  Generate:
4346                      --    Temp := Ptr_Id (Obj_Id);
4347                      --      <or>
4348                      --    Temp := Obj_Id'Unrestricted_Access;
4349
4350                      Insert_After_And_Analyze (Stmt,
4351                        Make_Assignment_Statement (Loc,
4352                          Name       => New_Reference_To (Temp_Id, Loc),
4353                          Expression => Expr));
4354                   end;
4355                end if;
4356
4357                Stmts := New_List;
4358
4359                --  The transient object is about to be finalized by the clean
4360                --  up code following the subprogram call. In order to avoid
4361                --  double finalization, clear the hook.
4362
4363                --  Generate:
4364                --    Temp := null;
4365
4366                if Requires_Hooking then
4367                   Append_To (Stmts,
4368                     Make_Assignment_Statement (Loc,
4369                       Name       => New_Reference_To (Temp_Id, Loc),
4370                       Expression => Make_Null (Loc)));
4371                end if;
4372
4373                --  Generate:
4374                --    [Deep_]Finalize (Obj_Ref);
4375
4376                Obj_Ref := New_Reference_To (Obj_Id, Loc);
4377
4378                if Is_Access_Type (Obj_Typ) then
4379                   Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4380                end if;
4381
4382                Append_To (Stmts,
4383                  Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ));
4384
4385                --  Generate:
4386                --    [Temp := null;]
4387                --    begin
4388                --       [Deep_]Finalize (Obj_Ref);
4389
4390                --    exception
4391                --       when others =>
4392                --          if not Raised then
4393                --             Raised := True;
4394                --             Save_Occurrence
4395                --               (Enn, Get_Current_Excep.all.all);
4396                --          end if;
4397                --    end;
4398
4399                Fin_Block :=
4400                  Make_Block_Statement (Loc,
4401                    Handled_Statement_Sequence =>
4402                      Make_Handled_Sequence_Of_Statements (Loc,
4403                        Statements => Stmts,
4404                        Exception_Handlers => New_List (
4405                          Build_Exception_Handler (Fin_Data))));
4406
4407                Insert_After_And_Analyze (Last_Object, Fin_Block);
4408
4409                --  The raise statement must be inserted after all the
4410                --  finalization blocks.
4411
4412                if No (Last_Fin) then
4413                   Last_Fin := Fin_Block;
4414                end if;
4415
4416             --  When the associated node is an array object, the expander may
4417             --  sometimes generate a loop and create transient objects inside
4418             --  the loop.
4419
4420             elsif Nkind (Related_Node) = N_Object_Declaration
4421               and then Is_Array_Type
4422                          (Base_Type
4423                            (Etype (Defining_Identifier (Related_Node))))
4424               and then Nkind (Stmt) = N_Loop_Statement
4425             then
4426                declare
4427                   Block_HSS : Node_Id := First (Statements (Stmt));
4428
4429                begin
4430                   --  The loop statements may have been wrapped in a block by
4431                   --  Process_Statements_For_Controlled_Objects, inspect the
4432                   --  handled sequence of statements.
4433
4434                   if Nkind (Block_HSS) = N_Block_Statement
4435                     and then No (Next (Block_HSS))
4436                   then
4437                      Block_HSS := Handled_Statement_Sequence (Block_HSS);
4438
4439                      Process_Transient_Objects
4440                        (First_Object => First (Statements (Block_HSS)),
4441                         Last_Object  => Last (Statements (Block_HSS)),
4442                         Related_Node => Related_Node);
4443
4444                   --  Inspect the statements of the loop
4445
4446                   else
4447                      Process_Transient_Objects
4448                        (First_Object => First (Statements (Stmt)),
4449                         Last_Object  => Last (Statements (Stmt)),
4450                         Related_Node => Related_Node);
4451                   end if;
4452                end;
4453
4454             --  Terminate the scan after the last object has been processed
4455
4456             elsif Stmt = Last_Object then
4457                exit;
4458             end if;
4459
4460             Next (Stmt);
4461          end loop;
4462
4463          --  Generate:
4464          --    if Raised and then not Abort then
4465          --       Raise_From_Controlled_Operation (E);
4466          --    end if;
4467
4468          if Built
4469            and then Present (Last_Fin)
4470          then
4471             Insert_After_And_Analyze (Last_Fin,
4472               Build_Raise_Statement (Fin_Data));
4473          end if;
4474       end Process_Transient_Objects;
4475
4476    --  Start of processing for Insert_Actions_In_Scope_Around
4477
4478    begin
4479       if No (Before) and then No (After) then
4480          return;
4481       end if;
4482
4483       declare
4484          Node_To_Wrap  : constant Node_Id := Node_To_Be_Wrapped;
4485          First_Obj  : Node_Id;
4486          Last_Obj   : Node_Id;
4487          Target     : Node_Id;
4488
4489       begin
4490          --  If the node to be wrapped is the trigger of an asynchronous
4491          --  select, it is not part of a statement list. The actions must be
4492          --  inserted before the select itself, which is part of some list of
4493          --  statements. Note that the triggering alternative includes the
4494          --  triggering statement and an optional statement list. If the node
4495          --  to be wrapped is part of that list, the normal insertion applies.
4496
4497          if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
4498            and then not Is_List_Member (Node_To_Wrap)
4499          then
4500             Target := Parent (Parent (Node_To_Wrap));
4501          else
4502             Target := N;
4503          end if;
4504
4505          First_Obj := Target;
4506          Last_Obj  := Target;
4507
4508          --  Add all actions associated with a transient scope into the main
4509          --  tree. There are several scenarios here:
4510
4511          --       +--- Before ----+        +----- After ---+
4512          --    1) First_Obj ....... Target ........ Last_Obj
4513
4514          --    2) First_Obj ....... Target
4515
4516          --    3)                   Target ........ Last_Obj
4517
4518          if Present (Before) then
4519
4520             --  Flag declarations are inserted before the first object
4521
4522             First_Obj := First (Before);
4523
4524             Insert_List_Before (Target, Before);
4525          end if;
4526
4527          if Present (After) then
4528
4529             --  Finalization calls are inserted after the last object
4530
4531             Last_Obj := Last (After);
4532
4533             Insert_List_After (Target, After);
4534          end if;
4535
4536          --  Check for transient controlled objects associated with Target and
4537          --  generate the appropriate finalization actions for them.
4538
4539          Process_Transient_Objects
4540            (First_Object => First_Obj,
4541             Last_Object  => Last_Obj,
4542             Related_Node => Target);
4543
4544          --  Reset the action lists
4545
4546          if Present (Before) then
4547             Before := No_List;
4548          end if;
4549
4550          if Present (After) then
4551             After := No_List;
4552          end if;
4553       end;
4554    end Insert_Actions_In_Scope_Around;
4555
4556    ------------------------------
4557    -- Is_Simple_Protected_Type --
4558    ------------------------------
4559
4560    function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
4561    begin
4562       return
4563         Is_Protected_Type (T)
4564           and then not Has_Entries (T)
4565           and then Is_RTE (Find_Protection_Type (T), RE_Protection);
4566    end Is_Simple_Protected_Type;
4567
4568    -----------------------
4569    -- Make_Adjust_Call --
4570    -----------------------
4571
4572    function Make_Adjust_Call
4573      (Obj_Ref    : Node_Id;
4574       Typ        : Entity_Id;
4575       For_Parent : Boolean := False) return Node_Id
4576    is
4577       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
4578       Adj_Id : Entity_Id := Empty;
4579       Ref    : Node_Id   := Obj_Ref;
4580       Utyp   : Entity_Id;
4581
4582    begin
4583       --  Recover the proper type which contains Deep_Adjust
4584
4585       if Is_Class_Wide_Type (Typ) then
4586          Utyp := Root_Type (Typ);
4587       else
4588          Utyp := Typ;
4589       end if;
4590
4591       Utyp := Underlying_Type (Base_Type (Utyp));
4592       Set_Assignment_OK (Ref);
4593
4594       --  Deal with non-tagged derivation of private views
4595
4596       if Is_Untagged_Derivation (Typ) then
4597          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
4598          Ref  := Unchecked_Convert_To (Utyp, Ref);
4599          Set_Assignment_OK (Ref);
4600       end if;
4601
4602       --  When dealing with the completion of a private type, use the base
4603       --  type instead.
4604
4605       if Utyp /= Base_Type (Utyp) then
4606          pragma Assert (Is_Private_Type (Typ));
4607
4608          Utyp := Base_Type (Utyp);
4609          Ref  := Unchecked_Convert_To (Utyp, Ref);
4610       end if;
4611
4612       --  Select the appropriate version of adjust
4613
4614       if For_Parent then
4615          if Has_Controlled_Component (Utyp) then
4616             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4617          end if;
4618
4619       --  Class-wide types, interfaces and types with controlled components
4620
4621       elsif Is_Class_Wide_Type (Typ)
4622         or else Is_Interface (Typ)
4623         or else Has_Controlled_Component (Utyp)
4624       then
4625          if Is_Tagged_Type (Utyp) then
4626             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4627          else
4628             Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
4629          end if;
4630
4631       --  Derivations from [Limited_]Controlled
4632
4633       elsif Is_Controlled (Utyp) then
4634          if Has_Controlled_Component (Utyp) then
4635             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4636          else
4637             Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
4638          end if;
4639
4640       --  Tagged types
4641
4642       elsif Is_Tagged_Type (Utyp) then
4643          Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4644
4645       else
4646          raise Program_Error;
4647       end if;
4648
4649       if Present (Adj_Id) then
4650
4651          --  If the object is unanalyzed, set its expected type for use in
4652          --  Convert_View in case an additional conversion is needed.
4653
4654          if No (Etype (Ref))
4655            and then Nkind (Ref) /= N_Unchecked_Type_Conversion
4656          then
4657             Set_Etype (Ref, Typ);
4658          end if;
4659
4660          --  The object reference may need another conversion depending on the
4661          --  type of the formal and that of the actual.
4662
4663          if not Is_Class_Wide_Type (Typ) then
4664             Ref := Convert_View (Adj_Id, Ref);
4665          end if;
4666
4667          return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent);
4668       else
4669          return Empty;
4670       end if;
4671    end Make_Adjust_Call;
4672
4673    ----------------------
4674    -- Make_Attach_Call --
4675    ----------------------
4676
4677    function Make_Attach_Call
4678      (Obj_Ref : Node_Id;
4679       Ptr_Typ : Entity_Id) return Node_Id
4680    is
4681       pragma Assert (VM_Target /= No_VM);
4682
4683       Loc : constant Source_Ptr := Sloc (Obj_Ref);
4684    begin
4685       return
4686         Make_Procedure_Call_Statement (Loc,
4687           Name                   =>
4688             New_Reference_To (RTE (RE_Attach), Loc),
4689           Parameter_Associations => New_List (
4690             New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
4691             Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
4692    end Make_Attach_Call;
4693
4694    ----------------------
4695    -- Make_Detach_Call --
4696    ----------------------
4697
4698    function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
4699       Loc : constant Source_Ptr := Sloc (Obj_Ref);
4700
4701    begin
4702       return
4703         Make_Procedure_Call_Statement (Loc,
4704           Name                   =>
4705             New_Reference_To (RTE (RE_Detach), Loc),
4706           Parameter_Associations => New_List (
4707             Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
4708    end Make_Detach_Call;
4709
4710    ---------------
4711    -- Make_Call --
4712    ---------------
4713
4714    function Make_Call
4715      (Loc        : Source_Ptr;
4716       Proc_Id    : Entity_Id;
4717       Param      : Node_Id;
4718       For_Parent : Boolean := False) return Node_Id
4719    is
4720       Params : constant List_Id := New_List (Param);
4721
4722    begin
4723       --  When creating a call to Deep_Finalize for a _parent field of a
4724       --  derived type, disable the invocation of the nested Finalize by giving
4725       --  the corresponding flag a False value.
4726
4727       if For_Parent then
4728          Append_To (Params, New_Reference_To (Standard_False, Loc));
4729       end if;
4730
4731       return
4732         Make_Procedure_Call_Statement (Loc,
4733           Name                   => New_Reference_To (Proc_Id, Loc),
4734           Parameter_Associations => Params);
4735    end Make_Call;
4736
4737    --------------------------
4738    -- Make_Deep_Array_Body --
4739    --------------------------
4740
4741    function Make_Deep_Array_Body
4742      (Prim : Final_Primitives;
4743       Typ  : Entity_Id) return List_Id
4744    is
4745       function Build_Adjust_Or_Finalize_Statements
4746         (Typ : Entity_Id) return List_Id;
4747       --  Create the statements necessary to adjust or finalize an array of
4748       --  controlled elements. Generate:
4749       --
4750       --    declare
4751       --       Abort  : constant Boolean := Triggered_By_Abort;
4752       --         <or>
4753       --       Abort  : constant Boolean := False;  --  no abort
4754       --
4755       --       E      : Exception_Occurrence;
4756       --       Raised : Boolean := False;
4757       --
4758       --    begin
4759       --       for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
4760       --                 ^--  in the finalization case
4761       --          ...
4762       --          for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
4763       --             begin
4764       --                [Deep_]Adjust / Finalize (V (J1, ..., Jn));
4765       --
4766       --             exception
4767       --                when others =>
4768       --                   if not Raised then
4769       --                      Raised := True;
4770       --                      Save_Occurrence (E, Get_Current_Excep.all.all);
4771       --                   end if;
4772       --             end;
4773       --          end loop;
4774       --          ...
4775       --       end loop;
4776       --
4777       --       if Raised and then not Abort then
4778       --          Raise_From_Controlled_Operation (E);
4779       --       end if;
4780       --    end;
4781
4782       function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
4783       --  Create the statements necessary to initialize an array of controlled
4784       --  elements. Include a mechanism to carry out partial finalization if an
4785       --  exception occurs. Generate:
4786       --
4787       --    declare
4788       --       Counter : Integer := 0;
4789       --
4790       --    begin
4791       --       for J1 in V'Range (1) loop
4792       --          ...
4793       --          for JN in V'Range (N) loop
4794       --             begin
4795       --                [Deep_]Initialize (V (J1, ..., JN));
4796       --
4797       --                Counter := Counter + 1;
4798       --
4799       --             exception
4800       --                when others =>
4801       --                   declare
4802       --                      Abort  : constant Boolean := Triggered_By_Abort;
4803       --                        <or>
4804       --                      Abort  : constant Boolean := False; --  no abort
4805       --                      E      : Exception_Occurence;
4806       --                      Raised : Boolean := False;
4807
4808       --                   begin
4809       --                      Counter :=
4810       --                        V'Length (1) *
4811       --                        V'Length (2) *
4812       --                        ...
4813       --                        V'Length (N) - Counter;
4814
4815       --                      for F1 in reverse V'Range (1) loop
4816       --                         ...
4817       --                         for FN in reverse V'Range (N) loop
4818       --                            if Counter > 0 then
4819       --                               Counter := Counter - 1;
4820       --                            else
4821       --                               begin
4822       --                                  [Deep_]Finalize (V (F1, ..., FN));
4823
4824       --                               exception
4825       --                                  when others =>
4826       --                                     if not Raised then
4827       --                                        Raised := True;
4828       --                                        Save_Occurrence (E,
4829       --                                          Get_Current_Excep.all.all);
4830       --                                     end if;
4831       --                               end;
4832       --                            end if;
4833       --                         end loop;
4834       --                         ...
4835       --                      end loop;
4836       --                   end;
4837       --
4838       --                   if Raised and then not Abort then
4839       --                      Raise_From_Controlled_Operation (E);
4840       --                   end if;
4841       --
4842       --                   raise;
4843       --             end;
4844       --          end loop;
4845       --       end loop;
4846       --    end;
4847
4848       function New_References_To
4849         (L   : List_Id;
4850          Loc : Source_Ptr) return List_Id;
4851       --  Given a list of defining identifiers, return a list of references to
4852       --  the original identifiers, in the same order as they appear.
4853
4854       -----------------------------------------
4855       -- Build_Adjust_Or_Finalize_Statements --
4856       -----------------------------------------
4857
4858       function Build_Adjust_Or_Finalize_Statements
4859         (Typ : Entity_Id) return List_Id
4860       is
4861          Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
4862          Index_List      : constant List_Id    := New_List;
4863          Loc             : constant Source_Ptr := Sloc (Typ);
4864          Num_Dims        : constant Int        := Number_Dimensions (Typ);
4865          Finalizer_Decls : List_Id := No_List;
4866          Finalizer_Data  : Finalization_Exception_Data;
4867          Call            : Node_Id;
4868          Comp_Ref        : Node_Id;
4869          Core_Loop       : Node_Id;
4870          Dim             : Int;
4871          J               : Entity_Id;
4872          Loop_Id         : Entity_Id;
4873          Stmts           : List_Id;
4874
4875          Exceptions_OK : constant Boolean :=
4876                            not Restriction_Active (No_Exception_Propagation);
4877
4878          procedure Build_Indices;
4879          --  Generate the indices used in the dimension loops
4880
4881          -------------------
4882          -- Build_Indices --
4883          -------------------
4884
4885          procedure Build_Indices is
4886          begin
4887             --  Generate the following identifiers:
4888             --    Jnn  -  for initialization
4889
4890             for Dim in 1 .. Num_Dims loop
4891                Append_To (Index_List,
4892                  Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
4893             end loop;
4894          end Build_Indices;
4895
4896       --  Start of processing for Build_Adjust_Or_Finalize_Statements
4897
4898       begin
4899          Finalizer_Decls := New_List;
4900
4901          Build_Indices;
4902          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
4903
4904          Comp_Ref :=
4905            Make_Indexed_Component (Loc,
4906              Prefix      => Make_Identifier (Loc, Name_V),
4907              Expressions => New_References_To (Index_List, Loc));
4908          Set_Etype (Comp_Ref, Comp_Typ);
4909
4910          --  Generate:
4911          --    [Deep_]Adjust (V (J1, ..., JN))
4912
4913          if Prim = Adjust_Case then
4914             Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
4915
4916          --  Generate:
4917          --    [Deep_]Finalize (V (J1, ..., JN))
4918
4919          else pragma Assert (Prim = Finalize_Case);
4920             Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
4921          end if;
4922
4923          --  Generate the block which houses the adjust or finalize call:
4924
4925          --    <adjust or finalize call>;  --  No_Exception_Propagation
4926
4927          --    begin                       --  Exception handlers allowed
4928          --       <adjust or finalize call>
4929
4930          --    exception
4931          --       when others =>
4932          --          if not Raised then
4933          --             Raised := True;
4934          --             Save_Occurrence (E, Get_Current_Excep.all.all);
4935          --          end if;
4936          --    end;
4937
4938          if Exceptions_OK then
4939             Core_Loop :=
4940               Make_Block_Statement (Loc,
4941                 Handled_Statement_Sequence =>
4942                   Make_Handled_Sequence_Of_Statements (Loc,
4943                     Statements         => New_List (Call),
4944                     Exception_Handlers => New_List (
4945                       Build_Exception_Handler (Finalizer_Data))));
4946          else
4947             Core_Loop := Call;
4948          end if;
4949
4950          --  Generate the dimension loops starting from the innermost one
4951
4952          --    for Jnn in [reverse] V'Range (Dim) loop
4953          --       <core loop>
4954          --    end loop;
4955
4956          J := Last (Index_List);
4957          Dim := Num_Dims;
4958          while Present (J) and then Dim > 0 loop
4959             Loop_Id := J;
4960             Prev (J);
4961             Remove (Loop_Id);
4962
4963             Core_Loop :=
4964               Make_Loop_Statement (Loc,
4965                 Iteration_Scheme =>
4966                   Make_Iteration_Scheme (Loc,
4967                     Loop_Parameter_Specification =>
4968                       Make_Loop_Parameter_Specification (Loc,
4969                         Defining_Identifier         => Loop_Id,
4970                         Discrete_Subtype_Definition =>
4971                           Make_Attribute_Reference (Loc,
4972                             Prefix         => Make_Identifier (Loc, Name_V),
4973                             Attribute_Name => Name_Range,
4974                             Expressions    => New_List (
4975                               Make_Integer_Literal (Loc, Dim))),
4976
4977                         Reverse_Present => Prim = Finalize_Case)),
4978
4979                 Statements => New_List (Core_Loop),
4980                 End_Label  => Empty);
4981
4982             Dim := Dim - 1;
4983          end loop;
4984
4985          --  Generate the block which contains the core loop, the declarations
4986          --  of the abort flag, the exception occurrence, the raised flag and
4987          --  the conditional raise:
4988
4989          --    declare
4990          --       Abort  : constant Boolean := Triggered_By_Abort;
4991          --         <or>
4992          --       Abort  : constant Boolean := False;  --  no abort
4993
4994          --       E      : Exception_Occurrence;
4995          --       Raised : Boolean := False;
4996
4997          --    begin
4998          --       <core loop>
4999
5000          --       if Raised and then not Abort then  --  Expection handlers OK
5001          --          Raise_From_Controlled_Operation (E);
5002          --       end if;
5003          --    end;
5004
5005          Stmts := New_List (Core_Loop);
5006
5007          if Exceptions_OK then
5008             Append_To (Stmts,
5009               Build_Raise_Statement (Finalizer_Data));
5010          end if;
5011
5012          return
5013            New_List (
5014              Make_Block_Statement (Loc,
5015                Declarations               =>
5016                  Finalizer_Decls,
5017                Handled_Statement_Sequence =>
5018                  Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5019       end Build_Adjust_Or_Finalize_Statements;
5020
5021       ---------------------------------
5022       -- Build_Initialize_Statements --
5023       ---------------------------------
5024
5025       function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
5026          Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
5027          Final_List      : constant List_Id    := New_List;
5028          Index_List      : constant List_Id    := New_List;
5029          Loc             : constant Source_Ptr := Sloc (Typ);
5030          Num_Dims        : constant Int        := Number_Dimensions (Typ);
5031          Counter_Id      : Entity_Id;
5032          Dim             : Int;
5033          F               : Node_Id;
5034          Fin_Stmt        : Node_Id;
5035          Final_Block     : Node_Id;
5036          Final_Loop      : Node_Id;
5037          Finalizer_Data  : Finalization_Exception_Data;
5038          Finalizer_Decls : List_Id := No_List;
5039          Init_Loop       : Node_Id;
5040          J               : Node_Id;
5041          Loop_Id         : Node_Id;
5042          Stmts           : List_Id;
5043
5044          Exceptions_OK : constant Boolean :=
5045                            not Restriction_Active (No_Exception_Propagation);
5046
5047          function Build_Counter_Assignment return Node_Id;
5048          --  Generate the following assignment:
5049          --    Counter := V'Length (1) *
5050          --               ...
5051          --               V'Length (N) - Counter;
5052
5053          function Build_Finalization_Call return Node_Id;
5054          --  Generate a deep finalization call for an array element
5055
5056          procedure Build_Indices;
5057          --  Generate the initialization and finalization indices used in the
5058          --  dimension loops.
5059
5060          function Build_Initialization_Call return Node_Id;
5061          --  Generate a deep initialization call for an array element
5062
5063          ------------------------------
5064          -- Build_Counter_Assignment --
5065          ------------------------------
5066
5067          function Build_Counter_Assignment return Node_Id is
5068             Dim  : Int;
5069             Expr : Node_Id;
5070
5071          begin
5072             --  Start from the first dimension and generate:
5073             --    V'Length (1)
5074
5075             Dim := 1;
5076             Expr :=
5077               Make_Attribute_Reference (Loc,
5078                 Prefix         => Make_Identifier (Loc, Name_V),
5079                 Attribute_Name => Name_Length,
5080                 Expressions    => New_List (Make_Integer_Literal (Loc, Dim)));
5081
5082             --  Process the rest of the dimensions, generate:
5083             --    Expr * V'Length (N)
5084
5085             Dim := Dim + 1;
5086             while Dim <= Num_Dims loop
5087                Expr :=
5088                  Make_Op_Multiply (Loc,
5089                    Left_Opnd  => Expr,
5090                    Right_Opnd =>
5091                      Make_Attribute_Reference (Loc,
5092                        Prefix         => Make_Identifier (Loc, Name_V),
5093                        Attribute_Name => Name_Length,
5094                        Expressions    => New_List (
5095                          Make_Integer_Literal (Loc, Dim))));
5096
5097                Dim := Dim + 1;
5098             end loop;
5099
5100             --  Generate:
5101             --    Counter := Expr - Counter;
5102
5103             return
5104               Make_Assignment_Statement (Loc,
5105                 Name       => New_Reference_To (Counter_Id, Loc),
5106                 Expression =>
5107                   Make_Op_Subtract (Loc,
5108                     Left_Opnd  => Expr,
5109                     Right_Opnd => New_Reference_To (Counter_Id, Loc)));
5110          end Build_Counter_Assignment;
5111
5112          -----------------------------
5113          -- Build_Finalization_Call --
5114          -----------------------------
5115
5116          function Build_Finalization_Call return Node_Id is
5117             Comp_Ref : constant Node_Id :=
5118                          Make_Indexed_Component (Loc,
5119                            Prefix      => Make_Identifier (Loc, Name_V),
5120                            Expressions => New_References_To (Final_List, Loc));
5121
5122          begin
5123             Set_Etype (Comp_Ref, Comp_Typ);
5124
5125             --  Generate:
5126             --    [Deep_]Finalize (V);
5127
5128             return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5129          end Build_Finalization_Call;
5130
5131          -------------------
5132          -- Build_Indices --
5133          -------------------
5134
5135          procedure Build_Indices is
5136          begin
5137             --  Generate the following identifiers:
5138             --    Jnn  -  for initialization
5139             --    Fnn  -  for finalization
5140
5141             for Dim in 1 .. Num_Dims loop
5142                Append_To (Index_List,
5143                  Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5144
5145                Append_To (Final_List,
5146                  Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
5147             end loop;
5148          end Build_Indices;
5149
5150          -------------------------------
5151          -- Build_Initialization_Call --
5152          -------------------------------
5153
5154          function Build_Initialization_Call return Node_Id is
5155             Comp_Ref : constant Node_Id :=
5156                          Make_Indexed_Component (Loc,
5157                            Prefix      => Make_Identifier (Loc, Name_V),
5158                            Expressions => New_References_To (Index_List, Loc));
5159
5160          begin
5161             Set_Etype (Comp_Ref, Comp_Typ);
5162
5163             --  Generate:
5164             --    [Deep_]Initialize (V (J1, ..., JN));
5165
5166             return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5167          end Build_Initialization_Call;
5168
5169       --  Start of processing for Build_Initialize_Statements
5170
5171       begin
5172          Counter_Id := Make_Temporary (Loc, 'C');
5173          Finalizer_Decls := New_List;
5174
5175          Build_Indices;
5176          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5177
5178          --  Generate the block which houses the finalization call, the index
5179          --  guard and the handler which triggers Program_Error later on.
5180
5181          --    if Counter > 0 then
5182          --       Counter := Counter - 1;
5183          --    else
5184          --       [Deep_]Finalize (V (F1, ..., FN));  --  No_Except_Propagation
5185
5186          --       begin                               --  Exceptions allowed
5187          --          [Deep_]Finalize (V (F1, ..., FN));
5188          --       exception
5189          --          when others =>
5190          --             if not Raised then
5191          --                Raised := True;
5192          --                Save_Occurrence (E, Get_Current_Excep.all.all);
5193          --             end if;
5194          --       end;
5195          --    end if;
5196
5197          if Exceptions_OK then
5198             Fin_Stmt :=
5199               Make_Block_Statement (Loc,
5200                 Handled_Statement_Sequence =>
5201                   Make_Handled_Sequence_Of_Statements (Loc,
5202                     Statements         => New_List (Build_Finalization_Call),
5203                     Exception_Handlers => New_List (
5204                       Build_Exception_Handler (Finalizer_Data))));
5205          else
5206             Fin_Stmt := Build_Finalization_Call;
5207          end if;
5208
5209          --  This is the core of the loop, the dimension iterators are added
5210          --  one by one in reverse.
5211
5212          Final_Loop :=
5213            Make_If_Statement (Loc,
5214              Condition =>
5215                Make_Op_Gt (Loc,
5216                  Left_Opnd  => New_Reference_To (Counter_Id, Loc),
5217                  Right_Opnd => Make_Integer_Literal (Loc, 0)),
5218
5219              Then_Statements => New_List (
5220                Make_Assignment_Statement (Loc,
5221                  Name       => New_Reference_To (Counter_Id, Loc),
5222                  Expression =>
5223                    Make_Op_Subtract (Loc,
5224                      Left_Opnd  => New_Reference_To (Counter_Id, Loc),
5225                      Right_Opnd => Make_Integer_Literal (Loc, 1)))),
5226
5227              Else_Statements => New_List (Fin_Stmt));
5228
5229          --  Generate all finalization loops starting from the innermost
5230          --  dimension.
5231
5232          --    for Fnn in reverse V'Range (Dim) loop
5233          --       <final loop>
5234          --    end loop;
5235
5236          F := Last (Final_List);
5237          Dim := Num_Dims;
5238          while Present (F) and then Dim > 0 loop
5239             Loop_Id := F;
5240             Prev (F);
5241             Remove (Loop_Id);
5242
5243             Final_Loop :=
5244               Make_Loop_Statement (Loc,
5245                 Iteration_Scheme =>
5246                   Make_Iteration_Scheme (Loc,
5247                     Loop_Parameter_Specification =>
5248                       Make_Loop_Parameter_Specification (Loc,
5249                         Defining_Identifier => Loop_Id,
5250                         Discrete_Subtype_Definition =>
5251                           Make_Attribute_Reference (Loc,
5252                             Prefix         => Make_Identifier (Loc, Name_V),
5253                             Attribute_Name => Name_Range,
5254                             Expressions    => New_List (
5255                               Make_Integer_Literal (Loc, Dim))),
5256
5257                         Reverse_Present => True)),
5258
5259                 Statements => New_List (Final_Loop),
5260                 End_Label => Empty);
5261
5262             Dim := Dim - 1;
5263          end loop;
5264
5265          --  Generate the block which contains the finalization loops, the
5266          --  declarations of the abort flag, the exception occurrence, the
5267          --  raised flag and the conditional raise.
5268
5269          --    declare
5270          --       Abort  : constant Boolean := Triggered_By_Abort;
5271          --         <or>
5272          --       Abort  : constant Boolean := False;  --  no abort
5273
5274          --       E      : Exception_Occurrence;
5275          --       Raised : Boolean := False;
5276
5277          --    begin
5278          --       Counter :=
5279          --         V'Length (1) *
5280          --         ...
5281          --         V'Length (N) - Counter;
5282
5283          --       <final loop>
5284
5285          --       if Raised and then not Abort then  --  Exception handlers OK
5286          --          Raise_From_Controlled_Operation (E);
5287          --       end if;
5288
5289          --       raise;  --  Exception handlers OK
5290          --    end;
5291
5292          Stmts := New_List (Build_Counter_Assignment, Final_Loop);
5293
5294          if Exceptions_OK then
5295             Append_To (Stmts,
5296               Build_Raise_Statement (Finalizer_Data));
5297             Append_To (Stmts, Make_Raise_Statement (Loc));
5298          end if;
5299
5300          Final_Block :=
5301            Make_Block_Statement (Loc,
5302              Declarations               =>
5303                Finalizer_Decls,
5304              Handled_Statement_Sequence =>
5305                Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
5306
5307          --  Generate the block which contains the initialization call and
5308          --  the partial finalization code.
5309
5310          --    begin
5311          --       [Deep_]Initialize (V (J1, ..., JN));
5312
5313          --       Counter := Counter + 1;
5314
5315          --    exception
5316          --       when others =>
5317          --          <finalization code>
5318          --    end;
5319
5320          Init_Loop :=
5321            Make_Block_Statement (Loc,
5322              Handled_Statement_Sequence =>
5323                Make_Handled_Sequence_Of_Statements (Loc,
5324                  Statements         => New_List (Build_Initialization_Call),
5325                  Exception_Handlers => New_List (
5326                    Make_Exception_Handler (Loc,
5327                      Exception_Choices => New_List (Make_Others_Choice (Loc)),
5328                      Statements        => New_List (Final_Block)))));
5329
5330          Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
5331            Make_Assignment_Statement (Loc,
5332              Name       => New_Reference_To (Counter_Id, Loc),
5333              Expression =>
5334                Make_Op_Add (Loc,
5335                  Left_Opnd  => New_Reference_To (Counter_Id, Loc),
5336                  Right_Opnd => Make_Integer_Literal (Loc, 1))));
5337
5338          --  Generate all initialization loops starting from the innermost
5339          --  dimension.
5340
5341          --    for Jnn in V'Range (Dim) loop
5342          --       <init loop>
5343          --    end loop;
5344
5345          J := Last (Index_List);
5346          Dim := Num_Dims;
5347          while Present (J) and then Dim > 0 loop
5348             Loop_Id := J;
5349             Prev (J);
5350             Remove (Loop_Id);
5351
5352             Init_Loop :=
5353               Make_Loop_Statement (Loc,
5354                 Iteration_Scheme =>
5355                   Make_Iteration_Scheme (Loc,
5356                     Loop_Parameter_Specification =>
5357                       Make_Loop_Parameter_Specification (Loc,
5358                         Defining_Identifier => Loop_Id,
5359                         Discrete_Subtype_Definition =>
5360                           Make_Attribute_Reference (Loc,
5361                             Prefix         => Make_Identifier (Loc, Name_V),
5362                             Attribute_Name => Name_Range,
5363                             Expressions    => New_List (
5364                               Make_Integer_Literal (Loc, Dim))))),
5365
5366                 Statements => New_List (Init_Loop),
5367                 End_Label => Empty);
5368
5369             Dim := Dim - 1;
5370          end loop;
5371
5372          --  Generate the block which contains the counter variable and the
5373          --  initialization loops.
5374
5375          --    declare
5376          --       Counter : Integer := 0;
5377          --    begin
5378          --       <init loop>
5379          --    end;
5380
5381          return
5382            New_List (
5383              Make_Block_Statement (Loc,
5384                Declarations               => New_List (
5385                  Make_Object_Declaration (Loc,
5386                    Defining_Identifier => Counter_Id,
5387                    Object_Definition   =>
5388                      New_Reference_To (Standard_Integer, Loc),
5389                    Expression          => Make_Integer_Literal (Loc, 0))),
5390
5391                Handled_Statement_Sequence =>
5392                  Make_Handled_Sequence_Of_Statements (Loc,
5393                    Statements => New_List (Init_Loop))));
5394       end Build_Initialize_Statements;
5395
5396       -----------------------
5397       -- New_References_To --
5398       -----------------------
5399
5400       function New_References_To
5401         (L   : List_Id;
5402          Loc : Source_Ptr) return List_Id
5403       is
5404          Refs : constant List_Id := New_List;
5405          Id   : Node_Id;
5406
5407       begin
5408          Id := First (L);
5409          while Present (Id) loop
5410             Append_To (Refs, New_Reference_To (Id, Loc));
5411             Next (Id);
5412          end loop;
5413
5414          return Refs;
5415       end New_References_To;
5416
5417    --  Start of processing for Make_Deep_Array_Body
5418
5419    begin
5420       case Prim is
5421          when Address_Case =>
5422             return Make_Finalize_Address_Stmts (Typ);
5423
5424          when Adjust_Case   |
5425               Finalize_Case =>
5426             return Build_Adjust_Or_Finalize_Statements (Typ);
5427
5428          when Initialize_Case =>
5429             return Build_Initialize_Statements (Typ);
5430       end case;
5431    end Make_Deep_Array_Body;
5432
5433    --------------------
5434    -- Make_Deep_Proc --
5435    --------------------
5436
5437    function Make_Deep_Proc
5438      (Prim  : Final_Primitives;
5439       Typ   : Entity_Id;
5440       Stmts : List_Id) return Entity_Id
5441    is
5442       Loc     : constant Source_Ptr := Sloc (Typ);
5443       Formals : List_Id;
5444       Proc_Id : Entity_Id;
5445
5446    begin
5447       --  Create the object formal, generate:
5448       --    V : System.Address
5449
5450       if Prim = Address_Case then
5451          Formals := New_List (
5452            Make_Parameter_Specification (Loc,
5453              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5454              Parameter_Type      => New_Reference_To (RTE (RE_Address), Loc)));
5455
5456       --  Default case
5457
5458       else
5459          --  V : in out Typ
5460
5461          Formals := New_List (
5462            Make_Parameter_Specification (Loc,
5463              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5464              In_Present          => True,
5465              Out_Present         => True,
5466              Parameter_Type      => New_Reference_To (Typ, Loc)));
5467
5468          --  F : Boolean := True
5469
5470          if Prim = Adjust_Case
5471            or else Prim = Finalize_Case
5472          then
5473             Append_To (Formals,
5474               Make_Parameter_Specification (Loc,
5475                 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
5476                 Parameter_Type      =>
5477                   New_Reference_To (Standard_Boolean, Loc),
5478                 Expression          =>
5479                   New_Reference_To (Standard_True, Loc)));
5480          end if;
5481       end if;
5482
5483       Proc_Id :=
5484         Make_Defining_Identifier (Loc,
5485           Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
5486
5487       --  Generate:
5488       --    procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5489       --    begin
5490       --       <stmts>
5491       --    exception                --  Finalize and Adjust cases only
5492       --       raise Program_Error;
5493       --    end Deep_Initialize / Adjust / Finalize;
5494
5495       --       or
5496
5497       --    procedure Finalize_Address (V : System.Address) is
5498       --    begin
5499       --       <stmts>
5500       --    end Finalize_Address;
5501
5502       Discard_Node (
5503         Make_Subprogram_Body (Loc,
5504           Specification =>
5505             Make_Procedure_Specification (Loc,
5506               Defining_Unit_Name       => Proc_Id,
5507               Parameter_Specifications => Formals),
5508
5509           Declarations => Empty_List,
5510
5511           Handled_Statement_Sequence =>
5512             Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
5513
5514       return Proc_Id;
5515    end Make_Deep_Proc;
5516
5517    ---------------------------
5518    -- Make_Deep_Record_Body --
5519    ---------------------------
5520
5521    function Make_Deep_Record_Body
5522      (Prim     : Final_Primitives;
5523       Typ      : Entity_Id;
5524       Is_Local : Boolean := False) return List_Id
5525    is
5526       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
5527       --  Build the statements necessary to adjust a record type. The type may
5528       --  have discriminants and contain variant parts. Generate:
5529       --
5530       --    begin
5531       --       begin
5532       --          [Deep_]Adjust (V.Comp_1);
5533       --       exception
5534       --          when Id : others =>
5535       --             if not Raised then
5536       --                Raised := True;
5537       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5538       --             end if;
5539       --       end;
5540       --       .  .  .
5541       --       begin
5542       --          [Deep_]Adjust (V.Comp_N);
5543       --       exception
5544       --          when Id : others =>
5545       --             if not Raised then
5546       --                Raised := True;
5547       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5548       --             end if;
5549       --       end;
5550       --
5551       --       begin
5552       --          Deep_Adjust (V._parent, False);  --  If applicable
5553       --       exception
5554       --          when Id : others =>
5555       --             if not Raised then
5556       --                Raised := True;
5557       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5558       --             end if;
5559       --       end;
5560       --
5561       --       if F then
5562       --          begin
5563       --             Adjust (V);  --  If applicable
5564       --          exception
5565       --             when others =>
5566       --                if not Raised then
5567       --                   Raised := True;
5568       --                   Save_Occurence (E, Get_Current_Excep.all.all);
5569       --                end if;
5570       --          end;
5571       --       end if;
5572       --
5573       --       if Raised and then not Abort then
5574       --          Raise_From_Controlled_Operation (E);
5575       --       end if;
5576       --    end;
5577
5578       function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
5579       --  Build the statements necessary to finalize a record type. The type
5580       --  may have discriminants and contain variant parts. Generate:
5581       --
5582       --    declare
5583       --       Abort  : constant Boolean := Triggered_By_Abort;
5584       --         <or>
5585       --       Abort  : constant Boolean := False;  --  no abort
5586       --       E      : Exception_Occurence;
5587       --       Raised : Boolean := False;
5588       --
5589       --    begin
5590       --       if F then
5591       --          begin
5592       --             Finalize (V);  --  If applicable
5593       --          exception
5594       --             when others =>
5595       --                if not Raised then
5596       --                   Raised := True;
5597       --                   Save_Occurence (E, Get_Current_Excep.all.all);
5598       --                end if;
5599       --          end;
5600       --       end if;
5601       --
5602       --       case Variant_1 is
5603       --          when Value_1 =>
5604       --             case State_Counter_N =>  --  If Is_Local is enabled
5605       --                when N =>                 .
5606       --                   goto LN;               .
5607       --                ...                       .
5608       --                when 1 =>                 .
5609       --                   goto L1;               .
5610       --                when others =>            .
5611       --                   goto L0;               .
5612       --             end case;                    .
5613       --
5614       --             <<LN>>                   --  If Is_Local is enabled
5615       --             begin
5616       --                [Deep_]Finalize (V.Comp_N);
5617       --             exception
5618       --                when others =>
5619       --                   if not Raised then
5620       --                      Raised := True;
5621       --                      Save_Occurence (E, Get_Current_Excep.all.all);
5622       --                   end if;
5623       --             end;
5624       --             .  .  .
5625       --             <<L1>>
5626       --             begin
5627       --                [Deep_]Finalize (V.Comp_1);
5628       --             exception
5629       --                when others =>
5630       --                   if not Raised then
5631       --                      Raised := True;
5632       --                      Save_Occurence (E, Get_Current_Excep.all.all);
5633       --                   end if;
5634       --             end;
5635       --             <<L0>>
5636       --       end case;
5637       --
5638       --       case State_Counter_1 =>  --  If Is_Local is enabled
5639       --          when M =>                 .
5640       --             goto LM;               .
5641       --       ...
5642       --
5643       --       begin
5644       --          Deep_Finalize (V._parent, False);  --  If applicable
5645       --       exception
5646       --          when Id : others =>
5647       --             if not Raised then
5648       --                Raised := True;
5649       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5650       --             end if;
5651       --       end;
5652       --
5653       --       if Raised and then not Abort then
5654       --          Raise_From_Controlled_Operation (E);
5655       --       end if;
5656       --    end;
5657
5658       function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
5659       --  Given a derived tagged type Typ, traverse all components, find field
5660       --  _parent and return its type.
5661
5662       procedure Preprocess_Components
5663         (Comps     : Node_Id;
5664          Num_Comps : out Int;
5665          Has_POC   : out Boolean);
5666       --  Examine all components in component list Comps, count all controlled
5667       --  components and determine whether at least one of them is per-object
5668       --  constrained. Component _parent is always skipped.
5669
5670       -----------------------------
5671       -- Build_Adjust_Statements --
5672       -----------------------------
5673
5674       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
5675          Loc             : constant Source_Ptr := Sloc (Typ);
5676          Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
5677          Bod_Stmts       : List_Id;
5678          Finalizer_Data  : Finalization_Exception_Data;
5679          Finalizer_Decls : List_Id := No_List;
5680          Rec_Def         : Node_Id;
5681          Var_Case        : Node_Id;
5682
5683          Exceptions_OK : constant Boolean :=
5684                            not Restriction_Active (No_Exception_Propagation);
5685
5686          function Process_Component_List_For_Adjust
5687            (Comps : Node_Id) return List_Id;
5688          --  Build all necessary adjust statements for a single component list
5689
5690          ---------------------------------------
5691          -- Process_Component_List_For_Adjust --
5692          ---------------------------------------
5693
5694          function Process_Component_List_For_Adjust
5695            (Comps : Node_Id) return List_Id
5696          is
5697             Stmts     : constant List_Id := New_List;
5698             Decl      : Node_Id;
5699             Decl_Id   : Entity_Id;
5700             Decl_Typ  : Entity_Id;
5701             Has_POC   : Boolean;
5702             Num_Comps : Int;
5703
5704             procedure Process_Component_For_Adjust (Decl : Node_Id);
5705             --  Process the declaration of a single controlled component
5706
5707             ----------------------------------
5708             -- Process_Component_For_Adjust --
5709             ----------------------------------
5710
5711             procedure Process_Component_For_Adjust (Decl : Node_Id) is
5712                Id       : constant Entity_Id := Defining_Identifier (Decl);
5713                Typ      : constant Entity_Id := Etype (Id);
5714                Adj_Stmt : Node_Id;
5715
5716             begin
5717                --  Generate:
5718                --    [Deep_]Adjust (V.Id);  --  No_Exception_Propagation
5719
5720                --    begin                  --  Exception handlers allowed
5721                --       [Deep_]Adjust (V.Id);
5722                --    exception
5723                --       when others =>
5724                --          if not Raised then
5725                --             Raised := True;
5726                --             Save_Occurrence (E, Get_Current_Excep.all.all);
5727                --          end if;
5728                --    end;
5729
5730                Adj_Stmt :=
5731                  Make_Adjust_Call (
5732                    Obj_Ref =>
5733                      Make_Selected_Component (Loc,
5734                        Prefix        => Make_Identifier (Loc, Name_V),
5735                        Selector_Name => Make_Identifier (Loc, Chars (Id))),
5736                    Typ     => Typ);
5737
5738                if Exceptions_OK then
5739                   Adj_Stmt :=
5740                     Make_Block_Statement (Loc,
5741                       Handled_Statement_Sequence =>
5742                         Make_Handled_Sequence_Of_Statements (Loc,
5743                           Statements         => New_List (Adj_Stmt),
5744                           Exception_Handlers => New_List (
5745                             Build_Exception_Handler (Finalizer_Data))));
5746                end if;
5747
5748                Append_To (Stmts, Adj_Stmt);
5749             end Process_Component_For_Adjust;
5750
5751          --  Start of processing for Process_Component_List_For_Adjust
5752
5753          begin
5754             --  Perform an initial check, determine the number of controlled
5755             --  components in the current list and whether at least one of them
5756             --  is per-object constrained.
5757
5758             Preprocess_Components (Comps, Num_Comps, Has_POC);
5759
5760             --  The processing in this routine is done in the following order:
5761             --    1) Regular components
5762             --    2) Per-object constrained components
5763             --    3) Variant parts
5764
5765             if Num_Comps > 0 then
5766
5767                --  Process all regular components in order of declarations
5768
5769                Decl := First_Non_Pragma (Component_Items (Comps));
5770                while Present (Decl) loop
5771                   Decl_Id  := Defining_Identifier (Decl);
5772                   Decl_Typ := Etype (Decl_Id);
5773
5774                   --  Skip _parent as well as per-object constrained components
5775
5776                   if Chars (Decl_Id) /= Name_uParent
5777                     and then Needs_Finalization (Decl_Typ)
5778                   then
5779                      if Has_Access_Constraint (Decl_Id)
5780                        and then No (Expression (Decl))
5781                      then
5782                         null;
5783                      else
5784                         Process_Component_For_Adjust (Decl);
5785                      end if;
5786                   end if;
5787
5788                   Next_Non_Pragma (Decl);
5789                end loop;
5790
5791                --  Process all per-object constrained components in order of
5792                --  declarations.
5793
5794                if Has_POC then
5795                   Decl := First_Non_Pragma (Component_Items (Comps));
5796                   while Present (Decl) loop
5797                      Decl_Id  := Defining_Identifier (Decl);
5798                      Decl_Typ := Etype (Decl_Id);
5799
5800                      --  Skip _parent
5801
5802                      if Chars (Decl_Id) /= Name_uParent
5803                        and then Needs_Finalization (Decl_Typ)
5804                        and then Has_Access_Constraint (Decl_Id)
5805                        and then No (Expression (Decl))
5806                      then
5807                         Process_Component_For_Adjust (Decl);
5808                      end if;
5809
5810                      Next_Non_Pragma (Decl);
5811                   end loop;
5812                end if;
5813             end if;
5814
5815             --  Process all variants, if any
5816
5817             Var_Case := Empty;
5818             if Present (Variant_Part (Comps)) then
5819                declare
5820                   Var_Alts : constant List_Id := New_List;
5821                   Var      : Node_Id;
5822
5823                begin
5824                   Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
5825                   while Present (Var) loop
5826
5827                      --  Generate:
5828                      --     when <discrete choices> =>
5829                      --        <adjust statements>
5830
5831                      Append_To (Var_Alts,
5832                        Make_Case_Statement_Alternative (Loc,
5833                          Discrete_Choices =>
5834                            New_Copy_List (Discrete_Choices (Var)),
5835                          Statements       =>
5836                            Process_Component_List_For_Adjust (
5837                              Component_List (Var))));
5838
5839                      Next_Non_Pragma (Var);
5840                   end loop;
5841
5842                   --  Generate:
5843                   --     case V.<discriminant> is
5844                   --        when <discrete choices 1> =>
5845                   --           <adjust statements 1>
5846                   --        ...
5847                   --        when <discrete choices N> =>
5848                   --           <adjust statements N>
5849                   --     end case;
5850
5851                   Var_Case :=
5852                     Make_Case_Statement (Loc,
5853                       Expression =>
5854                         Make_Selected_Component (Loc,
5855                           Prefix        => Make_Identifier (Loc, Name_V),
5856                           Selector_Name =>
5857                             Make_Identifier (Loc,
5858                               Chars => Chars (Name (Variant_Part (Comps))))),
5859                       Alternatives => Var_Alts);
5860                end;
5861             end if;
5862
5863             --  Add the variant case statement to the list of statements
5864
5865             if Present (Var_Case) then
5866                Append_To (Stmts, Var_Case);
5867             end if;
5868
5869             --  If the component list did not have any controlled components
5870             --  nor variants, return null.
5871
5872             if Is_Empty_List (Stmts) then
5873                Append_To (Stmts, Make_Null_Statement (Loc));
5874             end if;
5875
5876             return Stmts;
5877          end Process_Component_List_For_Adjust;
5878
5879       --  Start of processing for Build_Adjust_Statements
5880
5881       begin
5882          Finalizer_Decls := New_List;
5883          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5884
5885          if Nkind (Typ_Def) = N_Derived_Type_Definition then
5886             Rec_Def := Record_Extension_Part (Typ_Def);
5887          else
5888             Rec_Def := Typ_Def;
5889          end if;
5890
5891          --  Create an adjust sequence for all record components
5892
5893          if Present (Component_List (Rec_Def)) then
5894             Bod_Stmts :=
5895               Process_Component_List_For_Adjust (Component_List (Rec_Def));
5896          end if;
5897
5898          --  A derived record type must adjust all inherited components. This
5899          --  action poses the following problem:
5900
5901          --    procedure Deep_Adjust (Obj : in out Parent_Typ) is
5902          --    begin
5903          --       Adjust (Obj);
5904          --       ...
5905
5906          --    procedure Deep_Adjust (Obj : in out Derived_Typ) is
5907          --    begin
5908          --       Deep_Adjust (Obj._parent);
5909          --       ...
5910          --       Adjust (Obj);
5911          --       ...
5912
5913          --  Adjusting the derived type will invoke Adjust of the parent and
5914          --  then that of the derived type. This is undesirable because both
5915          --  routines may modify shared components. Only the Adjust of the
5916          --  derived type should be invoked.
5917
5918          --  To prevent this double adjustment of shared components,
5919          --  Deep_Adjust uses a flag to control the invocation of Adjust:
5920
5921          --    procedure Deep_Adjust
5922          --      (Obj  : in out Some_Type;
5923          --       Flag : Boolean := True)
5924          --    is
5925          --    begin
5926          --       if Flag then
5927          --          Adjust (Obj);
5928          --       end if;
5929          --       ...
5930
5931          --  When Deep_Adjust is invokes for field _parent, a value of False is
5932          --  provided for the flag:
5933
5934          --    Deep_Adjust (Obj._parent, False);
5935
5936          if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
5937             declare
5938                Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
5939                Adj_Stmt : Node_Id;
5940                Call     : Node_Id;
5941
5942             begin
5943                if Needs_Finalization (Par_Typ) then
5944                   Call :=
5945                     Make_Adjust_Call
5946                       (Obj_Ref    =>
5947                          Make_Selected_Component (Loc,
5948                            Prefix        => Make_Identifier (Loc, Name_V),
5949                            Selector_Name =>
5950                              Make_Identifier (Loc, Name_uParent)),
5951                        Typ        => Par_Typ,
5952                        For_Parent => True);
5953
5954                   --  Generate:
5955                   --    Deep_Adjust (V._parent, False);  --  No_Except_Propagat
5956
5957                   --    begin                            --  Exceptions OK
5958                   --       Deep_Adjust (V._parent, False);
5959                   --    exception
5960                   --       when Id : others =>
5961                   --          if not Raised then
5962                   --             Raised := True;
5963                   --             Save_Occurrence (E,
5964                   --               Get_Current_Excep.all.all);
5965                   --          end if;
5966                   --    end;
5967
5968                   if Present (Call) then
5969                      Adj_Stmt := Call;
5970
5971                      if Exceptions_OK then
5972                         Adj_Stmt :=
5973                           Make_Block_Statement (Loc,
5974                             Handled_Statement_Sequence =>
5975                               Make_Handled_Sequence_Of_Statements (Loc,
5976                                 Statements         => New_List (Adj_Stmt),
5977                                 Exception_Handlers => New_List (
5978                                   Build_Exception_Handler (Finalizer_Data))));
5979                      end if;
5980
5981                      Prepend_To (Bod_Stmts, Adj_Stmt);
5982                   end if;
5983                end if;
5984             end;
5985          end if;
5986
5987          --  Adjust the object. This action must be performed last after all
5988          --  components have been adjusted.
5989
5990          if Is_Controlled (Typ) then
5991             declare
5992                Adj_Stmt : Node_Id;
5993                Proc     : Entity_Id;
5994
5995             begin
5996                Proc := Find_Prim_Op (Typ, Name_Adjust);
5997
5998                --  Generate:
5999                --    if F then
6000                --       Adjust (V);  --  No_Exception_Propagation
6001
6002                --       begin        --  Exception handlers allowed
6003                --          Adjust (V);
6004                --       exception
6005                --          when others =>
6006                --             if not Raised then
6007                --                Raised := True;
6008                --                Save_Occurrence (E,
6009                --                  Get_Current_Excep.all.all);
6010                --             end if;
6011                --       end;
6012                --    end if;
6013
6014                if Present (Proc) then
6015                   Adj_Stmt :=
6016                     Make_Procedure_Call_Statement (Loc,
6017                       Name                   => New_Reference_To (Proc, Loc),
6018                       Parameter_Associations => New_List (
6019                         Make_Identifier (Loc, Name_V)));
6020
6021                   if Exceptions_OK then
6022                      Adj_Stmt :=
6023                        Make_Block_Statement (Loc,
6024                          Handled_Statement_Sequence =>
6025                            Make_Handled_Sequence_Of_Statements (Loc,
6026                              Statements         => New_List (Adj_Stmt),
6027                              Exception_Handlers => New_List (
6028                                Build_Exception_Handler
6029                                  (Finalizer_Data))));
6030                   end if;
6031
6032                   Append_To (Bod_Stmts,
6033                     Make_If_Statement (Loc,
6034                       Condition       => Make_Identifier (Loc, Name_F),
6035                       Then_Statements => New_List (Adj_Stmt)));
6036                end if;
6037             end;
6038          end if;
6039
6040          --  At this point either all adjustment statements have been generated
6041          --  or the type is not controlled.
6042
6043          if Is_Empty_List (Bod_Stmts) then
6044             Append_To (Bod_Stmts, Make_Null_Statement (Loc));
6045
6046             return Bod_Stmts;
6047
6048          --  Generate:
6049          --    declare
6050          --       Abort  : constant Boolean := Triggered_By_Abort;
6051          --         <or>
6052          --       Abort  : constant Boolean := False;  --  no abort
6053
6054          --       E      : Exception_Occurence;
6055          --       Raised : Boolean := False;
6056
6057          --    begin
6058          --       <adjust statements>
6059
6060          --       if Raised and then not Abort then
6061          --          Raise_From_Controlled_Operation (E);
6062          --       end if;
6063          --    end;
6064
6065          else
6066             if Exceptions_OK then
6067                Append_To (Bod_Stmts,
6068                  Build_Raise_Statement (Finalizer_Data));
6069             end if;
6070
6071             return
6072               New_List (
6073                 Make_Block_Statement (Loc,
6074                   Declarations               =>
6075                     Finalizer_Decls,
6076                   Handled_Statement_Sequence =>
6077                     Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6078          end if;
6079       end Build_Adjust_Statements;
6080
6081       -------------------------------
6082       -- Build_Finalize_Statements --
6083       -------------------------------
6084
6085       function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
6086          Loc             : constant Source_Ptr := Sloc (Typ);
6087          Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
6088          Bod_Stmts       : List_Id;
6089          Counter         : Int := 0;
6090          Finalizer_Data  : Finalization_Exception_Data;
6091          Finalizer_Decls : List_Id := No_List;
6092          Rec_Def         : Node_Id;
6093          Var_Case        : Node_Id;
6094
6095          Exceptions_OK : constant Boolean :=
6096                            not Restriction_Active (No_Exception_Propagation);
6097
6098          function Process_Component_List_For_Finalize
6099            (Comps : Node_Id) return List_Id;
6100          --  Build all necessary finalization statements for a single component
6101          --  list. The statements may include a jump circuitry if flag Is_Local
6102          --  is enabled.
6103
6104          -----------------------------------------
6105          -- Process_Component_List_For_Finalize --
6106          -----------------------------------------
6107
6108          function Process_Component_List_For_Finalize
6109            (Comps : Node_Id) return List_Id
6110          is
6111             Alts       : List_Id;
6112             Counter_Id : Entity_Id;
6113             Decl       : Node_Id;
6114             Decl_Id    : Entity_Id;
6115             Decl_Typ   : Entity_Id;
6116             Decls      : List_Id;
6117             Has_POC    : Boolean;
6118             Jump_Block : Node_Id;
6119             Label      : Node_Id;
6120             Label_Id   : Entity_Id;
6121             Num_Comps  : Int;
6122             Stmts      : List_Id;
6123
6124             procedure Process_Component_For_Finalize
6125               (Decl  : Node_Id;
6126                Alts  : List_Id;
6127                Decls : List_Id;
6128                Stmts : List_Id);
6129             --  Process the declaration of a single controlled component. If
6130             --  flag Is_Local is enabled, create the corresponding label and
6131             --  jump circuitry. Alts is the list of case alternatives, Decls
6132             --  is the top level declaration list where labels are declared
6133             --  and Stmts is the list of finalization actions.
6134
6135             ------------------------------------
6136             -- Process_Component_For_Finalize --
6137             ------------------------------------
6138
6139             procedure Process_Component_For_Finalize
6140               (Decl  : Node_Id;
6141                Alts  : List_Id;
6142                Decls : List_Id;
6143                Stmts : List_Id)
6144             is
6145                Id       : constant Entity_Id := Defining_Identifier (Decl);
6146                Typ      : constant Entity_Id := Etype (Id);
6147                Fin_Stmt : Node_Id;
6148
6149             begin
6150                if Is_Local then
6151                   declare
6152                      Label    : Node_Id;
6153                      Label_Id : Entity_Id;
6154
6155                   begin
6156                      --  Generate:
6157                      --    LN : label;
6158
6159                      Label_Id :=
6160                        Make_Identifier (Loc,
6161                          Chars => New_External_Name ('L', Num_Comps));
6162                      Set_Entity (Label_Id,
6163                        Make_Defining_Identifier (Loc, Chars (Label_Id)));
6164                      Label := Make_Label (Loc, Label_Id);
6165
6166                      Append_To (Decls,
6167                        Make_Implicit_Label_Declaration (Loc,
6168                          Defining_Identifier => Entity (Label_Id),
6169                          Label_Construct     => Label));
6170
6171                      --  Generate:
6172                      --    when N =>
6173                      --      goto LN;
6174
6175                      Append_To (Alts,
6176                        Make_Case_Statement_Alternative (Loc,
6177                          Discrete_Choices => New_List (
6178                            Make_Integer_Literal (Loc, Num_Comps)),
6179
6180                          Statements => New_List (
6181                            Make_Goto_Statement (Loc,
6182                              Name =>
6183                                New_Reference_To (Entity (Label_Id), Loc)))));
6184
6185                      --  Generate:
6186                      --    <<LN>>
6187
6188                      Append_To (Stmts, Label);
6189
6190                      --  Decrease the number of components to be processed.
6191                      --  This action yields a new Label_Id in future calls.
6192
6193                      Num_Comps := Num_Comps - 1;
6194                   end;
6195                end if;
6196
6197                --  Generate:
6198                --    [Deep_]Finalize (V.Id);  --  No_Exception_Propagation
6199
6200                --    begin                    --  Exception handlers allowed
6201                --       [Deep_]Finalize (V.Id);
6202                --    exception
6203                --       when others =>
6204                --          if not Raised then
6205                --             Raised := True;
6206                --             Save_Occurrence (E,
6207                --               Get_Current_Excep.all.all);
6208                --          end if;
6209                --    end;
6210
6211                Fin_Stmt :=
6212                  Make_Final_Call
6213                    (Obj_Ref =>
6214                       Make_Selected_Component (Loc,
6215                         Prefix        => Make_Identifier (Loc, Name_V),
6216                         Selector_Name => Make_Identifier (Loc, Chars (Id))),
6217                     Typ     => Typ);
6218
6219                if not Restriction_Active (No_Exception_Propagation) then
6220                   Fin_Stmt :=
6221                     Make_Block_Statement (Loc,
6222                       Handled_Statement_Sequence =>
6223                         Make_Handled_Sequence_Of_Statements (Loc,
6224                           Statements         => New_List (Fin_Stmt),
6225                           Exception_Handlers => New_List (
6226                             Build_Exception_Handler (Finalizer_Data))));
6227                end if;
6228
6229                Append_To (Stmts, Fin_Stmt);
6230             end Process_Component_For_Finalize;
6231
6232          --  Start of processing for Process_Component_List_For_Finalize
6233
6234          begin
6235             --  Perform an initial check, look for controlled and per-object
6236             --  constrained components.
6237
6238             Preprocess_Components (Comps, Num_Comps, Has_POC);
6239
6240             --  Create a state counter to service the current component list.
6241             --  This step is performed before the variants are inspected in
6242             --  order to generate the same state counter names as those from
6243             --  Build_Initialize_Statements.
6244
6245             if Num_Comps > 0
6246               and then Is_Local
6247             then
6248                Counter := Counter + 1;
6249
6250                Counter_Id :=
6251                  Make_Defining_Identifier (Loc,
6252                    Chars => New_External_Name ('C', Counter));
6253             end if;
6254
6255             --  Process the component in the following order:
6256             --    1) Variants
6257             --    2) Per-object constrained components
6258             --    3) Regular components
6259
6260             --  Start with the variant parts
6261
6262             Var_Case := Empty;
6263             if Present (Variant_Part (Comps)) then
6264                declare
6265                   Var_Alts : constant List_Id := New_List;
6266                   Var      : Node_Id;
6267
6268                begin
6269                   Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6270                   while Present (Var) loop
6271
6272                      --  Generate:
6273                      --     when <discrete choices> =>
6274                      --        <finalize statements>
6275
6276                      Append_To (Var_Alts,
6277                        Make_Case_Statement_Alternative (Loc,
6278                          Discrete_Choices =>
6279                            New_Copy_List (Discrete_Choices (Var)),
6280                          Statements =>
6281                            Process_Component_List_For_Finalize (
6282                              Component_List (Var))));
6283
6284                      Next_Non_Pragma (Var);
6285                   end loop;
6286
6287                   --  Generate:
6288                   --     case V.<discriminant> is
6289                   --        when <discrete choices 1> =>
6290                   --           <finalize statements 1>
6291                   --        ...
6292                   --        when <discrete choices N> =>
6293                   --           <finalize statements N>
6294                   --     end case;
6295
6296                   Var_Case :=
6297                     Make_Case_Statement (Loc,
6298                       Expression =>
6299                         Make_Selected_Component (Loc,
6300                           Prefix        => Make_Identifier (Loc, Name_V),
6301                           Selector_Name =>
6302                             Make_Identifier (Loc,
6303                               Chars => Chars (Name (Variant_Part (Comps))))),
6304                       Alternatives => Var_Alts);
6305                end;
6306             end if;
6307
6308             --  The current component list does not have a single controlled
6309             --  component, however it may contain variants. Return the case
6310             --  statement for the variants or nothing.
6311
6312             if Num_Comps = 0 then
6313                if Present (Var_Case) then
6314                   return New_List (Var_Case);
6315                else
6316                   return New_List (Make_Null_Statement (Loc));
6317                end if;
6318             end if;
6319
6320             --  Prepare all lists
6321
6322             Alts  := New_List;
6323             Decls := New_List;
6324             Stmts := New_List;
6325
6326             --  Process all per-object constrained components in reverse order
6327
6328             if Has_POC then
6329                Decl := Last_Non_Pragma (Component_Items (Comps));
6330                while Present (Decl) loop
6331                   Decl_Id  := Defining_Identifier (Decl);
6332                   Decl_Typ := Etype (Decl_Id);
6333
6334                   --  Skip _parent
6335
6336                   if Chars (Decl_Id) /= Name_uParent
6337                     and then Needs_Finalization (Decl_Typ)
6338                     and then Has_Access_Constraint (Decl_Id)
6339                     and then No (Expression (Decl))
6340                   then
6341                      Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6342                   end if;
6343
6344                   Prev_Non_Pragma (Decl);
6345                end loop;
6346             end if;
6347
6348             --  Process the rest of the components in reverse order
6349
6350             Decl := Last_Non_Pragma (Component_Items (Comps));
6351             while Present (Decl) loop
6352                Decl_Id  := Defining_Identifier (Decl);
6353                Decl_Typ := Etype (Decl_Id);
6354
6355                --  Skip _parent
6356
6357                if Chars (Decl_Id) /= Name_uParent
6358                  and then Needs_Finalization (Decl_Typ)
6359                then
6360                   --  Skip per-object constrained components since they were
6361                   --  handled in the above step.
6362
6363                   if Has_Access_Constraint (Decl_Id)
6364                     and then No (Expression (Decl))
6365                   then
6366                      null;
6367                   else
6368                      Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6369                   end if;
6370                end if;
6371
6372                Prev_Non_Pragma (Decl);
6373             end loop;
6374
6375             --  Generate:
6376             --    declare
6377             --       LN : label;        --  If Is_Local is enabled
6378             --       ...                    .
6379             --       L0 : label;            .
6380
6381             --    begin                     .
6382             --       case CounterX is       .
6383             --          when N =>           .
6384             --             goto LN;         .
6385             --          ...                 .
6386             --          when 1 =>           .
6387             --             goto L1;         .
6388             --          when others =>      .
6389             --             goto L0;         .
6390             --       end case;              .
6391
6392             --       <<LN>>             --  If Is_Local is enabled
6393             --          begin
6394             --             [Deep_]Finalize (V.CompY);
6395             --          exception
6396             --             when Id : others =>
6397             --                if not Raised then
6398             --                   Raised := True;
6399             --                   Save_Occurrence (E,
6400             --                     Get_Current_Excep.all.all);
6401             --                end if;
6402             --          end;
6403             --       ...
6404             --       <<L0>>  --  If Is_Local is enabled
6405             --    end;
6406
6407             if Is_Local then
6408
6409                --  Add the declaration of default jump location L0, its
6410                --  corresponding alternative and its place in the statements.
6411
6412                Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
6413                Set_Entity (Label_Id,
6414                  Make_Defining_Identifier (Loc, Chars (Label_Id)));
6415                Label := Make_Label (Loc, Label_Id);
6416
6417                Append_To (Decls,          --  declaration
6418                  Make_Implicit_Label_Declaration (Loc,
6419                    Defining_Identifier => Entity (Label_Id),
6420                    Label_Construct     => Label));
6421
6422                Append_To (Alts,           --  alternative
6423                  Make_Case_Statement_Alternative (Loc,
6424                    Discrete_Choices => New_List (
6425                      Make_Others_Choice (Loc)),
6426
6427                    Statements => New_List (
6428                      Make_Goto_Statement (Loc,
6429                        Name => New_Reference_To (Entity (Label_Id), Loc)))));
6430
6431                Append_To (Stmts, Label);  --  statement
6432
6433                --  Create the jump block
6434
6435                Prepend_To (Stmts,
6436                  Make_Case_Statement (Loc,
6437                    Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
6438                    Alternatives => Alts));
6439             end if;
6440
6441             Jump_Block :=
6442               Make_Block_Statement (Loc,
6443                 Declarations               => Decls,
6444                 Handled_Statement_Sequence =>
6445                   Make_Handled_Sequence_Of_Statements (Loc, Stmts));
6446
6447             if Present (Var_Case) then
6448                return New_List (Var_Case, Jump_Block);
6449             else
6450                return New_List (Jump_Block);
6451             end if;
6452          end Process_Component_List_For_Finalize;
6453
6454       --  Start of processing for Build_Finalize_Statements
6455
6456       begin
6457          Finalizer_Decls := New_List;
6458          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6459
6460          if Nkind (Typ_Def) = N_Derived_Type_Definition then
6461             Rec_Def := Record_Extension_Part (Typ_Def);
6462          else
6463             Rec_Def := Typ_Def;
6464          end if;
6465
6466          --  Create a finalization sequence for all record components
6467
6468          if Present (Component_List (Rec_Def)) then
6469             Bod_Stmts :=
6470               Process_Component_List_For_Finalize (Component_List (Rec_Def));
6471          end if;
6472
6473          --  A derived record type must finalize all inherited components. This
6474          --  action poses the following problem:
6475
6476          --    procedure Deep_Finalize (Obj : in out Parent_Typ) is
6477          --    begin
6478          --       Finalize (Obj);
6479          --       ...
6480
6481          --    procedure Deep_Finalize (Obj : in out Derived_Typ) is
6482          --    begin
6483          --       Deep_Finalize (Obj._parent);
6484          --       ...
6485          --       Finalize (Obj);
6486          --       ...
6487
6488          --  Finalizing the derived type will invoke Finalize of the parent and
6489          --  then that of the derived type. This is undesirable because both
6490          --  routines may modify shared components. Only the Finalize of the
6491          --  derived type should be invoked.
6492
6493          --  To prevent this double adjustment of shared components,
6494          --  Deep_Finalize uses a flag to control the invocation of Finalize:
6495
6496          --    procedure Deep_Finalize
6497          --      (Obj  : in out Some_Type;
6498          --       Flag : Boolean := True)
6499          --    is
6500          --    begin
6501          --       if Flag then
6502          --          Finalize (Obj);
6503          --       end if;
6504          --       ...
6505
6506          --  When Deep_Finalize is invokes for field _parent, a value of False
6507          --  is provided for the flag:
6508
6509          --    Deep_Finalize (Obj._parent, False);
6510
6511          if Is_Tagged_Type (Typ)
6512            and then Is_Derived_Type (Typ)
6513          then
6514             declare
6515                Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
6516                Call     : Node_Id;
6517                Fin_Stmt : Node_Id;
6518
6519             begin
6520                if Needs_Finalization (Par_Typ) then
6521                   Call :=
6522                     Make_Final_Call
6523                       (Obj_Ref    =>
6524                          Make_Selected_Component (Loc,
6525                            Prefix        => Make_Identifier (Loc, Name_V),
6526                            Selector_Name =>
6527                              Make_Identifier (Loc, Name_uParent)),
6528                        Typ        => Par_Typ,
6529                        For_Parent => True);
6530
6531                   --  Generate:
6532                   --    Deep_Finalize (V._parent, False);  --  No_Except_Propag
6533
6534                   --    begin                              --  Exceptions OK
6535                   --       Deep_Finalize (V._parent, False);
6536                   --    exception
6537                   --       when Id : others =>
6538                   --          if not Raised then
6539                   --             Raised := True;
6540                   --             Save_Occurrence (E,
6541                   --               Get_Current_Excep.all.all);
6542                   --          end if;
6543                   --    end;
6544
6545                   if Present (Call) then
6546                      Fin_Stmt := Call;
6547
6548                      if Exceptions_OK then
6549                         Fin_Stmt :=
6550                           Make_Block_Statement (Loc,
6551                             Handled_Statement_Sequence =>
6552                               Make_Handled_Sequence_Of_Statements (Loc,
6553                                 Statements         => New_List (Fin_Stmt),
6554                                 Exception_Handlers => New_List (
6555                                   Build_Exception_Handler
6556                                     (Finalizer_Data))));
6557                      end if;
6558
6559                      Append_To (Bod_Stmts, Fin_Stmt);
6560                   end if;
6561                end if;
6562             end;
6563          end if;
6564
6565          --  Finalize the object. This action must be performed first before
6566          --  all components have been finalized.
6567
6568          if Is_Controlled (Typ)
6569            and then not Is_Local
6570          then
6571             declare
6572                Fin_Stmt : Node_Id;
6573                Proc     : Entity_Id;
6574
6575             begin
6576                Proc := Find_Prim_Op (Typ, Name_Finalize);
6577
6578                --  Generate:
6579                --    if F then
6580                --       Finalize (V);  --  No_Exception_Propagation
6581
6582                --       begin
6583                --          Finalize (V);
6584                --       exception
6585                --          when others =>
6586                --             if not Raised then
6587                --                Raised := True;
6588                --                Save_Occurrence (E,
6589                --                  Get_Current_Excep.all.all);
6590                --             end if;
6591                --       end;
6592                --    end if;
6593
6594                if Present (Proc) then
6595                   Fin_Stmt :=
6596                     Make_Procedure_Call_Statement (Loc,
6597                       Name                   => New_Reference_To (Proc, Loc),
6598                       Parameter_Associations => New_List (
6599                         Make_Identifier (Loc, Name_V)));
6600
6601                   if Exceptions_OK then
6602                      Fin_Stmt :=
6603                        Make_Block_Statement (Loc,
6604                          Handled_Statement_Sequence =>
6605                            Make_Handled_Sequence_Of_Statements (Loc,
6606                              Statements         => New_List (Fin_Stmt),
6607                              Exception_Handlers => New_List (
6608                                Build_Exception_Handler
6609                                  (Finalizer_Data))));
6610                   end if;
6611
6612                   Prepend_To (Bod_Stmts,
6613                     Make_If_Statement (Loc,
6614                       Condition       => Make_Identifier (Loc, Name_F),
6615                       Then_Statements => New_List (Fin_Stmt)));
6616                end if;
6617             end;
6618          end if;
6619
6620          --  At this point either all finalization statements have been
6621          --  generated or the type is not controlled.
6622
6623          if No (Bod_Stmts) then
6624             return New_List (Make_Null_Statement (Loc));
6625
6626          --  Generate:
6627          --    declare
6628          --       Abort  : constant Boolean := Triggered_By_Abort;
6629          --         <or>
6630          --       Abort  : constant Boolean := False;  --  no abort
6631
6632          --       E      : Exception_Occurence;
6633          --       Raised : Boolean := False;
6634
6635          --    begin
6636          --       <finalize statements>
6637
6638          --       if Raised and then not Abort then
6639          --          Raise_From_Controlled_Operation (E);
6640          --       end if;
6641          --    end;
6642
6643          else
6644             if Exceptions_OK then
6645                Append_To (Bod_Stmts,
6646                  Build_Raise_Statement (Finalizer_Data));
6647             end if;
6648
6649             return
6650               New_List (
6651                 Make_Block_Statement (Loc,
6652                   Declarations               =>
6653                     Finalizer_Decls,
6654                   Handled_Statement_Sequence =>
6655                     Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6656          end if;
6657       end Build_Finalize_Statements;
6658
6659       -----------------------
6660       -- Parent_Field_Type --
6661       -----------------------
6662
6663       function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
6664          Field : Entity_Id;
6665
6666       begin
6667          Field := First_Entity (Typ);
6668          while Present (Field) loop
6669             if Chars (Field) = Name_uParent then
6670                return Etype (Field);
6671             end if;
6672
6673             Next_Entity (Field);
6674          end loop;
6675
6676          --  A derived tagged type should always have a parent field
6677
6678          raise Program_Error;
6679       end Parent_Field_Type;
6680
6681       ---------------------------
6682       -- Preprocess_Components --
6683       ---------------------------
6684
6685       procedure Preprocess_Components
6686         (Comps     : Node_Id;
6687          Num_Comps : out Int;
6688          Has_POC   : out Boolean)
6689       is
6690          Decl : Node_Id;
6691          Id   : Entity_Id;
6692          Typ  : Entity_Id;
6693
6694       begin
6695          Num_Comps := 0;
6696          Has_POC   := False;
6697
6698          Decl := First_Non_Pragma (Component_Items (Comps));
6699          while Present (Decl) loop
6700             Id  := Defining_Identifier (Decl);
6701             Typ := Etype (Id);
6702
6703             --  Skip field _parent
6704
6705             if Chars (Id) /= Name_uParent
6706               and then Needs_Finalization (Typ)
6707             then
6708                Num_Comps := Num_Comps + 1;
6709
6710                if Has_Access_Constraint (Id)
6711                  and then No (Expression (Decl))
6712                then
6713                   Has_POC := True;
6714                end if;
6715             end if;
6716
6717             Next_Non_Pragma (Decl);
6718          end loop;
6719       end Preprocess_Components;
6720
6721    --  Start of processing for Make_Deep_Record_Body
6722
6723    begin
6724       case Prim is
6725          when Address_Case =>
6726             return Make_Finalize_Address_Stmts (Typ);
6727
6728          when Adjust_Case =>
6729             return Build_Adjust_Statements (Typ);
6730
6731          when Finalize_Case =>
6732             return Build_Finalize_Statements (Typ);
6733
6734          when Initialize_Case =>
6735             declare
6736                Loc : constant Source_Ptr := Sloc (Typ);
6737
6738             begin
6739                if Is_Controlled (Typ) then
6740                   return New_List (
6741                     Make_Procedure_Call_Statement (Loc,
6742                       Name                   =>
6743                         New_Reference_To
6744                           (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
6745                       Parameter_Associations => New_List (
6746                         Make_Identifier (Loc, Name_V))));
6747                else
6748                   return Empty_List;
6749                end if;
6750             end;
6751       end case;
6752    end Make_Deep_Record_Body;
6753
6754    ----------------------
6755    -- Make_Final_Call --
6756    ----------------------
6757
6758    function Make_Final_Call
6759      (Obj_Ref    : Node_Id;
6760       Typ        : Entity_Id;
6761       For_Parent : Boolean := False) return Node_Id
6762    is
6763       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
6764       Atyp   : Entity_Id;
6765       Fin_Id : Entity_Id := Empty;
6766       Ref    : Node_Id;
6767       Utyp   : Entity_Id;
6768
6769    begin
6770       --  Recover the proper type which contains [Deep_]Finalize
6771
6772       if Is_Class_Wide_Type (Typ) then
6773          Utyp := Root_Type (Typ);
6774          Atyp := Utyp;
6775          Ref  := Obj_Ref;
6776
6777       elsif Is_Concurrent_Type (Typ) then
6778          Utyp := Corresponding_Record_Type (Typ);
6779          Atyp := Empty;
6780          Ref  := Convert_Concurrent (Obj_Ref, Typ);
6781
6782       elsif Is_Private_Type (Typ)
6783         and then Present (Full_View (Typ))
6784         and then Is_Concurrent_Type (Full_View (Typ))
6785       then
6786          Utyp := Corresponding_Record_Type (Full_View (Typ));
6787          Atyp := Typ;
6788          Ref  := Convert_Concurrent (Obj_Ref, Full_View (Typ));
6789
6790       else
6791          Utyp := Typ;
6792          Atyp := Typ;
6793          Ref  := Obj_Ref;
6794       end if;
6795
6796       Utyp := Underlying_Type (Base_Type (Utyp));
6797       Set_Assignment_OK (Ref);
6798
6799       --  Deal with non-tagged derivation of private views. If the parent type
6800       --  is a protected type, Deep_Finalize is found on the corresponding
6801       --  record of the ancestor.
6802
6803       if Is_Untagged_Derivation (Typ) then
6804          if Is_Protected_Type (Typ) then
6805             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
6806          else
6807             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6808
6809             if Is_Protected_Type (Utyp) then
6810                Utyp := Corresponding_Record_Type (Utyp);
6811             end if;
6812          end if;
6813
6814          Ref := Unchecked_Convert_To (Utyp, Ref);
6815          Set_Assignment_OK (Ref);
6816       end if;
6817
6818       --  Deal with derived private types which do not inherit primitives from
6819       --  their parents. In this case, [Deep_]Finalize can be found in the full
6820       --  view of the parent type.
6821
6822       if Is_Tagged_Type (Utyp)
6823         and then Is_Derived_Type (Utyp)
6824         and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
6825         and then Is_Private_Type (Etype (Utyp))
6826         and then Present (Full_View (Etype (Utyp)))
6827       then
6828          Utyp := Full_View (Etype (Utyp));
6829          Ref  := Unchecked_Convert_To (Utyp, Ref);
6830          Set_Assignment_OK (Ref);
6831       end if;
6832
6833       --  When dealing with the completion of a private type, use the base type
6834       --  instead.
6835
6836       if Utyp /= Base_Type (Utyp) then
6837          pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
6838
6839          Utyp := Base_Type (Utyp);
6840          Ref  := Unchecked_Convert_To (Utyp, Ref);
6841          Set_Assignment_OK (Ref);
6842       end if;
6843
6844       --  Select the appropriate version of Finalize
6845
6846       if For_Parent then
6847          if Has_Controlled_Component (Utyp) then
6848             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
6849          end if;
6850
6851       --  Class-wide types, interfaces and types with controlled components
6852
6853       elsif Is_Class_Wide_Type (Typ)
6854         or else Is_Interface (Typ)
6855         or else Has_Controlled_Component (Utyp)
6856       then
6857          if Is_Tagged_Type (Utyp) then
6858             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
6859          else
6860             Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
6861          end if;
6862
6863       --  Derivations from [Limited_]Controlled
6864
6865       elsif Is_Controlled (Utyp) then
6866          if Has_Controlled_Component (Utyp) then
6867             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
6868          else
6869             Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
6870          end if;
6871
6872       --  Tagged types
6873
6874       elsif Is_Tagged_Type (Utyp) then
6875          Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
6876
6877       else
6878          raise Program_Error;
6879       end if;
6880
6881       if Present (Fin_Id) then
6882
6883          --  When finalizing a class-wide object, do not convert to the root
6884          --  type in order to produce a dispatching call.
6885
6886          if Is_Class_Wide_Type (Typ) then
6887             null;
6888
6889          --  Ensure that a finalization routine is at least decorated in order
6890          --  to inspect the object parameter.
6891
6892          elsif Analyzed (Fin_Id)
6893            or else Ekind (Fin_Id) = E_Procedure
6894          then
6895             --  In certain cases, such as the creation of Stream_Read, the
6896             --  visible entity of the type is its full view. Since Stream_Read
6897             --  will have to create an object of type Typ, the local object
6898             --  will be finalzed by the scope finalizer generated later on. The
6899             --  object parameter of Deep_Finalize will always use the private
6900             --  view of the type. To avoid such a clash between a private and a
6901             --  full view, perform an unchecked conversion of the object
6902             --  reference to the private view.
6903
6904             declare
6905                Formal_Typ : constant Entity_Id :=
6906                               Etype (First_Formal (Fin_Id));
6907             begin
6908                if Is_Private_Type (Formal_Typ)
6909                  and then Present (Full_View (Formal_Typ))
6910                  and then Full_View (Formal_Typ) = Utyp
6911                then
6912                   Ref := Unchecked_Convert_To (Formal_Typ, Ref);
6913                end if;
6914             end;
6915
6916             Ref := Convert_View (Fin_Id, Ref);
6917          end if;
6918
6919          return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent);
6920       else
6921          return Empty;
6922       end if;
6923    end Make_Final_Call;
6924
6925    --------------------------------
6926    -- Make_Finalize_Address_Body --
6927    --------------------------------
6928
6929    procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
6930       Is_Task : constant Boolean :=
6931                   Ekind (Typ) = E_Record_Type
6932                     and then Is_Concurrent_Record_Type (Typ)
6933                     and then Ekind (Corresponding_Concurrent_Type (Typ)) =
6934                                E_Task_Type;
6935       Loc     : constant Source_Ptr := Sloc (Typ);
6936       Proc_Id : Entity_Id;
6937       Stmts   : List_Id;
6938
6939    begin
6940       --  The corresponding records of task types are not controlled by design.
6941       --  For the sake of completeness, create an empty Finalize_Address to be
6942       --  used in task class-wide allocations.
6943
6944       if Is_Task then
6945          null;
6946
6947       --  Nothing to do if the type is not controlled or it already has a
6948       --  TSS entry for Finalize_Address. Skip class-wide subtypes which do not
6949       --  come from source. These are usually generated for completeness and
6950       --  do not need the Finalize_Address primitive.
6951
6952       elsif not Needs_Finalization (Typ)
6953         or else Is_Abstract_Type (Typ)
6954         or else Present (TSS (Typ, TSS_Finalize_Address))
6955         or else
6956           (Is_Class_Wide_Type (Typ)
6957             and then Ekind (Root_Type (Typ)) = E_Record_Subtype
6958             and then not Comes_From_Source (Root_Type (Typ)))
6959       then
6960          return;
6961       end if;
6962
6963       Proc_Id :=
6964         Make_Defining_Identifier (Loc,
6965           Make_TSS_Name (Typ, TSS_Finalize_Address));
6966
6967       --  Generate:
6968
6969       --    procedure <Typ>FD (V : System.Address) is
6970       --    begin
6971       --       null;                            --  for tasks
6972
6973       --       declare                          --  for all other types
6974       --          type Pnn is access all Typ;
6975       --          for Pnn'Storage_Size use 0;
6976       --       begin
6977       --          [Deep_]Finalize (Pnn (V).all);
6978       --       end;
6979       --    end TypFD;
6980
6981       if Is_Task then
6982          Stmts := New_List (Make_Null_Statement (Loc));
6983       else
6984          Stmts := Make_Finalize_Address_Stmts (Typ);
6985       end if;
6986
6987       Discard_Node (
6988         Make_Subprogram_Body (Loc,
6989           Specification =>
6990             Make_Procedure_Specification (Loc,
6991               Defining_Unit_Name => Proc_Id,
6992
6993               Parameter_Specifications => New_List (
6994                 Make_Parameter_Specification (Loc,
6995                   Defining_Identifier =>
6996                     Make_Defining_Identifier (Loc, Name_V),
6997                   Parameter_Type =>
6998                     New_Reference_To (RTE (RE_Address), Loc)))),
6999
7000           Declarations => No_List,
7001
7002           Handled_Statement_Sequence =>
7003             Make_Handled_Sequence_Of_Statements (Loc,
7004               Statements => Stmts)));
7005
7006       Set_TSS (Typ, Proc_Id);
7007    end Make_Finalize_Address_Body;
7008
7009    ---------------------------------
7010    -- Make_Finalize_Address_Stmts --
7011    ---------------------------------
7012
7013    function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
7014       Loc      : constant Source_Ptr := Sloc (Typ);
7015       Ptr_Typ  : constant Entity_Id  := Make_Temporary (Loc, 'P');
7016       Decls    : List_Id;
7017       Desg_Typ : Entity_Id;
7018       Obj_Expr : Node_Id;
7019
7020    begin
7021       if Is_Array_Type (Typ) then
7022          if Is_Constrained (First_Subtype (Typ)) then
7023             Desg_Typ := First_Subtype (Typ);
7024          else
7025             Desg_Typ := Base_Type (Typ);
7026          end if;
7027
7028       --  Class-wide types of constrained root types
7029
7030       elsif Is_Class_Wide_Type (Typ)
7031         and then Has_Discriminants (Root_Type (Typ))
7032         and then not
7033           Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
7034       then
7035          declare
7036             Parent_Typ : Entity_Id;
7037
7038          begin
7039             --  Climb the parent type chain looking for a non-constrained type
7040
7041             Parent_Typ := Root_Type (Typ);
7042             while Parent_Typ /= Etype (Parent_Typ)
7043               and then Has_Discriminants (Parent_Typ)
7044               and then not
7045                 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
7046             loop
7047                Parent_Typ := Etype (Parent_Typ);
7048             end loop;
7049
7050             --  Handle views created for tagged types with unknown
7051             --  discriminants.
7052
7053             if Is_Underlying_Record_View (Parent_Typ) then
7054                Parent_Typ := Underlying_Record_View (Parent_Typ);
7055             end if;
7056
7057             Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
7058          end;
7059
7060       --  General case
7061
7062       else
7063          Desg_Typ := Typ;
7064       end if;
7065
7066       --  Generate:
7067       --    type Ptr_Typ is access all Typ;
7068       --    for Ptr_Typ'Storage_Size use 0;
7069
7070       Decls := New_List (
7071         Make_Full_Type_Declaration (Loc,
7072           Defining_Identifier => Ptr_Typ,
7073           Type_Definition     =>
7074             Make_Access_To_Object_Definition (Loc,
7075               All_Present        => True,
7076               Subtype_Indication => New_Reference_To (Desg_Typ, Loc))),
7077
7078         Make_Attribute_Definition_Clause (Loc,
7079           Name       => New_Reference_To (Ptr_Typ, Loc),
7080           Chars      => Name_Storage_Size,
7081           Expression => Make_Integer_Literal (Loc, 0)));
7082
7083       Obj_Expr := Make_Identifier (Loc, Name_V);
7084
7085       --  Unconstrained arrays require special processing in order to retrieve
7086       --  the elements. To achieve this, we have to skip the dope vector which
7087       --  lays in front of the elements and then use a thin pointer to perform
7088       --  the address-to-access conversion.
7089
7090       if Is_Array_Type (Typ)
7091         and then not Is_Constrained (First_Subtype (Typ))
7092       then
7093          declare
7094             Dope_Id : Entity_Id;
7095
7096          begin
7097             --  Ensure that Ptr_Typ a thin pointer, generate:
7098             --    for Ptr_Typ'Size use System.Address'Size;
7099
7100             Append_To (Decls,
7101               Make_Attribute_Definition_Clause (Loc,
7102                 Name       => New_Reference_To (Ptr_Typ, Loc),
7103                 Chars      => Name_Size,
7104                 Expression =>
7105                   Make_Integer_Literal (Loc, System_Address_Size)));
7106
7107             --  Generate:
7108             --    Dnn : constant Storage_Offset :=
7109             --            Desg_Typ'Descriptor_Size / Storage_Unit;
7110
7111             Dope_Id := Make_Temporary (Loc, 'D');
7112
7113             Append_To (Decls,
7114               Make_Object_Declaration (Loc,
7115                 Defining_Identifier => Dope_Id,
7116                 Constant_Present    => True,
7117                 Object_Definition   =>
7118                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
7119                 Expression          =>
7120                   Make_Op_Divide (Loc,
7121                     Left_Opnd  =>
7122                       Make_Attribute_Reference (Loc,
7123                         Prefix         => New_Reference_To (Desg_Typ, Loc),
7124                         Attribute_Name => Name_Descriptor_Size),
7125                     Right_Opnd =>
7126                       Make_Integer_Literal (Loc, System_Storage_Unit))));
7127
7128             --  Shift the address from the start of the dope vector to the
7129             --  start of the elements:
7130             --
7131             --    V + Dnn
7132             --
7133             --  Note that this is done through a wrapper routine since RTSfind
7134             --  cannot retrieve operations with string names of the form "+".
7135
7136             Obj_Expr :=
7137               Make_Function_Call (Loc,
7138                 Name                   =>
7139                   New_Reference_To (RTE (RE_Add_Offset_To_Address), Loc),
7140                 Parameter_Associations => New_List (
7141                   Obj_Expr,
7142                   New_Reference_To (Dope_Id, Loc)));
7143          end;
7144       end if;
7145
7146       --  Create the block and the finalization call
7147
7148       return New_List (
7149         Make_Block_Statement (Loc,
7150           Declarations => Decls,
7151
7152           Handled_Statement_Sequence =>
7153             Make_Handled_Sequence_Of_Statements (Loc,
7154               Statements => New_List (
7155                 Make_Final_Call (
7156                   Obj_Ref =>
7157                     Make_Explicit_Dereference (Loc,
7158                       Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
7159                   Typ => Desg_Typ)))));
7160    end Make_Finalize_Address_Stmts;
7161
7162    -------------------------------------
7163    -- Make_Handler_For_Ctrl_Operation --
7164    -------------------------------------
7165
7166    --  Generate:
7167
7168    --    when E : others =>
7169    --      Raise_From_Controlled_Operation (E);
7170
7171    --  or:
7172
7173    --    when others =>
7174    --      raise Program_Error [finalize raised exception];
7175
7176    --  depending on whether Raise_From_Controlled_Operation is available
7177
7178    function Make_Handler_For_Ctrl_Operation
7179      (Loc : Source_Ptr) return Node_Id
7180    is
7181       E_Occ : Entity_Id;
7182       --  Choice parameter (for the first case above)
7183
7184       Raise_Node : Node_Id;
7185       --  Procedure call or raise statement
7186
7187    begin
7188       --  Standard run-time, .NET/JVM targets: add choice parameter E and pass
7189       --  it to Raise_From_Controlled_Operation so that the original exception
7190       --  name and message can be recorded in the exception message for
7191       --  Program_Error.
7192
7193       if RTE_Available (RE_Raise_From_Controlled_Operation) then
7194          E_Occ := Make_Defining_Identifier (Loc, Name_E);
7195          Raise_Node :=
7196            Make_Procedure_Call_Statement (Loc,
7197              Name                   =>
7198                New_Reference_To
7199                  (RTE (RE_Raise_From_Controlled_Operation), Loc),
7200              Parameter_Associations => New_List (
7201                New_Reference_To (E_Occ, Loc)));
7202
7203       --  Restricted run-time: exception messages are not supported
7204
7205       else
7206          E_Occ := Empty;
7207          Raise_Node :=
7208            Make_Raise_Program_Error (Loc,
7209              Reason => PE_Finalize_Raised_Exception);
7210       end if;
7211
7212       return
7213         Make_Implicit_Exception_Handler (Loc,
7214           Exception_Choices => New_List (Make_Others_Choice (Loc)),
7215           Choice_Parameter  => E_Occ,
7216           Statements        => New_List (Raise_Node));
7217    end Make_Handler_For_Ctrl_Operation;
7218
7219    --------------------
7220    -- Make_Init_Call --
7221    --------------------
7222
7223    function Make_Init_Call
7224      (Obj_Ref : Node_Id;
7225       Typ     : Entity_Id) return Node_Id
7226    is
7227       Loc     : constant Source_Ptr := Sloc (Obj_Ref);
7228       Is_Conc : Boolean;
7229       Proc    : Entity_Id;
7230       Ref     : Node_Id;
7231       Utyp    : Entity_Id;
7232
7233    begin
7234       --  Deal with the type and object reference. Depending on the context, an
7235       --  object reference may need several conversions.
7236
7237       if Is_Concurrent_Type (Typ) then
7238          Is_Conc := True;
7239          Utyp    := Corresponding_Record_Type (Typ);
7240          Ref     := Convert_Concurrent (Obj_Ref, Typ);
7241
7242       elsif Is_Private_Type (Typ)
7243         and then Present (Full_View (Typ))
7244         and then Is_Concurrent_Type (Underlying_Type (Typ))
7245       then
7246          Is_Conc := True;
7247          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
7248          Ref     := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
7249
7250       else
7251          Is_Conc := False;
7252          Utyp    := Typ;
7253          Ref     := Obj_Ref;
7254       end if;
7255
7256       Set_Assignment_OK (Ref);
7257
7258       Utyp := Underlying_Type (Base_Type (Utyp));
7259
7260       --  Deal with non-tagged derivation of private views
7261
7262       if Is_Untagged_Derivation (Typ)
7263         and then not Is_Conc
7264       then
7265          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7266          Ref  := Unchecked_Convert_To (Utyp, Ref);
7267
7268          --  The following is to prevent problems with UC see 1.156 RH ???
7269
7270          Set_Assignment_OK (Ref);
7271       end if;
7272
7273       --  If the underlying_type is a subtype, then we are dealing with the
7274       --  completion of a private type. We need to access the base type and
7275       --  generate a conversion to it.
7276
7277       if Utyp /= Base_Type (Utyp) then
7278          pragma Assert (Is_Private_Type (Typ));
7279          Utyp := Base_Type (Utyp);
7280          Ref  := Unchecked_Convert_To (Utyp, Ref);
7281       end if;
7282
7283       --  Select the appropriate version of initialize
7284
7285       if Has_Controlled_Component (Utyp) then
7286          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
7287       else
7288          Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
7289          Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
7290       end if;
7291
7292       --  The object reference may need another conversion depending on the
7293       --  type of the formal and that of the actual.
7294
7295       Ref := Convert_View (Proc, Ref);
7296
7297       --  Generate:
7298       --    [Deep_]Initialize (Ref);
7299
7300       return
7301         Make_Procedure_Call_Statement (Loc,
7302           Name =>
7303             New_Reference_To (Proc, Loc),
7304           Parameter_Associations => New_List (Ref));
7305    end Make_Init_Call;
7306
7307    ------------------------------
7308    -- Make_Local_Deep_Finalize --
7309    ------------------------------
7310
7311    function Make_Local_Deep_Finalize
7312      (Typ : Entity_Id;
7313       Nam : Entity_Id) return Node_Id
7314    is
7315       Loc : constant Source_Ptr := Sloc (Typ);
7316       Formals : List_Id;
7317
7318    begin
7319       Formals := New_List (
7320
7321          --  V : in out Typ
7322
7323         Make_Parameter_Specification (Loc,
7324           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7325           In_Present          => True,
7326           Out_Present         => True,
7327           Parameter_Type      => New_Reference_To (Typ, Loc)),
7328
7329          --  F : Boolean := True
7330
7331         Make_Parameter_Specification (Loc,
7332           Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
7333           Parameter_Type      => New_Reference_To (Standard_Boolean, Loc),
7334           Expression          => New_Reference_To (Standard_True, Loc)));
7335
7336       --  Add the necessary number of counters to represent the initialization
7337       --  state of an object.
7338
7339       return
7340         Make_Subprogram_Body (Loc,
7341           Specification =>
7342             Make_Procedure_Specification (Loc,
7343               Defining_Unit_Name       => Nam,
7344               Parameter_Specifications => Formals),
7345
7346           Declarations => No_List,
7347
7348           Handled_Statement_Sequence =>
7349             Make_Handled_Sequence_Of_Statements (Loc,
7350               Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
7351    end Make_Local_Deep_Finalize;
7352
7353    ------------------------------------
7354    -- Make_Set_Finalize_Address_Call --
7355    ------------------------------------
7356
7357    function Make_Set_Finalize_Address_Call
7358      (Loc     : Source_Ptr;
7359       Typ     : Entity_Id;
7360       Ptr_Typ : Entity_Id) return Node_Id
7361    is
7362       Desig_Typ   : constant Entity_Id :=
7363                       Available_View (Designated_Type (Ptr_Typ));
7364       Fin_Mas_Id  : constant Entity_Id := Finalization_Master (Ptr_Typ);
7365       Fin_Mas_Ref : Node_Id;
7366       Utyp        : Entity_Id;
7367
7368    begin
7369       --  If the context is a class-wide allocator, we use the class-wide type
7370       --  to obtain the proper Finalize_Address routine.
7371
7372       if Is_Class_Wide_Type (Desig_Typ) then
7373          Utyp := Desig_Typ;
7374
7375       else
7376          Utyp := Typ;
7377
7378          if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
7379             Utyp := Full_View (Utyp);
7380          end if;
7381
7382          if Is_Concurrent_Type (Utyp) then
7383             Utyp := Corresponding_Record_Type (Utyp);
7384          end if;
7385       end if;
7386
7387       Utyp := Underlying_Type (Base_Type (Utyp));
7388
7389       --  Deal with non-tagged derivation of private views. If the parent is
7390       --  now known to be protected, the finalization routine is the one
7391       --  defined on the corresponding record of the ancestor (corresponding
7392       --  records do not automatically inherit operations, but maybe they
7393       --  should???)
7394
7395       if Is_Untagged_Derivation (Typ) then
7396          if Is_Protected_Type (Typ) then
7397             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7398          else
7399             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7400
7401             if Is_Protected_Type (Utyp) then
7402                Utyp := Corresponding_Record_Type (Utyp);
7403             end if;
7404          end if;
7405       end if;
7406
7407       --  If the underlying_type is a subtype, we are dealing with the
7408       --  completion of a private type. We need to access the base type and
7409       --  generate a conversion to it.
7410
7411       if Utyp /= Base_Type (Utyp) then
7412          pragma Assert (Is_Private_Type (Typ));
7413
7414          Utyp := Base_Type (Utyp);
7415       end if;
7416
7417       Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc);
7418
7419       --  If the call is from a build-in-place function, the Master parameter
7420       --  is actually a pointer. Dereference it for the call.
7421
7422       if Is_Access_Type (Etype (Fin_Mas_Id)) then
7423          Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref);
7424       end if;
7425
7426       --  Generate:
7427       --    Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7428
7429       return
7430         Make_Procedure_Call_Statement (Loc,
7431           Name                   =>
7432             New_Reference_To (RTE (RE_Set_Finalize_Address), Loc),
7433           Parameter_Associations => New_List (
7434             Fin_Mas_Ref,
7435             Make_Attribute_Reference (Loc,
7436               Prefix         =>
7437                 New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
7438               Attribute_Name => Name_Unrestricted_Access)));
7439    end Make_Set_Finalize_Address_Call;
7440
7441    --------------------------
7442    -- Make_Transient_Block --
7443    --------------------------
7444
7445    function Make_Transient_Block
7446      (Loc    : Source_Ptr;
7447       Action : Node_Id;
7448       Par    : Node_Id) return Node_Id
7449    is
7450       Decls  : constant List_Id := New_List;
7451       Instrs : constant List_Id := New_List (Action);
7452       Block  : Node_Id;
7453       Insert : Node_Id;
7454
7455    begin
7456       --  Case where only secondary stack use is involved
7457
7458       if VM_Target = No_VM
7459         and then Uses_Sec_Stack (Current_Scope)
7460         and then Nkind (Action) /= N_Simple_Return_Statement
7461         and then Nkind (Par) /= N_Exception_Handler
7462       then
7463          declare
7464             S : Entity_Id;
7465
7466          begin
7467             S := Scope (Current_Scope);
7468             loop
7469                --  At the outer level, no need to release the sec stack
7470
7471                if S = Standard_Standard then
7472                   Set_Uses_Sec_Stack (Current_Scope, False);
7473                   exit;
7474
7475                --  In a function, only release the sec stack if the function
7476                --  does not return on the sec stack otherwise the result may
7477                --  be lost. The caller is responsible for releasing.
7478
7479                elsif Ekind (S) = E_Function then
7480                   Set_Uses_Sec_Stack (Current_Scope, False);
7481
7482                   if not Requires_Transient_Scope (Etype (S)) then
7483                      Set_Uses_Sec_Stack (S, True);
7484                      Check_Restriction (No_Secondary_Stack, Action);
7485                   end if;
7486
7487                   exit;
7488
7489                --  In a loop or entry we should install a block encompassing
7490                --  all the construct. For now just release right away.
7491
7492                elsif Ekind_In (S, E_Entry, E_Loop) then
7493                   exit;
7494
7495                --  In a procedure or a block, we release on exit of the
7496                --  procedure or block. ??? memory leak can be created by
7497                --  recursive calls.
7498
7499                elsif Ekind_In (S, E_Block, E_Procedure) then
7500                   Set_Uses_Sec_Stack (S, True);
7501                   Check_Restriction (No_Secondary_Stack, Action);
7502                   Set_Uses_Sec_Stack (Current_Scope, False);
7503                   exit;
7504
7505                else
7506                   S := Scope (S);
7507                end if;
7508             end loop;
7509          end;
7510       end if;
7511
7512       --  Create the transient block. Set the parent now since the block itself
7513       --  is not part of the tree.
7514
7515       Block :=
7516         Make_Block_Statement (Loc,
7517           Identifier                 => New_Reference_To (Current_Scope, Loc),
7518           Declarations               => Decls,
7519           Handled_Statement_Sequence =>
7520             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
7521           Has_Created_Identifier     => True);
7522       Set_Parent (Block, Par);
7523
7524       --  Insert actions stuck in the transient scopes as well as all freezing
7525       --  nodes needed by those actions.
7526
7527       Insert_Actions_In_Scope_Around (Action);
7528
7529       Insert := Prev (Action);
7530       if Present (Insert) then
7531          Freeze_All (First_Entity (Current_Scope), Insert);
7532       end if;
7533
7534       --  When the transient scope was established, we pushed the entry for the
7535       --  transient scope onto the scope stack, so that the scope was active
7536       --  for the installation of finalizable entities etc. Now we must remove
7537       --  this entry, since we have constructed a proper block.
7538
7539       Pop_Scope;
7540
7541       return Block;
7542    end Make_Transient_Block;
7543
7544    ------------------------
7545    -- Node_To_Be_Wrapped --
7546    ------------------------
7547
7548    function Node_To_Be_Wrapped return Node_Id is
7549    begin
7550       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
7551    end Node_To_Be_Wrapped;
7552
7553    ----------------------------
7554    -- Set_Node_To_Be_Wrapped --
7555    ----------------------------
7556
7557    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
7558    begin
7559       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
7560    end Set_Node_To_Be_Wrapped;
7561
7562    ----------------------------------
7563    -- Store_After_Actions_In_Scope --
7564    ----------------------------------
7565
7566    procedure Store_After_Actions_In_Scope (L : List_Id) is
7567       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
7568
7569    begin
7570       if Present (SE.Actions_To_Be_Wrapped_After) then
7571          Insert_List_Before_And_Analyze (
7572           First (SE.Actions_To_Be_Wrapped_After), L);
7573
7574       else
7575          SE.Actions_To_Be_Wrapped_After := L;
7576
7577          if Is_List_Member (SE.Node_To_Be_Wrapped) then
7578             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
7579          else
7580             Set_Parent (L, SE.Node_To_Be_Wrapped);
7581          end if;
7582
7583          Analyze_List (L);
7584       end if;
7585    end Store_After_Actions_In_Scope;
7586
7587    -----------------------------------
7588    -- Store_Before_Actions_In_Scope --
7589    -----------------------------------
7590
7591    procedure Store_Before_Actions_In_Scope (L : List_Id) is
7592       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
7593
7594    begin
7595       if Present (SE.Actions_To_Be_Wrapped_Before) then
7596          Insert_List_After_And_Analyze (
7597            Last (SE.Actions_To_Be_Wrapped_Before), L);
7598
7599       else
7600          SE.Actions_To_Be_Wrapped_Before := L;
7601
7602          if Is_List_Member (SE.Node_To_Be_Wrapped) then
7603             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
7604          else
7605             Set_Parent (L, SE.Node_To_Be_Wrapped);
7606          end if;
7607
7608          Analyze_List (L);
7609       end if;
7610    end Store_Before_Actions_In_Scope;
7611
7612    --------------------------------
7613    -- Wrap_Transient_Declaration --
7614    --------------------------------
7615
7616    --  If a transient scope has been established during the processing of the
7617    --  Expression of an Object_Declaration, it is not possible to wrap the
7618    --  declaration into a transient block as usual case, otherwise the object
7619    --  would be itself declared in the wrong scope. Therefore, all entities (if
7620    --  any) defined in the transient block are moved to the proper enclosing
7621    --  scope, furthermore, if they are controlled variables they are finalized
7622    --  right after the declaration. The finalization list of the transient
7623    --  scope is defined as a renaming of the enclosing one so during their
7624    --  initialization they will be attached to the proper finalization list.
7625    --  For instance, the following declaration :
7626
7627    --        X : Typ := F (G (A), G (B));
7628
7629    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7630    --  is expanded into :
7631
7632    --    X : Typ := [ complex Expression-Action ];
7633    --    [Deep_]Finalize (_v1);
7634    --    [Deep_]Finalize (_v2);
7635
7636    procedure Wrap_Transient_Declaration (N : Node_Id) is
7637       Encl_S  : Entity_Id;
7638       S       : Entity_Id;
7639       Uses_SS : Boolean;
7640
7641    begin
7642       S := Current_Scope;
7643       Encl_S := Scope (S);
7644
7645       --  Insert Actions kept in the Scope stack
7646
7647       Insert_Actions_In_Scope_Around (N);
7648
7649       --  If the declaration is consuming some secondary stack, mark the
7650       --  enclosing scope appropriately.
7651
7652       Uses_SS := Uses_Sec_Stack (S);
7653       Pop_Scope;
7654
7655       --  Put the local entities back in the enclosing scope, and set the
7656       --  Is_Public flag appropriately.
7657
7658       Transfer_Entities (S, Encl_S);
7659
7660       --  Mark the enclosing dynamic scope so that the sec stack will be
7661       --  released upon its exit unless this is a function that returns on
7662       --  the sec stack in which case this will be done by the caller.
7663
7664       if VM_Target = No_VM and then Uses_SS then
7665          S := Enclosing_Dynamic_Scope (S);
7666
7667          if Ekind (S) = E_Function
7668            and then Requires_Transient_Scope (Etype (S))
7669          then
7670             null;
7671          else
7672             Set_Uses_Sec_Stack (S);
7673             Check_Restriction (No_Secondary_Stack, N);
7674          end if;
7675       end if;
7676    end Wrap_Transient_Declaration;
7677
7678    -------------------------------
7679    -- Wrap_Transient_Expression --
7680    -------------------------------
7681
7682    procedure Wrap_Transient_Expression (N : Node_Id) is
7683       Expr : constant Node_Id    := Relocate_Node (N);
7684       Loc  : constant Source_Ptr := Sloc (N);
7685       Temp : constant Entity_Id  := Make_Temporary (Loc, 'E', N);
7686       Typ  : constant Entity_Id  := Etype (N);
7687
7688    begin
7689       --  Generate:
7690
7691       --    Temp : Typ;
7692       --    declare
7693       --       M : constant Mark_Id := SS_Mark;
7694       --       procedure Finalizer is ...  (See Build_Finalizer)
7695
7696       --    begin
7697       --       Temp := <Expr>;
7698       --
7699       --    at end
7700       --       Finalizer;
7701       --    end;
7702
7703       Insert_Actions (N, New_List (
7704         Make_Object_Declaration (Loc,
7705           Defining_Identifier => Temp,
7706           Object_Definition   => New_Reference_To (Typ, Loc)),
7707
7708         Make_Transient_Block (Loc,
7709           Action =>
7710             Make_Assignment_Statement (Loc,
7711               Name       => New_Reference_To (Temp, Loc),
7712               Expression => Expr),
7713           Par    => Parent (N))));
7714
7715       Rewrite (N, New_Reference_To (Temp, Loc));
7716       Analyze_And_Resolve (N, Typ);
7717    end Wrap_Transient_Expression;
7718
7719    ------------------------------
7720    -- Wrap_Transient_Statement --
7721    ------------------------------
7722
7723    procedure Wrap_Transient_Statement (N : Node_Id) is
7724       Loc      : constant Source_Ptr := Sloc (N);
7725       New_Stmt : constant Node_Id    := Relocate_Node (N);
7726
7727    begin
7728       --  Generate:
7729       --    declare
7730       --       M : constant Mark_Id := SS_Mark;
7731       --       procedure Finalizer is ...  (See Build_Finalizer)
7732       --
7733       --    begin
7734       --       <New_Stmt>;
7735       --
7736       --    at end
7737       --       Finalizer;
7738       --    end;
7739
7740       Rewrite (N,
7741         Make_Transient_Block (Loc,
7742           Action => New_Stmt,
7743           Par    => Parent (N)));
7744
7745       --  With the scope stack back to normal, we can call analyze on the
7746       --  resulting block. At this point, the transient scope is being
7747       --  treated like a perfectly normal scope, so there is nothing
7748       --  special about it.
7749
7750       --  Note: Wrap_Transient_Statement is called with the node already
7751       --  analyzed (i.e. Analyzed (N) is True). This is important, since
7752       --  otherwise we would get a recursive processing of the node when
7753       --  we do this Analyze call.
7754
7755       Analyze (N);
7756    end Wrap_Transient_Statement;
7757
7758 end Exp_Ch7;