PR target/49868

[official-gcc.git] / gcc / ada / exp_ch7.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              E X P _ C H 7                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains virtually all expansion mechanisms related to
--    - controlled types
--    - transient scopes

with Atree;    use Atree;
with Debug;    use Debug;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Errout;   use Errout;
with Exp_Ch6;  use Exp_Ch6;
with Exp_Ch9;  use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Dist; use Exp_Dist;
with Exp_Disp; use Exp_Disp;
with Exp_Tss;  use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze;   use Freeze;
with Lib;      use Lib;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Opt;      use Opt;
with Output;   use Output;
with Restrict; use Restrict;
with Rident;   use Rident;
with Rtsfind;  use Rtsfind;
with Sinfo;    use Sinfo;
with Sem;      use Sem;
with Sem_Aux;  use Sem_Aux;
with Sem_Ch3;  use Sem_Ch3;
with Sem_Ch7;  use Sem_Ch7;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Res;  use Sem_Res;
with Sem_Util; use Sem_Util;
with Snames;   use Snames;
with Stand;    use Stand;
with Targparm; use Targparm;
with Tbuild;   use Tbuild;
with Ttypes;   use Ttypes;
with Uintp;    use Uintp;

package body Exp_Ch7 is

   --------------------------------
   -- Transient Scope Management --
   --------------------------------

   --  A transient scope is created when temporary objects are created by the
   --  compiler. These temporary objects are allocated on the secondary stack
   --  and the transient scope is responsible for finalizing the object when
   --  appropriate and reclaiming the memory at the right time. The temporary
   --  objects are generally the objects allocated to store the result of a
   --  function returning an unconstrained or a tagged value. Expressions
   --  needing to be wrapped in a transient scope (functions calls returning
   --  unconstrained or tagged values) may appear in 3 different contexts which
   --  lead to 3 different kinds of transient scope expansion:

   --   1. In a simple statement (procedure call, assignment, ...). In this
   --      case the instruction is wrapped into a transient block. See
   --      Wrap_Transient_Statement for details.

   --   2. In an expression of a control structure (test in a IF statement,
   --      expression in a CASE statement, ...). See Wrap_Transient_Expression
   --      for details.

   --   3. In a expression of an object_declaration. No wrapping is possible
   --      here, so the finalization actions, if any, are done right after the
   --      declaration and the secondary stack deallocation is done in the
   --      proper enclosing scope. See Wrap_Transient_Declaration for details.

   --  Note about functions returning tagged types: it has been decided to
   --  always allocate their result in the secondary stack, even though is not
   --  absolutely mandatory when the tagged type is constrained because the
   --  caller knows the size of the returned object and thus could allocate the
   --  result in the primary stack. An exception to this is when the function
   --  builds its result in place, as is done for functions with inherently
   --  limited result types for Ada 2005. In that case, certain callers may
   --  pass the address of a constrained object as the target object for the
   --  function result.

   --  By allocating tagged results in the secondary stack a number of
   --  implementation difficulties are avoided:

   --    - If it is a dispatching function call, the computation of the size of
   --      the result is possible but complex from the outside.

   --    - If the returned type is controlled, the assignment of the returned
   --      value to the anonymous object involves an Adjust, and we have no
   --      easy way to access the anonymous object created by the back end.

   --    - If the returned type is class-wide, this is an unconstrained type
   --      anyway.

   --  Furthermore, the small loss in efficiency which is the result of this
   --  decision is not such a big deal because functions returning tagged types
   --  are not as common in practice compared to functions returning access to
   --  a tagged type.

   --------------------------------------------------
   -- Transient Blocks and Finalization Management --
   --------------------------------------------------

   function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
   --  N is a node which may generate a transient scope. Loop over the parent
   --  pointers of N until it find the appropriate node to wrap. If it returns
   --  Empty, it means that no transient scope is needed in this context.

   procedure Insert_Actions_In_Scope_Around (N : Node_Id);
   --  Insert the before-actions kept in the scope stack before N, and the
   --  after-actions after N, which must be a member of a list.

   function Make_Transient_Block
     (Loc    : Source_Ptr;
      Action : Node_Id;
      Par    : Node_Id) return Node_Id;
   --  Action is a single statement or object declaration. Par is the proper
   --  parent of the generated block. Create a transient block whose name is
   --  the current scope and the only handled statement is Action. If Action
   --  involves controlled objects or secondary stack usage, the corresponding
   --  cleanup actions are performed at the end of the block.

   procedure Set_Node_To_Be_Wrapped (N : Node_Id);
   --  Set the field Node_To_Be_Wrapped of the current scope

   --  ??? The entire comment needs to be rewritten

   -----------------------------
   -- Finalization Management --
   -----------------------------

   --  This part describe how Initialization/Adjustment/Finalization procedures
   --  are generated and called. Two cases must be considered, types that are
   --  Controlled (Is_Controlled flag set) and composite types that contain
   --  controlled components (Has_Controlled_Component flag set). In the first
   --  case the procedures to call are the user-defined primitive operations
   --  Initialize/Adjust/Finalize. In the second case, GNAT generates
   --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
   --  of calling the former procedures on the controlled components.

   --  For records with Has_Controlled_Component set, a hidden "controller"
   --  component is inserted. This controller component contains its own
   --  finalization list on which all controlled components are attached
   --  creating an indirection on the upper-level Finalization list. This
   --  technique facilitates the management of objects whose number of
   --  controlled components changes during execution. This controller
   --  component is itself controlled and is attached to the upper-level
   --  finalization chain. Its adjust primitive is in charge of calling adjust
   --  on the components and adjusting the finalization pointer to match their
   --  new location (see a-finali.adb).

   --  It is not possible to use a similar technique for arrays that have
   --  Has_Controlled_Component set. In this case, deep procedures are
   --  generated that call initialize/adjust/finalize + attachment or
   --  detachment on the finalization list for all component.

   --  Initialize calls: they are generated for declarations or dynamic
   --  allocations of Controlled objects with no initial value. They are always
   --  followed by an attachment to the current Finalization Chain. For the
   --  dynamic allocation case this the chain attached to the scope of the
   --  access type definition otherwise, this is the chain of the current
   --  scope.

   --  Adjust Calls: They are generated on 2 occasions: (1) for declarations
   --  or dynamic allocations of Controlled objects with an initial value.
   --  (2) after an assignment. In the first case they are followed by an
   --  attachment to the final chain, in the second case they are not.

   --  Finalization Calls: They are generated on (1) scope exit, (2)
   --  assignments, (3) unchecked deallocations. In case (3) they have to
   --  be detached from the final chain, in case (2) they must not and in
   --  case (1) this is not important since we are exiting the scope anyway.

   --  Other details:

   --    Type extensions will have a new record controller at each derivation
   --    level containing controlled components. The record controller for
   --    the parent/ancestor is attached to the finalization list of the
   --    extension's record controller (i.e. the parent is like a component
   --    of the extension).

   --    For types that are both Is_Controlled and Has_Controlled_Components,
   --    the record controller and the object itself are handled separately.
   --    It could seem simpler to attach the object at the end of its record
   --    controller but this would not tackle view conversions properly.

   --    A classwide type can always potentially have controlled components
   --    but the record controller of the corresponding actual type may not
   --    be known at compile time so the dispatch table contains a special
   --    field that allows to compute the offset of the record controller
   --    dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.

   --  Here is a simple example of the expansion of a controlled block :

   --    declare
   --       X : Controlled;
   --       Y : Controlled := Init;
   --
   --       type R is record
   --          C : Controlled;
   --       end record;
   --       W : R;
   --       Z : R := (C => X);

   --    begin
   --       X := Y;
   --       W := Z;
   --    end;
   --
   --  is expanded into
   --
   --    declare
   --       _L : System.FI.Finalizable_Ptr;

   --       procedure _Clean is
   --       begin
   --          Abort_Defer;
   --          System.FI.Finalize_List (_L);
   --          Abort_Undefer;
   --       end _Clean;

   --       X : Controlled;
   --       begin
   --          Abort_Defer;
   --          Initialize (X);
   --          Attach_To_Final_List (_L, Finalizable (X), 1);
   --       at end: Abort_Undefer;
   --       Y : Controlled := Init;
   --       Adjust (Y);
   --       Attach_To_Final_List (_L, Finalizable (Y), 1);
   --
   --       type R is record
   --          C : Controlled;
   --       end record;
   --       W : R;
   --       begin
   --          Abort_Defer;
   --          Deep_Initialize (W, _L, 1);
   --       at end: Abort_Under;
   --       Z : R := (C => X);
   --       Deep_Adjust (Z, _L, 1);

   --    begin
   --       _Assign (X, Y);
   --       Deep_Finalize (W, False);
   --       <save W's final pointers>
   --       W := Z;
   --       <restore W's final pointers>
   --       Deep_Adjust (W, _L, 0);
   --    at end
   --       _Clean;
   --    end;

   type Final_Primitives is
     (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
   --  This enumeration type is defined in order to ease sharing code for
   --  building finalization procedures for composite types.

   Name_Of      : constant array (Final_Primitives) of Name_Id :=
                    (Initialize_Case => Name_Initialize,
                     Adjust_Case     => Name_Adjust,
                     Finalize_Case   => Name_Finalize,
                     Address_Case    => Name_Finalize_Address);
   Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
                    (Initialize_Case => TSS_Deep_Initialize,
                     Adjust_Case     => TSS_Deep_Adjust,
                     Finalize_Case   => TSS_Deep_Finalize,
                     Address_Case    => TSS_Finalize_Address);

   procedure Build_Array_Deep_Procs (Typ : Entity_Id);
   --  Build the deep Initialize/Adjust/Finalize for a record Typ with
   --  Has_Controlled_Component set and store them using the TSS mechanism.

   function Build_Cleanup_Statements (N : Node_Id) return List_Id;
   --  Create the clean up calls for an asynchronous call block, task master,
   --  protected subprogram body, task allocation block or task body. If the
   --  context does not contain the above constructs, the routine returns an
   --  empty list.

   procedure Build_Finalizer
     (N           : Node_Id;
      Clean_Stmts : List_Id;
      Mark_Id     : Entity_Id;
      Top_Decls   : List_Id;
      Defer_Abort : Boolean;
      Fin_Id      : out Entity_Id);
   --  N may denote an accept statement, block, entry body, package body,
   --  package spec, protected body, subprogram body, and a task body. Create
   --  a procedure which contains finalization calls for all controlled objects
   --  declared in the declarative or statement region of N. The calls are
   --  built in reverse order relative to the original declarations. In the
   --  case of a tack body, the routine delays the creation of the finalizer
   --  until all statements have been moved to the task body procedure.
   --  Clean_Stmts may contain additional context-dependent code used to abort
   --  asynchronous calls or complete tasks (see Build_Cleanup_Statements).
   --  Mark_Id is the secondary stack used in the current context or Empty if
   --  missing. Top_Decls is the list on which the declaration of the finalizer
   --  is attached in the non-package case. Defer_Abort indicates that the
   --  statements passed in perform actions that require abort to be deferred,
   --  such as for task termination. Fin_Id is the finalizer declaration
   --  entity.

   procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
   --  N is a construct which contains a handled sequence of statements, Fin_Id
   --  is the entity of a finalizer. Create an At_End handler which covers the
   --  statements of N and calls Fin_Id. If the handled statement sequence has
   --  an exception handler, the statements will be wrapped in a block to avoid
   --  unwanted interaction with the new At_End handler.

   procedure Build_Record_Deep_Procs (Typ : Entity_Id);
   --  Build the deep Initialize/Adjust/Finalize for a record Typ with
   --  Has_Component_Component set and store them using the TSS mechanism.

   procedure Check_Visibly_Controlled
     (Prim : Final_Primitives;
      Typ  : Entity_Id;
      E    : in out Entity_Id;
      Cref : in out Node_Id);
   --  The controlled operation declared for a derived type may not be
   --  overriding, if the controlled operations of the parent type are hidden,
   --  for example when the parent is a private type whose full view is
   --  controlled. For other primitive operations we modify the name of the
   --  operation to indicate that it is not overriding, but this is not
   --  possible for Initialize, etc. because they have to be retrievable by
   --  name. Before generating the proper call to one of these operations we
   --  check whether Typ is known to be controlled at the point of definition.
   --  If it is not then we must retrieve the hidden operation of the parent
   --  and use it instead.  This is one case that might be solved more cleanly
   --  once Overriding pragmas or declarations are in place.

   function Convert_View
     (Proc : Entity_Id;
      Arg  : Node_Id;
      Ind  : Pos := 1) return Node_Id;
   --  Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
   --  argument being passed to it. Ind indicates which formal of procedure
   --  Proc we are trying to match. This function will, if necessary, generate
   --  a conversion between the partial and full view of Arg to match the type
   --  of the formal of Proc, or force a conversion to the class-wide type in
   --  the case where the operation is abstract.

   function Enclosing_Function (E : Entity_Id) return Entity_Id;
   --  Given an arbitrary entity, traverse the scope chain looking for the
   --  first enclosing function. Return Empty if no function was found.

   function Make_Call
     (Loc        : Source_Ptr;
      Proc_Id    : Entity_Id;
      Param      : Node_Id;
      For_Parent : Boolean := False) return Node_Id;
   --  Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
   --  routine [Deep_]Adjust / Finalize and an object parameter, create an
   --  adjust / finalization call. Flag For_Parent should be set when field
   --  _parent is being processed.

   function Make_Deep_Proc
     (Prim  : Final_Primitives;
      Typ   : Entity_Id;
      Stmts : List_Id) return Node_Id;
   --  This function generates the tree for Deep_Initialize, Deep_Adjust or
   --  Deep_Finalize procedures according to the first parameter, these
   --  procedures operate on the type Typ. The Stmts parameter gives the body
   --  of the procedure.

   function Make_Deep_Array_Body
     (Prim : Final_Primitives;
      Typ  : Entity_Id) return List_Id;
   --  This function generates the list of statements for implementing
   --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
   --  the first parameter, these procedures operate on the array type Typ.

   function Make_Deep_Record_Body
     (Prim     : Final_Primitives;
      Typ      : Entity_Id;
      Is_Local : Boolean := False) return List_Id;
   --  This function generates the list of statements for implementing
   --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
   --  the first parameter, these procedures operate on the record type Typ.
   --  Flag Is_Local is used in conjunction with Deep_Finalize to designate
   --  whether the inner logic should be dictated by state counters.

   function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
   --  Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
   --  Make_Deep_Record_Body. Generate the following statements:
   --
   --    declare
   --       type Acc_Typ is access all Typ;
   --       for Acc_Typ'Storage_Size use 0;
   --    begin
   --       [Deep_]Finalize (Acc_Typ (V).all);
   --    end;

   ----------------------------
   -- Build_Array_Deep_Procs --
   ----------------------------

   procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
   begin
      Set_TSS (Typ,
        Make_Deep_Proc
          (Prim  => Initialize_Case,
           Typ   => Typ,
           Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));

      if not Is_Immutably_Limited_Type (Typ) then
         Set_TSS (Typ,
           Make_Deep_Proc
             (Prim  => Adjust_Case,
              Typ   => Typ,
              Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
      end if;

      --  Do not generate Deep_Finalize and Finalize_Address if finalization is
      --  suppressed since these routine will not be used.

      if not Restriction_Active (No_Finalization) then
         Set_TSS (Typ,
           Make_Deep_Proc
             (Prim  => Finalize_Case,
              Typ   => Typ,
              Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));

         --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
         --  .NET do not support address arithmetic and unchecked conversions.

         if VM_Target = No_VM then
            Set_TSS (Typ,
              Make_Deep_Proc
                (Prim  => Address_Case,
                 Typ   => Typ,
                 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
         end if;
      end if;
   end Build_Array_Deep_Procs;

   ------------------------------
   -- Build_Cleanup_Statements --
   ------------------------------

   function Build_Cleanup_Statements (N : Node_Id) return List_Id is
      Is_Asynchronous_Call : constant Boolean :=
                               Nkind (N) = N_Block_Statement
                                 and then Is_Asynchronous_Call_Block (N);
      Is_Master            : constant Boolean :=
                               Nkind (N) /= N_Entry_Body
                                 and then Is_Task_Master (N);
      Is_Protected_Body    : constant Boolean :=
                               Nkind (N) = N_Subprogram_Body
                                 and then Is_Protected_Subprogram_Body (N);
      Is_Task_Allocation   : constant Boolean :=
                               Nkind (N) = N_Block_Statement
                                 and then Is_Task_Allocation_Block (N);
      Is_Task_Body         : constant Boolean :=
                               Nkind (Original_Node (N)) = N_Task_Body;

      Loc   : constant Source_Ptr := Sloc (N);
      Stmts : constant List_Id    := New_List;

   begin
      if Is_Task_Body then
         if Restricted_Profile then
            Append_To (Stmts,
              Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
         else
            Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
         end if;

      elsif Is_Master then
         if Restriction_Active (No_Task_Hierarchy) = False then
            Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
         end if;

      --  Add statements to unlock the protected object parameter and to
      --  undefer abort. If the context is a protected procedure and the object
      --  has entries, call the entry service routine.

      --  NOTE: The generated code references _object, a parameter to the
      --  procedure.

      elsif Is_Protected_Body then
         declare
            Spec      : constant Node_Id := Parent (Corresponding_Spec (N));
            Conc_Typ  : Entity_Id;
            Nam       : Node_Id;
            Param     : Node_Id;
            Param_Typ : Entity_Id;

         begin
            --  Find the _object parameter representing the protected object

            Param := First (Parameter_Specifications (Spec));
            loop
               Param_Typ := Etype (Parameter_Type (Param));

               if Ekind (Param_Typ) = E_Record_Type then
                  Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
               end if;

               exit when No (Param) or else Present (Conc_Typ);
               Next (Param);
            end loop;

            pragma Assert (Present (Param));

            --  If the associated protected object has entries, a protected
            --  procedure has to service entry queues. In this case generate:

            --    Service_Entries (_object._object'Access);

            if Nkind (Specification (N)) = N_Procedure_Specification
              and then Has_Entries (Conc_Typ)
            then
               case Corresponding_Runtime_Package (Conc_Typ) is
                  when System_Tasking_Protected_Objects_Entries =>
                     Nam := New_Reference_To (RTE (RE_Service_Entries), Loc);

                  when System_Tasking_Protected_Objects_Single_Entry =>
                     Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);

                  when others =>
                     raise Program_Error;
               end case;

               Append_To (Stmts,
                 Make_Procedure_Call_Statement (Loc,
                   Name                   => Nam,
                   Parameter_Associations => New_List (
                     Make_Attribute_Reference (Loc,
                       Prefix         =>
                         Make_Selected_Component (Loc,
                           Prefix        => New_Reference_To (
                             Defining_Identifier (Param), Loc),
                           Selector_Name =>
                             Make_Identifier (Loc, Name_uObject)),
                       Attribute_Name => Name_Unchecked_Access))));

            else
               --  Generate:
               --    Unlock (_object._object'Access);

               case Corresponding_Runtime_Package (Conc_Typ) is
                  when System_Tasking_Protected_Objects_Entries =>
                     Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);

                  when System_Tasking_Protected_Objects_Single_Entry =>
                     Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);

                  when System_Tasking_Protected_Objects =>
                     Nam := New_Reference_To (RTE (RE_Unlock), Loc);

                  when others =>
                     raise Program_Error;
               end case;

               Append_To (Stmts,
                 Make_Procedure_Call_Statement (Loc,
                   Name                   => Nam,
                   Parameter_Associations => New_List (
                     Make_Attribute_Reference (Loc,
                       Prefix         =>
                         Make_Selected_Component (Loc,
                           Prefix        =>
                             New_Reference_To
                               (Defining_Identifier (Param), Loc),
                           Selector_Name =>
                             Make_Identifier (Loc, Name_uObject)),
                       Attribute_Name => Name_Unchecked_Access))));
            end if;

            --  Generate:
            --    Abort_Undefer;

            if Abort_Allowed then
               Append_To (Stmts,
                 Make_Procedure_Call_Statement (Loc,
                   Name                   =>
                     New_Reference_To (RTE (RE_Abort_Undefer), Loc),
                   Parameter_Associations => Empty_List));
            end if;
         end;

      --  Add a call to Expunge_Unactivated_Tasks for dynamically allocated
      --  tasks. Other unactivated tasks are completed by Complete_Task or
      --  Complete_Master.

      --  NOTE: The generated code references _chain, a local object

      elsif Is_Task_Allocation then

         --  Generate:
         --     Expunge_Unactivated_Tasks (_chain);

         --  where _chain is the list of tasks created by the allocator but not
         --  yet activated. This list will be empty unless the block completes
         --  abnormally.

         Append_To (Stmts,
           Make_Procedure_Call_Statement (Loc,
             Name =>
               New_Reference_To
                 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
             Parameter_Associations => New_List (
               New_Reference_To (Activation_Chain_Entity (N), Loc))));

      --  Attempt to cancel an asynchronous entry call whenever the block which
      --  contains the abortable part is exited.

      --  NOTE: The generated code references Cnn, a local object

      elsif Is_Asynchronous_Call then
         declare
            Cancel_Param : constant Entity_Id :=
                             Entry_Cancel_Parameter (Entity (Identifier (N)));

         begin
            --  If it is of type Communication_Block, this must be a protected
            --  entry call. Generate:

            --    if Enqueued (Cancel_Param) then
            --       Cancel_Protected_Entry_Call (Cancel_Param);
            --    end if;

            if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
               Append_To (Stmts,
                 Make_If_Statement (Loc,
                   Condition =>
                     Make_Function_Call (Loc,
                       Name                   =>
                         New_Reference_To (RTE (RE_Enqueued), Loc),
                       Parameter_Associations => New_List (
                         New_Reference_To (Cancel_Param, Loc))),

                   Then_Statements => New_List (
                     Make_Procedure_Call_Statement (Loc,
                       Name =>
                         New_Reference_To
                           (RTE (RE_Cancel_Protected_Entry_Call), Loc),
                         Parameter_Associations => New_List (
                           New_Reference_To (Cancel_Param, Loc))))));

            --  Asynchronous delay, generate:
            --    Cancel_Async_Delay (Cancel_Param);

            elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
               Append_To (Stmts,
                 Make_Procedure_Call_Statement (Loc,
                   Name                   =>
                     New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
                   Parameter_Associations => New_List (
                     Make_Attribute_Reference (Loc,
                       Prefix         =>
                         New_Reference_To (Cancel_Param, Loc),
                       Attribute_Name => Name_Unchecked_Access))));

            --  Task entry call, generate:
            --    Cancel_Task_Entry_Call (Cancel_Param);

            else
               Append_To (Stmts,
                 Make_Procedure_Call_Statement (Loc,
                   Name                   =>
                     New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc),
                   Parameter_Associations => New_List (
                     New_Reference_To (Cancel_Param, Loc))));
            end if;
         end;
      end if;

      return Stmts;
   end Build_Cleanup_Statements;

   -----------------------------
   -- Build_Controlling_Procs --
   -----------------------------

   procedure Build_Controlling_Procs (Typ : Entity_Id) is
   begin
      if Is_Array_Type (Typ) then
         Build_Array_Deep_Procs (Typ);
      else pragma Assert (Is_Record_Type (Typ));
         Build_Record_Deep_Procs (Typ);
      end if;
   end Build_Controlling_Procs;

   -----------------------------
   -- Build_Exception_Handler --
   -----------------------------

   function Build_Exception_Handler
     (Data        : Finalization_Exception_Data;
      For_Library : Boolean := False) return Node_Id
   is
      Actuals      : List_Id;
      Proc_To_Call : Entity_Id;

   begin
      pragma Assert (Present (Data.E_Id));
      pragma Assert (Present (Data.Raised_Id));

      --  Generate:
      --    Get_Current_Excep.all.all

      Actuals := New_List (
        Make_Explicit_Dereference (Data.Loc,
          Prefix =>
            Make_Function_Call (Data.Loc,
              Name =>
                Make_Explicit_Dereference (Data.Loc,
                  Prefix =>
                    New_Reference_To (RTE (RE_Get_Current_Excep),
                                      Data.Loc)))));

      if For_Library and then not Restricted_Profile then
         Proc_To_Call := RTE (RE_Save_Library_Occurrence);

      else
         Proc_To_Call := RTE (RE_Save_Occurrence);
         Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc));
      end if;

      --  Generate:
      --    when others =>
      --       if not Raised_Id then
      --          Raised_Id := True;

      --          Save_Occurrence (E_Id, Get_Current_Excep.all.all);
      --            or
      --          Save_Library_Occurrence (Get_Current_Excep.all.all);
      --       end if;

      return
        Make_Exception_Handler (Data.Loc,
          Exception_Choices =>
            New_List (Make_Others_Choice (Data.Loc)),
          Statements => New_List (
            Make_If_Statement (Data.Loc,
              Condition       =>
                Make_Op_Not (Data.Loc,
                  Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),

              Then_Statements => New_List (
                Make_Assignment_Statement (Data.Loc,
                  Name       => New_Reference_To (Data.Raised_Id, Data.Loc),
                  Expression => New_Reference_To (Standard_True, Data.Loc)),

                Make_Procedure_Call_Statement (Data.Loc,
                  Name                   =>
                    New_Reference_To (Proc_To_Call, Data.Loc),
                  Parameter_Associations => Actuals)))));
   end Build_Exception_Handler;

   -------------------------------
   -- Build_Finalization_Master --
   -------------------------------

   procedure Build_Finalization_Master
     (Typ        : Entity_Id;
      Ins_Node   : Node_Id := Empty;
      Encl_Scope : Entity_Id := Empty)
   is
      Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
      Ptr_Typ   : Entity_Id := Root_Type (Base_Type (Typ));

      function In_Deallocation_Instance (E : Entity_Id) return Boolean;
      --  Determine whether entity E is inside a wrapper package created for
      --  an instance of Ada.Unchecked_Deallocation.

      ------------------------------
      -- In_Deallocation_Instance --
      ------------------------------

      function In_Deallocation_Instance (E : Entity_Id) return Boolean is
         Pkg : constant Entity_Id := Scope (E);
         Par : Node_Id := Empty;

      begin
         if Ekind (Pkg) = E_Package
           and then Present (Related_Instance (Pkg))
           and then Ekind (Related_Instance (Pkg)) = E_Procedure
         then
            Par := Generic_Parent (Parent (Related_Instance (Pkg)));

            return
              Present (Par)
                and then Chars (Par) = Name_Unchecked_Deallocation
                and then Chars (Scope (Par)) = Name_Ada
                and then Scope (Scope (Par)) = Standard_Standard;
         end if;

         return False;
      end In_Deallocation_Instance;

   --  Start of processing for Build_Finalization_Master

   begin
      if Is_Private_Type (Ptr_Typ)
        and then Present (Full_View (Ptr_Typ))
      then
         Ptr_Typ := Full_View (Ptr_Typ);
      end if;

      --  Certain run-time configurations and targets do not provide support
      --  for controlled types.

      if Restriction_Active (No_Finalization) then
         return;

      --  Do not process C, C++, CIL and Java types since it is assumend that
      --  the non-Ada side will handle their clean up.

      elsif Convention (Desig_Typ) = Convention_C
        or else Convention (Desig_Typ) = Convention_CIL
        or else Convention (Desig_Typ) = Convention_CPP
        or else Convention (Desig_Typ) = Convention_Java
      then
         return;

      --  Various machinery such as freezing may have already created a
      --  finalization master.

      elsif Present (Finalization_Master (Ptr_Typ)) then
         return;

      --  Do not process types that return on the secondary stack

      elsif Present (Associated_Storage_Pool (Ptr_Typ))
        and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
      then
         return;

      --  Do not process types which may never allocate an object

      elsif No_Pool_Assigned (Ptr_Typ) then
         return;

      --  Do not process access types coming from Ada.Unchecked_Deallocation
      --  instances. Even though the designated type may be controlled, the
      --  access type will never participate in allocation.

      elsif In_Deallocation_Instance (Ptr_Typ) then
         return;

      --  Ignore the general use of anonymous access types unless the context
      --  requires a finalization master.

      elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
        and then No (Ins_Node)
      then
         return;

      --  Do not process non-library access types when restriction No_Nested_
      --  Finalization is in effect since masters are controlled objects.

      elsif Restriction_Active (No_Nested_Finalization)
        and then not Is_Library_Level_Entity (Ptr_Typ)
      then
         return;

      --  For .NET/JVM targets, allow the processing of access-to-controlled
      --  types where the designated type is explicitly derived from [Limited_]
      --  Controlled.

      elsif VM_Target /= No_VM
        and then not Is_Controlled (Desig_Typ)
      then
         return;

      --  Do not create finalization masters in Alfa mode because they result
      --  in unwanted expansion.

      elsif Alfa_Mode then
         return;
      end if;

      declare
         Loc        : constant Source_Ptr := Sloc (Ptr_Typ);
         Actions    : constant List_Id := New_List;
         Fin_Mas_Id : Entity_Id;
         Pool_Id    : Entity_Id;

      begin
         --  Generate:
         --    Fnn : aliased Finalization_Master;

         --  Source access types use fixed master names since the master is
         --  inserted in the same source unit only once. The only exception to
         --  this are instances using the same access type as generic actual.

         if Comes_From_Source (Ptr_Typ)
           and then not Inside_A_Generic
         then
            Fin_Mas_Id :=
              Make_Defining_Identifier (Loc,
                Chars => New_External_Name (Chars (Ptr_Typ), "FM"));

         --  Internally generated access types use temporaries as their names
         --  due to possible collision with identical names coming from other
         --  packages.

         else
            Fin_Mas_Id := Make_Temporary (Loc, 'F');
         end if;

         Append_To (Actions,
           Make_Object_Declaration (Loc,
             Defining_Identifier => Fin_Mas_Id,
             Aliased_Present     => True,
             Object_Definition   =>
               New_Reference_To (RTE (RE_Finalization_Master), Loc)));

         --  Storage pool selection and attribute decoration of the generated
         --  master. Since .NET/JVM compilers do not support pools, this step
         --  is skipped.

         if VM_Target = No_VM then

            --  If the access type has a user-defined pool, use it as the base
            --  storage medium for the finalization pool.

            if Present (Associated_Storage_Pool (Ptr_Typ)) then
               Pool_Id := Associated_Storage_Pool (Ptr_Typ);

            --  The default choice is the global pool

            else
               Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
               Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
            end if;

            --  Generate:
            --    Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);

            Append_To (Actions,
              Make_Procedure_Call_Statement (Loc,
                Name                   =>
                  New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
                Parameter_Associations => New_List (
                  New_Reference_To (Fin_Mas_Id, Loc),
                  Make_Attribute_Reference (Loc,
                    Prefix         => New_Reference_To (Pool_Id, Loc),
                    Attribute_Name => Name_Unrestricted_Access))));
         end if;

         Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);

         --  A finalization master created for an anonymous access type must be
         --  inserted before a context-dependent node.

         if Present (Ins_Node) then
            Push_Scope (Encl_Scope);

            --  Treat use clauses as declarations and insert directly in front
            --  of them.

            if Nkind_In (Ins_Node, N_Use_Package_Clause,
                                   N_Use_Type_Clause)
            then
               Insert_List_Before_And_Analyze (Ins_Node, Actions);
            else
               Insert_Actions (Ins_Node, Actions);
            end if;

            Pop_Scope;

         elsif Ekind (Desig_Typ) = E_Incomplete_Type
           and then Has_Completion_In_Body (Desig_Typ)
         then
            Insert_Actions (Parent (Ptr_Typ), Actions);

         --  If the designated type is not yet frozen, then append the actions
         --  to that type's freeze actions. The actions need to be appended to
         --  whichever type is frozen later, similarly to what Freeze_Type does
         --  for appending the storage pool declaration for an access type.
         --  Otherwise, the call to Set_Storage_Pool_Ptr might reference the
         --  pool object before it's declared. However, it's not clear that
         --  this is exactly the right test to accomplish that here. ???

         elsif Present (Freeze_Node (Desig_Typ))
           and then not Analyzed (Freeze_Node (Desig_Typ))
         then
            Append_Freeze_Actions (Desig_Typ, Actions);

         elsif Present (Freeze_Node (Ptr_Typ))
           and then not Analyzed (Freeze_Node (Ptr_Typ))
         then
            Append_Freeze_Actions (Ptr_Typ, Actions);

         --  If there's a pool created locally for the access type, then we
         --  need to ensure that the master gets created after the pool object,
         --  because otherwise we can have a forward reference, so we force the
         --  master actions to be inserted and analyzed after the pool entity.
         --  Note that both the access type and its designated type may have
         --  already been frozen and had their freezing actions analyzed at
         --  this point. (This seems a little unclean.???)

         elsif VM_Target = No_VM
           and then Scope (Pool_Id) = Scope (Ptr_Typ)
         then
            Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);

         else
            Insert_Actions (Parent (Ptr_Typ), Actions);
         end if;
      end;
   end Build_Finalization_Master;

   ---------------------
   -- Build_Finalizer --
   ---------------------

   procedure Build_Finalizer
     (N           : Node_Id;
      Clean_Stmts : List_Id;
      Mark_Id     : Entity_Id;
      Top_Decls   : List_Id;
      Defer_Abort : Boolean;
      Fin_Id      : out Entity_Id)
   is
      Acts_As_Clean    : constant Boolean :=
                           Present (Mark_Id)
                             or else
                               (Present (Clean_Stmts)
                                 and then Is_Non_Empty_List (Clean_Stmts));
      Exceptions_OK    : constant Boolean :=
                           not Restriction_Active (No_Exception_Propagation);
      For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
      For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
      For_Package      : constant Boolean :=
                           For_Package_Body or else For_Package_Spec;
      Loc              : constant Source_Ptr := Sloc (N);

      --  NOTE: Local variable declarations are conservative and do not create
      --  structures right from the start. Entities and lists are created once
      --  it has been established that N has at least one controlled object.

      Components_Built : Boolean := False;
      --  A flag used to avoid double initialization of entities and lists. If
      --  the flag is set then the following variables have been initialized:
      --    Counter_Id
      --    Finalizer_Decls
      --    Finalizer_Stmts
      --    Jump_Alts

      Counter_Id  : Entity_Id := Empty;
      Counter_Val : Int       := 0;
      --  Name and value of the state counter

      Decls : List_Id := No_List;
      --  Declarative region of N (if available). If N is a package declaration
      --  Decls denotes the visible declarations.

      Finalizer_Data : Finalization_Exception_Data;
      --  Data for the exception

      Finalizer_Decls : List_Id := No_List;
      --  Local variable declarations. This list holds the label declarations
      --  of all jump block alternatives as well as the declaration of the
      --  local exception occurence and the raised flag:
      --     E : Exception_Occurrence;
      --     Raised : Boolean := False;
      --     L<counter value> : label;

      Finalizer_Insert_Nod : Node_Id := Empty;
      --  Insertion point for the finalizer body. Depending on the context
      --  (Nkind of N) and the individual grouping of controlled objects, this
      --  node may denote a package declaration or body, package instantiation,
      --  block statement or a counter update statement.

      Finalizer_Stmts : List_Id := No_List;
      --  The statement list of the finalizer body. It contains the following:
      --
      --    Abort_Defer;               --  Added if abort is allowed
      --    <call to Prev_At_End>      --  Added if exists
      --    <cleanup statements>       --  Added if Acts_As_Clean
      --    <jump block>               --  Added if Has_Ctrl_Objs
      --    <finalization statements>  --  Added if Has_Ctrl_Objs
      --    <stack release>            --  Added if Mark_Id exists
      --    Abort_Undefer;             --  Added if abort is allowed

      Has_Ctrl_Objs : Boolean := False;
      --  A general flag which denotes whether N has at least one controlled
      --  object.

      Has_Tagged_Types : Boolean := False;
      --  A general flag which indicates whether N has at least one library-
      --  level tagged type declaration.

      HSS : Node_Id := Empty;
      --  The sequence of statements of N (if available)

      Jump_Alts : List_Id := No_List;
      --  Jump block alternatives. Depending on the value of the state counter,
      --  the control flow jumps to a sequence of finalization statements. This
      --  list contains the following:
      --
      --     when <counter value> =>
      --        goto L<counter value>;

      Jump_Block_Insert_Nod : Node_Id := Empty;
      --  Specific point in the finalizer statements where the jump block is
      --  inserted.

      Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
      --  The last controlled construct encountered when processing the top
      --  level lists of N. This can be a nested package, an instantiation or
      --  an object declaration.

      Prev_At_End : Entity_Id := Empty;
      --  The previous at end procedure of the handled statements block of N

      Priv_Decls : List_Id := No_List;
      --  The private declarations of N if N is a package declaration

      Spec_Id    : Entity_Id := Empty;
      Spec_Decls : List_Id   := Top_Decls;
      Stmts      : List_Id   := No_List;

      Tagged_Type_Stmts : List_Id := No_List;
      --  Contains calls to Ada.Tags.Unregister_Tag for all library-level
      --  tagged types found in N.

      -----------------------
      -- Local subprograms --
      -----------------------

      procedure Build_Components;
      --  Create all entites and initialize all lists used in the creation of
      --  the finalizer.

      procedure Create_Finalizer;
      --  Create the spec and body of the finalizer and insert them in the
      --  proper place in the tree depending on the context.

      procedure Process_Declarations
        (Decls      : List_Id;
         Preprocess : Boolean := False;
         Top_Level  : Boolean := False);
      --  Inspect a list of declarations or statements which may contain
      --  objects that need finalization. When flag Preprocess is set, the
      --  routine will simply count the total number of controlled objects in
      --  Decls. Flag Top_Level denotes whether the processing is done for
      --  objects in nested package declarations or instances.

      procedure Process_Object_Declaration
        (Decl         : Node_Id;
         Has_No_Init  : Boolean := False;
         Is_Protected : Boolean := False);
      --  Generate all the machinery associated with the finalization of a
      --  single object. Flag Has_No_Init is used to denote certain contexts
      --  where Decl does not have initialization call(s). Flag Is_Protected
      --  is set when Decl denotes a simple protected object.

      procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
      --  Generate all the code necessary to unregister the external tag of a
      --  tagged type.

      ----------------------
      -- Build_Components --
      ----------------------

      procedure Build_Components is
         Counter_Decl     : Node_Id;
         Counter_Typ      : Entity_Id;
         Counter_Typ_Decl : Node_Id;

      begin
         pragma Assert (Present (Decls));

         --  This routine might be invoked several times when dealing with
         --  constructs that have two lists (either two declarative regions
         --  or declarations and statements). Avoid double initialization.

         if Components_Built then
            return;
         end if;

         Components_Built := True;

         if Has_Ctrl_Objs then

            --  Create entities for the counter, its type, the local exception
            --  and the raised flag.

            Counter_Id  := Make_Temporary (Loc, 'C');
            Counter_Typ := Make_Temporary (Loc, 'T');

            Finalizer_Decls := New_List;

            Build_Object_Declarations
              (Finalizer_Data, Finalizer_Decls, Loc, For_Package);

            --  Since the total number of controlled objects is always known,
            --  build a subtype of Natural with precise bounds. This allows
            --  the backend to optimize the case statement. Generate:
            --
            --    subtype Tnn is Natural range 0 .. Counter_Val;

            Counter_Typ_Decl :=
              Make_Subtype_Declaration (Loc,
                Defining_Identifier => Counter_Typ,
                Subtype_Indication  =>
                  Make_Subtype_Indication (Loc,
                    Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
                    Constraint   =>
                      Make_Range_Constraint (Loc,
                        Range_Expression =>
                          Make_Range (Loc,
                            Low_Bound  =>
                              Make_Integer_Literal (Loc, Uint_0),
                            High_Bound =>
                              Make_Integer_Literal (Loc, Counter_Val)))));

            --  Generate the declaration of the counter itself:
            --
            --    Counter : Integer := 0;

            Counter_Decl :=
              Make_Object_Declaration (Loc,
                Defining_Identifier => Counter_Id,
                Object_Definition   => New_Reference_To (Counter_Typ, Loc),
                Expression          => Make_Integer_Literal (Loc, 0));

            --  Set the type of the counter explicitly to prevent errors when
            --  examining object declarations later on.

            Set_Etype (Counter_Id, Counter_Typ);

            --  The counter and its type are inserted before the source
            --  declarations of N.

            Prepend_To (Decls, Counter_Decl);
            Prepend_To (Decls, Counter_Typ_Decl);

            --  The counter and its associated type must be manually analized
            --  since N has already been analyzed. Use the scope of the spec
            --  when inserting in a package.

            if For_Package then
               Push_Scope (Spec_Id);
               Analyze (Counter_Typ_Decl);
               Analyze (Counter_Decl);
               Pop_Scope;

            else
               Analyze (Counter_Typ_Decl);
               Analyze (Counter_Decl);
            end if;

            Jump_Alts := New_List;
         end if;

         --  If the context requires additional clean up, the finalization
         --  machinery is added after the clean up code.

         if Acts_As_Clean then
            Finalizer_Stmts       := Clean_Stmts;
            Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
         else
            Finalizer_Stmts := New_List;
         end if;

         if Has_Tagged_Types then
            Tagged_Type_Stmts := New_List;
         end if;
      end Build_Components;

      ----------------------
      -- Create_Finalizer --
      ----------------------

      procedure Create_Finalizer is
         Body_Id    : Entity_Id;
         Fin_Body   : Node_Id;
         Fin_Spec   : Node_Id;
         Jump_Block : Node_Id;
         Label      : Node_Id;
         Label_Id   : Entity_Id;

         function New_Finalizer_Name return Name_Id;
         --  Create a fully qualified name of a package spec or body finalizer.
         --  The generated name is of the form: xx__yy__finalize_[spec|body].

         ------------------------
         -- New_Finalizer_Name --
         ------------------------

         function New_Finalizer_Name return Name_Id is
            procedure New_Finalizer_Name (Id : Entity_Id);
            --  Place "__<name-of-Id>" in the name buffer. If the identifier
            --  has a non-standard scope, process the scope first.

            ------------------------
            -- New_Finalizer_Name --
            ------------------------

            procedure New_Finalizer_Name (Id : Entity_Id) is
            begin
               if Scope (Id) = Standard_Standard then
                  Get_Name_String (Chars (Id));

               else
                  New_Finalizer_Name (Scope (Id));
                  Add_Str_To_Name_Buffer ("__");
                  Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
               end if;
            end New_Finalizer_Name;

         --  Start of processing for New_Finalizer_Name

         begin
            --  Create the fully qualified name of the enclosing scope

            New_Finalizer_Name (Spec_Id);

            --  Generate:
            --    __finalize_[spec|body]

            Add_Str_To_Name_Buffer ("__finalize_");

            if For_Package_Spec then
               Add_Str_To_Name_Buffer ("spec");
            else
               Add_Str_To_Name_Buffer ("body");
            end if;

            return Name_Find;
         end New_Finalizer_Name;

      --  Start of processing for Create_Finalizer

      begin
         --  Step 1: Creation of the finalizer name

         --  Packages must use a distinct name for their finalizers since the
         --  binder will have to generate calls to them by name. The name is
         --  of the following form:

         --    xx__yy__finalize_[spec|body]

         if For_Package then
            Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
            Set_Has_Qualified_Name       (Fin_Id);
            Set_Has_Fully_Qualified_Name (Fin_Id);

         --  The default name is _finalizer

         else
            Fin_Id :=
              Make_Defining_Identifier (Loc,
                Chars => New_External_Name (Name_uFinalizer));

            --  The visibility semantics of AT_END handlers force a strange
            --  separation of spec and body for stack-related finalizers:

            --     declare : Enclosing_Scope
            --        procedure _finalizer;
            --     begin
            --        <controlled objects>
            --        procedure _finalizer is
            --           ...
            --     at end
            --        _finalizer;
            --     end;

            --  Both spec and body are within the same construct and scope, but
            --  the body is part of the handled sequence of statements. This
            --  placement confuses the elaboration mechanism on targets where
            --  AT_END handlers are expanded into "when all others" handlers:

            --     exception
            --        when all others =>
            --           _finalizer;  --  appears to require elab checks
            --     at end
            --        _finalizer;
            --     end;

            --  Since the compiler guarantees that the body of a _finalizer is
            --  always inserted in the same construct where the AT_END handler
            --  resides, there is no need for elaboration checks.

            Set_Kill_Elaboration_Checks (Fin_Id);
         end if;

         --  Step 2: Creation of the finalizer specification

         --  Generate:
         --    procedure Fin_Id;

         Fin_Spec :=
           Make_Subprogram_Declaration (Loc,
             Specification =>
               Make_Procedure_Specification (Loc,
                 Defining_Unit_Name => Fin_Id));

         --  Step 3: Creation of the finalizer body

         if Has_Ctrl_Objs then

            --  Add L0, the default destination to the jump block

            Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
            Set_Entity (Label_Id,
              Make_Defining_Identifier (Loc, Chars (Label_Id)));
            Label := Make_Label (Loc, Label_Id);

            --  Generate:
            --    L0 : label;

            Prepend_To (Finalizer_Decls,
              Make_Implicit_Label_Declaration (Loc,
                Defining_Identifier => Entity (Label_Id),
                Label_Construct     => Label));

            --  Generate:
            --    when others =>
            --       goto L0;

            Append_To (Jump_Alts,
              Make_Case_Statement_Alternative (Loc,
                Discrete_Choices => New_List (Make_Others_Choice (Loc)),
                Statements       => New_List (
                  Make_Goto_Statement (Loc,
                    Name => New_Reference_To (Entity (Label_Id), Loc)))));

            --  Generate:
            --    <<L0>>

            Append_To (Finalizer_Stmts, Label);

            --  The local exception does not need to be reraised for library-
            --  level finalizers. Generate:
            --
            --    if Raised and then not Abort then
            --       Raise_From_Controlled_Operation (E);
            --    end if;

            if not For_Package
              and then Exceptions_OK
            then
               Append_To (Finalizer_Stmts,
                 Build_Raise_Statement (Finalizer_Data));
            end if;

            --  Create the jump block which controls the finalization flow
            --  depending on the value of the state counter.

            Jump_Block :=
              Make_Case_Statement (Loc,
                Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
                Alternatives => Jump_Alts);

            if Acts_As_Clean
              and then Present (Jump_Block_Insert_Nod)
            then
               Insert_After (Jump_Block_Insert_Nod, Jump_Block);
            else
               Prepend_To (Finalizer_Stmts, Jump_Block);
            end if;
         end if;

         --  Add the library-level tagged type unregistration machinery before
         --  the jump block circuitry. This ensures that external tags will be
         --  removed even if a finalization exception occurs at some point.

         if Has_Tagged_Types then
            Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
         end if;

         --  Add a call to the previous At_End handler if it exists. The call
         --  must always precede the jump block.

         if Present (Prev_At_End) then
            Prepend_To (Finalizer_Stmts,
              Make_Procedure_Call_Statement (Loc, Prev_At_End));

            --  Clear the At_End handler since we have already generated the
            --  proper replacement call for it.

            Set_At_End_Proc (HSS, Empty);
         end if;

         --  Release the secondary stack mark

         if Present (Mark_Id) then
            Append_To (Finalizer_Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name                   =>
                  New_Reference_To (RTE (RE_SS_Release), Loc),
                Parameter_Associations => New_List (
                  New_Reference_To (Mark_Id, Loc))));
         end if;

         --  Protect the statements with abort defer/undefer. This is only when
         --  aborts are allowed and the clean up statements require deferral or
         --  there are controlled objects to be finalized.

         if Abort_Allowed
           and then
             (Defer_Abort or else Has_Ctrl_Objs)
         then
            Prepend_To (Finalizer_Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name => New_Reference_To (RTE (RE_Abort_Defer), Loc)));

            Append_To (Finalizer_Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
         end if;

         --  Generate:
         --    procedure Fin_Id is
         --       Abort  : constant Boolean := Triggered_By_Abort;
         --         <or>
         --       Abort  : constant Boolean := False;  --  no abort

         --       E      : Exception_Occurrence;  --  All added if flag
         --       Raised : Boolean := False;      --  Has_Ctrl_Objs is set
         --       L0     : label;
         --       ...
         --       Lnn    : label;

         --    begin
         --       Abort_Defer;               --  Added if abort is allowed
         --       <call to Prev_At_End>      --  Added if exists
         --       <cleanup statements>       --  Added if Acts_As_Clean
         --       <jump block>               --  Added if Has_Ctrl_Objs
         --       <finalization statements>  --  Added if Has_Ctrl_Objs
         --       <stack release>            --  Added if Mark_Id exists
         --       Abort_Undefer;             --  Added if abort is allowed
         --    end Fin_Id;

         --  Create the body of the finalizer

         Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));

         if For_Package then
            Set_Has_Qualified_Name       (Body_Id);
            Set_Has_Fully_Qualified_Name (Body_Id);
         end if;

         Fin_Body :=
           Make_Subprogram_Body (Loc,
             Specification              =>
               Make_Procedure_Specification (Loc,
                 Defining_Unit_Name => Body_Id),
             Declarations               => Finalizer_Decls,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));

         --  Step 4: Spec and body insertion, analysis

         if For_Package then

            --  If the package spec has private declarations, the finalizer
            --  body must be added to the end of the list in order to have
            --  visibility of all private controlled objects.

            if For_Package_Spec then
               if Present (Priv_Decls) then
                  Append_To (Priv_Decls, Fin_Spec);
                  Append_To (Priv_Decls, Fin_Body);
               else
                  Append_To (Decls, Fin_Spec);
                  Append_To (Decls, Fin_Body);
               end if;

            --  For package bodies, both the finalizer spec and body are
            --  inserted at the end of the package declarations.

            else
               Append_To (Decls, Fin_Spec);
               Append_To (Decls, Fin_Body);
            end if;

            --  Push the name of the package

            Push_Scope (Spec_Id);
            Analyze (Fin_Spec);
            Analyze (Fin_Body);
            Pop_Scope;

         --  Non-package case

         else
            --  Create the spec for the finalizer. The At_End handler must be
            --  able to call the body which resides in a nested structure.

            --  Generate:
            --    declare
            --       procedure Fin_Id;                  --  Spec
            --    begin
            --       <objects and possibly statements>
            --       procedure Fin_Id is ...            --  Body
            --       <statements>
            --    at end
            --       Fin_Id;                            --  At_End handler
            --    end;

            pragma Assert (Present (Spec_Decls));

            Append_To (Spec_Decls, Fin_Spec);
            Analyze (Fin_Spec);

            --  When the finalizer acts solely as a clean up routine, the body
            --  is inserted right after the spec.

            if Acts_As_Clean
              and then not Has_Ctrl_Objs
            then
               Insert_After (Fin_Spec, Fin_Body);

            --  In all other cases the body is inserted after either:
            --
            --    1) The counter update statement of the last controlled object
            --    2) The last top level nested controlled package
            --    3) The last top level controlled instantiation

            else
               --  Manually freeze the spec. This is somewhat of a hack because
               --  a subprogram is frozen when its body is seen and the freeze
               --  node appears right before the body. However, in this case,
               --  the spec must be frozen earlier since the At_End handler
               --  must be able to call it.
               --
               --    declare
               --       procedure Fin_Id;               --  Spec
               --       [Fin_Id]                        --  Freeze node
               --    begin
               --       ...
               --    at end
               --       Fin_Id;                         --  At_End handler
               --    end;

               Ensure_Freeze_Node (Fin_Id);
               Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
               Set_Is_Frozen (Fin_Id);

               --  In the case where the last construct to contain a controlled
               --  object is either a nested package, an instantiation or a
               --  freeze node, the body must be inserted directly after the
               --  construct.

               if Nkind_In (Last_Top_Level_Ctrl_Construct,
                              N_Freeze_Entity,
                              N_Package_Declaration,
                              N_Package_Body)
               then
                  Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
               end if;

               Insert_After (Finalizer_Insert_Nod, Fin_Body);
            end if;

            Analyze (Fin_Body);
         end if;
      end Create_Finalizer;

      --------------------------
      -- Process_Declarations --
      --------------------------

      procedure Process_Declarations
        (Decls      : List_Id;
         Preprocess : Boolean := False;
         Top_Level  : Boolean := False)
      is
         Decl    : Node_Id;
         Expr    : Node_Id;
         Obj_Id  : Entity_Id;
         Obj_Typ : Entity_Id;
         Pack_Id : Entity_Id;
         Spec    : Node_Id;
         Typ     : Entity_Id;

         Old_Counter_Val : Int;
         --  This variable is used to determine whether a nested package or
         --  instance contains at least one controlled object.

         procedure Processing_Actions
           (Has_No_Init  : Boolean := False;
            Is_Protected : Boolean := False);
         --  Depending on the mode of operation of Process_Declarations, either
         --  increment the controlled object counter, set the controlled object
         --  flag and store the last top level construct or process the current
         --  declaration. Flag Has_No_Init is used to propagate scenarios where
         --  the current declaration may not have initialization proc(s). Flag
         --  Is_Protected should be set when the current declaration denotes a
         --  simple protected object.

         ------------------------
         -- Processing_Actions --
         ------------------------

         procedure Processing_Actions
           (Has_No_Init  : Boolean := False;
            Is_Protected : Boolean := False)
         is
         begin
            --  Library-level tagged type

            if Nkind (Decl) = N_Full_Type_Declaration then
               if Preprocess then
                  Has_Tagged_Types := True;

                  if Top_Level
                    and then No (Last_Top_Level_Ctrl_Construct)
                  then
                     Last_Top_Level_Ctrl_Construct := Decl;
                  end if;

               else
                  Process_Tagged_Type_Declaration (Decl);
               end if;

            --  Controlled object declaration

            else
               if Preprocess then
                  Counter_Val   := Counter_Val + 1;
                  Has_Ctrl_Objs := True;

                  if Top_Level
                    and then No (Last_Top_Level_Ctrl_Construct)
                  then
                     Last_Top_Level_Ctrl_Construct := Decl;
                  end if;

               else
                  Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
               end if;
            end if;
         end Processing_Actions;

      --  Start of processing for Process_Declarations

      begin
         if No (Decls) or else Is_Empty_List (Decls) then
            return;
         end if;

         --  Process all declarations in reverse order

         Decl := Last_Non_Pragma (Decls);
         while Present (Decl) loop

            --  Library-level tagged types

            if Nkind (Decl) = N_Full_Type_Declaration then
               Typ := Defining_Identifier (Decl);

               if Is_Tagged_Type (Typ)
                 and then Is_Library_Level_Entity (Typ)
                 and then Convention (Typ) = Convention_Ada
                 and then Present (Access_Disp_Table (Typ))
                 and then RTE_Available (RE_Register_Tag)
                 and then not No_Run_Time_Mode
                 and then not Is_Abstract_Type (Typ)
               then
                  Processing_Actions;
               end if;

            --  Regular object declarations

            elsif Nkind (Decl) = N_Object_Declaration then
               Obj_Id  := Defining_Identifier (Decl);
               Obj_Typ := Base_Type (Etype (Obj_Id));
               Expr    := Expression (Decl);

               --  Bypass any form of processing for objects which have their
               --  finalization disabled. This applies only to objects at the
               --  library level.

               if For_Package
                 and then Finalize_Storage_Only (Obj_Typ)
               then
                  null;

               --  Transient variables are treated separately in order to
               --  minimize the size of the generated code. For details, see
               --  Process_Transient_Objects.

               elsif Is_Processed_Transient (Obj_Id) then
                  null;

               --  The object is of the form:
               --    Obj : Typ [:= Expr];

               --  Do not process the incomplete view of a deferred constant.
               --  Do not consider tag-to-class-wide conversions.

               elsif not Is_Imported (Obj_Id)
                 and then Needs_Finalization (Obj_Typ)
                 and then not (Ekind (Obj_Id) = E_Constant
                                and then not Has_Completion (Obj_Id))
                 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
               then
                  Processing_Actions;

               --  The object is of the form:
               --    Obj : Access_Typ := Non_BIP_Function_Call'reference;

               --    Obj : Access_Typ :=
               --            BIP_Function_Call
               --              (..., BIPaccess => null, ...)'reference;

               elsif Is_Access_Type (Obj_Typ)
                 and then Needs_Finalization
                            (Available_View (Designated_Type (Obj_Typ)))
                 and then Present (Expr)
                 and then
                   (Is_Null_Access_BIP_Func_Call (Expr)
                     or else
                       (Is_Non_BIP_Func_Call (Expr)
                         and then not Is_Related_To_Func_Return (Obj_Id)))
               then
                  Processing_Actions (Has_No_Init => True);

               --  Processing for "hook" objects generated for controlled
               --  transients declared inside an Expression_With_Actions.

               elsif Is_Access_Type (Obj_Typ)
                 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
                 and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
                                   N_Object_Declaration
                 and then Is_Finalizable_Transient
                            (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
               then
                  Processing_Actions (Has_No_Init => True);

               --  Simple protected objects which use type System.Tasking.
               --  Protected_Objects.Protection to manage their locks should
               --  be treated as controlled since they require manual cleanup.
               --  The only exception is illustrated in the following example:

               --     package Pkg is
               --        type Ctrl is new Controlled ...
               --        procedure Finalize (Obj : in out Ctrl);
               --        Lib_Obj : Ctrl;
               --     end Pkg;

               --     package body Pkg is
               --        protected Prot is
               --           procedure Do_Something (Obj : in out Ctrl);
               --        end Prot;

               --        protected body Prot is
               --           procedure Do_Something (Obj : in out Ctrl) is ...
               --        end Prot;

               --        procedure Finalize (Obj : in out Ctrl) is
               --        begin
               --           Prot.Do_Something (Obj);
               --        end Finalize;
               --     end Pkg;

               --  Since for the most part entities in package bodies depend on
               --  those in package specs, Prot's lock should be cleaned up
               --  first. The subsequent cleanup of the spec finalizes Lib_Obj.
               --  This act however attempts to invoke Do_Something and fails
               --  because the lock has disappeared.

               elsif Ekind (Obj_Id) = E_Variable
                 and then not In_Library_Level_Package_Body (Obj_Id)
                 and then
                   (Is_Simple_Protected_Type (Obj_Typ)
                     or else Has_Simple_Protected_Object (Obj_Typ))
               then
                  Processing_Actions (Is_Protected => True);
               end if;

            --  Specific cases of object renamings

            elsif Nkind (Decl) = N_Object_Renaming_Declaration then
               Obj_Id  := Defining_Identifier (Decl);
               Obj_Typ := Base_Type (Etype (Obj_Id));

               --  Bypass any form of processing for objects which have their
               --  finalization disabled. This applies only to objects at the
               --  library level.

               if For_Package
                 and then Finalize_Storage_Only (Obj_Typ)
               then
                  null;

               --  Return object of a build-in-place function. This case is
               --  recognized and marked by the expansion of an extended return
               --  statement (see Expand_N_Extended_Return_Statement).

               elsif Needs_Finalization (Obj_Typ)
                 and then Is_Return_Object (Obj_Id)
                 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
               then
                  Processing_Actions (Has_No_Init => True);

               --  Detect a case where a source object has been initialized by
               --  a controlled function call which was later rewritten as a
               --  class-wide conversion of Ada.Tags.Displace.

               --     Obj : Class_Wide_Type := Function_Call (...);

               --     Temp : ... := Function_Call (...)'reference;
               --     Obj  : Class_Wide_Type renames
               --              (... Ada.Tags.Displace (Temp));

               elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
                  Processing_Actions (Has_No_Init => True);
               end if;

            --  Inspect the freeze node of an access-to-controlled type and
            --  look for a delayed finalization master. This case arises when
            --  the freeze actions are inserted at a later time than the
            --  expansion of the context. Since Build_Finalizer is never called
            --  on a single construct twice, the master will be ultimately
            --  left out and never finalized. This is also needed for freeze
            --  actions of designated types themselves, since in some cases the
            --  finalization master is associated with a designated type's
            --  freeze node rather than that of the access type (see handling
            --  for freeze actions in Build_Finalization_Master).

            elsif Nkind (Decl) = N_Freeze_Entity
              and then Present (Actions (Decl))
            then
               Typ := Entity (Decl);

               if (Is_Access_Type (Typ)
                    and then not Is_Access_Subprogram_Type (Typ)
                    and then Needs_Finalization
                               (Available_View (Designated_Type (Typ))))
                 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
               then
                  Old_Counter_Val := Counter_Val;

                  --  Freeze nodes are considered to be identical to packages
                  --  and blocks in terms of nesting. The difference is that
                  --  a finalization master created inside the freeze node is
                  --  at the same nesting level as the node itself.

                  Process_Declarations (Actions (Decl), Preprocess);

                  --  The freeze node contains a finalization master

                  if Preprocess
                    and then Top_Level
                    and then No (Last_Top_Level_Ctrl_Construct)
                    and then Counter_Val > Old_Counter_Val
                  then
                     Last_Top_Level_Ctrl_Construct := Decl;
                  end if;
               end if;

            --  Nested package declarations, avoid generics

            elsif Nkind (Decl) = N_Package_Declaration then
               Spec    := Specification (Decl);
               Pack_Id := Defining_Unit_Name (Spec);

               if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
                  Pack_Id := Defining_Identifier (Pack_Id);
               end if;

               if Ekind (Pack_Id) /= E_Generic_Package then
                  Old_Counter_Val := Counter_Val;
                  Process_Declarations
                    (Private_Declarations (Spec), Preprocess);
                  Process_Declarations
                    (Visible_Declarations (Spec), Preprocess);

                  --  Either the visible or the private declarations contain a
                  --  controlled object. The nested package declaration is the
                  --  last such construct.

                  if Preprocess
                    and then Top_Level
                    and then No (Last_Top_Level_Ctrl_Construct)
                    and then Counter_Val > Old_Counter_Val
                  then
                     Last_Top_Level_Ctrl_Construct := Decl;
                  end if;
               end if;

            --  Nested package bodies, avoid generics

            elsif Nkind (Decl) = N_Package_Body then
               Spec := Corresponding_Spec (Decl);

               if Ekind (Spec) /= E_Generic_Package then
                  Old_Counter_Val := Counter_Val;
                  Process_Declarations (Declarations (Decl), Preprocess);

                  --  The nested package body is the last construct to contain
                  --  a controlled object.

                  if Preprocess
                    and then Top_Level
                    and then No (Last_Top_Level_Ctrl_Construct)
                    and then Counter_Val > Old_Counter_Val
                  then
                     Last_Top_Level_Ctrl_Construct := Decl;
                  end if;
               end if;

            --  Handle a rare case caused by a controlled transient variable
            --  created as part of a record init proc. The variable is wrapped
            --  in a block, but the block is not associated with a transient
            --  scope.

            elsif Nkind (Decl) = N_Block_Statement
              and then Inside_Init_Proc
            then
               Old_Counter_Val := Counter_Val;

               if Present (Handled_Statement_Sequence (Decl)) then
                  Process_Declarations
                    (Statements (Handled_Statement_Sequence (Decl)),
                     Preprocess);
               end if;

               Process_Declarations (Declarations (Decl), Preprocess);

               --  Either the declaration or statement list of the block has a
               --  controlled object.

               if Preprocess
                 and then Top_Level
                 and then No (Last_Top_Level_Ctrl_Construct)
                 and then Counter_Val > Old_Counter_Val
               then
                  Last_Top_Level_Ctrl_Construct := Decl;
               end if;
            end if;

            Prev_Non_Pragma (Decl);
         end loop;
      end Process_Declarations;

      --------------------------------
      -- Process_Object_Declaration --
      --------------------------------

      procedure Process_Object_Declaration
        (Decl         : Node_Id;
         Has_No_Init  : Boolean := False;
         Is_Protected : Boolean := False)
      is
         Obj_Id    : constant Entity_Id := Defining_Identifier (Decl);
         Loc       : constant Source_Ptr := Sloc (Decl);
         Body_Ins  : Node_Id;
         Count_Ins : Node_Id;
         Fin_Call  : Node_Id;
         Fin_Stmts : List_Id;
         Inc_Decl  : Node_Id;
         Label     : Node_Id;
         Label_Id  : Entity_Id;
         Obj_Ref   : Node_Id;
         Obj_Typ   : Entity_Id;

         function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
         --  Once it has been established that the current object is in fact a
         --  return object of build-in-place function Func_Id, generate the
         --  following cleanup code:
         --
         --    if BIPallocfrom > Secondary_Stack'Pos
         --      and then BIPfinalizationmaster /= null
         --    then
         --       declare
         --          type Ptr_Typ is access Obj_Typ;
         --          for Ptr_Typ'Storage_Pool
         --            use Base_Pool (BIPfinalizationmaster);
         --       begin
         --          Free (Ptr_Typ (Temp));
         --       end;
         --    end if;
         --
         --  Obj_Typ is the type of the current object, Temp is the original
         --  allocation which Obj_Id renames.

         procedure Find_Last_Init
           (Decl        : Node_Id;
            Typ         : Entity_Id;
            Last_Init   : out Node_Id;
            Body_Insert : out Node_Id);
         --  An object declaration has at least one and at most two init calls:
         --  that of the type and the user-defined initialize. Given an object
         --  declaration, Last_Init denotes the last initialization call which
         --  follows the declaration. Body_Insert denotes the place where the
         --  finalizer body could be potentially inserted.

         -----------------------------
         -- Build_BIP_Cleanup_Stmts --
         -----------------------------

         function Build_BIP_Cleanup_Stmts
           (Func_Id : Entity_Id) return Node_Id
         is
            Decls      : constant List_Id := New_List;
            Fin_Mas_Id : constant Entity_Id :=
                           Build_In_Place_Formal
                             (Func_Id, BIP_Finalization_Master);
            Obj_Typ    : constant Entity_Id := Etype (Func_Id);
            Temp_Id    : constant Entity_Id :=
                           Entity (Prefix (Name (Parent (Obj_Id))));

            Cond      : Node_Id;
            Free_Blk  : Node_Id;
            Free_Stmt : Node_Id;
            Pool_Id   : Entity_Id;
            Ptr_Typ   : Entity_Id;

         begin
            --  Generate:
            --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;

            Pool_Id := Make_Temporary (Loc, 'P');

            Append_To (Decls,
              Make_Object_Renaming_Declaration (Loc,
                Defining_Identifier => Pool_Id,
                Subtype_Mark        =>
                  New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
                Name                =>
                  Make_Explicit_Dereference (Loc,
                    Prefix =>
                      Make_Function_Call (Loc,
                        Name                   =>
                          New_Reference_To (RTE (RE_Base_Pool), Loc),
                        Parameter_Associations => New_List (
                          Make_Explicit_Dereference (Loc,
                            Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));

            --  Create an access type which uses the storage pool of the
            --  caller's finalization master.

            --  Generate:
            --    type Ptr_Typ is access Obj_Typ;

            Ptr_Typ := Make_Temporary (Loc, 'P');

            Append_To (Decls,
              Make_Full_Type_Declaration (Loc,
                Defining_Identifier => Ptr_Typ,
                Type_Definition     =>
                  Make_Access_To_Object_Definition (Loc,
                    Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));

            --  Perform minor decoration in order to set the master and the
            --  storage pool attributes.

            Set_Ekind (Ptr_Typ, E_Access_Type);
            Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
            Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);

            --  Create an explicit free statement. Note that the free uses the
            --  caller's pool expressed as a renaming.

            Free_Stmt :=
              Make_Free_Statement (Loc,
                Expression =>
                  Unchecked_Convert_To (Ptr_Typ,
                    New_Reference_To (Temp_Id, Loc)));

            Set_Storage_Pool (Free_Stmt, Pool_Id);

            --  Create a block to house the dummy type and the instantiation as
            --  well as to perform the cleanup the temporary.

            --  Generate:
            --    declare
            --       <Decls>
            --    begin
            --       Free (Ptr_Typ (Temp_Id));
            --    end;

            Free_Blk :=
              Make_Block_Statement (Loc,
                Declarations               => Decls,
                Handled_Statement_Sequence =>
                  Make_Handled_Sequence_Of_Statements (Loc,
                    Statements => New_List (Free_Stmt)));

            --  Generate:
            --    if BIPfinalizationmaster /= null then

            Cond :=
              Make_Op_Ne (Loc,
                Left_Opnd  => New_Reference_To (Fin_Mas_Id, Loc),
                Right_Opnd => Make_Null (Loc));

            --  For constrained or tagged results escalate the condition to
            --  include the allocation format. Generate:
            --
            --    if BIPallocform > Secondary_Stack'Pos
            --      and then BIPfinalizationmaster /= null
            --    then

            if not Is_Constrained (Obj_Typ)
              or else Is_Tagged_Type (Obj_Typ)
            then
               declare
                  Alloc : constant Entity_Id :=
                            Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
               begin
                  Cond :=
                    Make_And_Then (Loc,
                      Left_Opnd  =>
                        Make_Op_Gt (Loc,
                          Left_Opnd  => New_Reference_To (Alloc, Loc),
                          Right_Opnd =>
                            Make_Integer_Literal (Loc,
                              UI_From_Int
                                (BIP_Allocation_Form'Pos (Secondary_Stack)))),

                      Right_Opnd => Cond);
               end;
            end if;

            --  Generate:
            --    if <Cond> then
            --       <Free_Blk>
            --    end if;

            return
              Make_If_Statement (Loc,
                Condition       => Cond,
                Then_Statements => New_List (Free_Blk));
         end Build_BIP_Cleanup_Stmts;

         --------------------
         -- Find_Last_Init --
         --------------------

         procedure Find_Last_Init
           (Decl        : Node_Id;
            Typ         : Entity_Id;
            Last_Init   : out Node_Id;
            Body_Insert : out Node_Id)
         is
            Nod_1 : Node_Id := Empty;
            Nod_2 : Node_Id := Empty;
            Utyp  : Entity_Id;

            function Is_Init_Call
              (N   : Node_Id;
               Typ : Entity_Id) return Boolean;
            --  Given an arbitrary node, determine whether N is a procedure
            --  call and if it is, try to match the name of the call with the
            --  [Deep_]Initialize proc of Typ.

            function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
            --  Given a statement which is part of a list, return the next
            --  real statement while skipping over dynamic elab checks.

            ------------------
            -- Is_Init_Call --
            ------------------

            function Is_Init_Call
              (N   : Node_Id;
               Typ : Entity_Id) return Boolean
            is
            begin
               --  A call to [Deep_]Initialize is always direct

               if Nkind (N) = N_Procedure_Call_Statement
                 and then Nkind (Name (N)) = N_Identifier
               then
                  declare
                     Call_Ent  : constant Entity_Id := Entity (Name (N));
                     Deep_Init : constant Entity_Id :=
                                   TSS (Typ, TSS_Deep_Initialize);
                     Init      : Entity_Id := Empty;

                  begin
                     --  A type may have controlled components but not be
                     --  controlled.

                     if Is_Controlled (Typ) then
                        Init := Find_Prim_Op (Typ, Name_Initialize);

                        if Present (Init) then
                           Init := Ultimate_Alias (Init);
                        end if;
                     end if;

                     return
                       (Present (Deep_Init) and then Call_Ent = Deep_Init)
                         or else
                       (Present (Init)      and then Call_Ent = Init);
                  end;
               end if;

               return False;
            end Is_Init_Call;

            -----------------------------
            -- Next_Suitable_Statement --
            -----------------------------

            function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
               Result : Node_Id := Next (Stmt);

            begin
               --  Skip over access-before-elaboration checks

               if Dynamic_Elaboration_Checks
                 and then Nkind (Result) = N_Raise_Program_Error
               then
                  Result := Next (Result);
               end if;

               return Result;
            end Next_Suitable_Statement;

         --  Start of processing for Find_Last_Init

         begin
            Last_Init   := Decl;
            Body_Insert := Empty;

            --  Object renamings and objects associated with controlled
            --  function results do not have initialization calls.

            if Has_No_Init then
               return;
            end if;

            if Is_Concurrent_Type (Typ) then
               Utyp := Corresponding_Record_Type (Typ);
            else
               Utyp := Typ;
            end if;

            if Is_Private_Type (Utyp)
              and then Present (Full_View (Utyp))
            then
               Utyp := Full_View (Utyp);
            end if;

            --  The init procedures are arranged as follows:

            --    Object : Controlled_Type;
            --    Controlled_TypeIP (Object);
            --    [[Deep_]Initialize (Object);]

            --  where the user-defined initialize may be optional or may appear
            --  inside a block when abort deferral is needed.

            Nod_1 := Next_Suitable_Statement (Decl);
            if Present (Nod_1) then
               Nod_2 := Next_Suitable_Statement (Nod_1);

               --  The statement following an object declaration is always a
               --  call to the type init proc.

               Last_Init := Nod_1;
            end if;

            --  Optional user-defined init or deep init processing

            if Present (Nod_2) then

               --  The statement following the type init proc may be a block
               --  statement in cases where abort deferral is required.

               if Nkind (Nod_2) = N_Block_Statement then
                  declare
                     HSS  : constant Node_Id :=
                              Handled_Statement_Sequence (Nod_2);
                     Stmt : Node_Id;

                  begin
                     if Present (HSS)
                       and then Present (Statements (HSS))
                     then
                        Stmt := First (Statements (HSS));

                        --  Examine individual block statements and locate the
                        --  call to [Deep_]Initialze.

                        while Present (Stmt) loop
                           if Is_Init_Call (Stmt, Utyp) then
                              Last_Init   := Stmt;
                              Body_Insert := Nod_2;

                              exit;
                           end if;

                           Next (Stmt);
                        end loop;
                     end if;
                  end;

               elsif Is_Init_Call (Nod_2, Utyp) then
                  Last_Init := Nod_2;
               end if;
            end if;
         end Find_Last_Init;

      --  Start of processing for Process_Object_Declaration

      begin
         Obj_Ref := New_Reference_To (Obj_Id, Loc);
         Obj_Typ := Base_Type (Etype (Obj_Id));

         --  Handle access types

         if Is_Access_Type (Obj_Typ) then
            Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
            Obj_Typ := Directly_Designated_Type (Obj_Typ);
         end if;

         Set_Etype (Obj_Ref, Obj_Typ);

         --  Set a new value for the state counter and insert the statement
         --  after the object declaration. Generate:
         --
         --    Counter := <value>;

         Inc_Decl :=
           Make_Assignment_Statement (Loc,
             Name       => New_Reference_To (Counter_Id, Loc),
             Expression => Make_Integer_Literal (Loc, Counter_Val));

         --  Insert the counter after all initialization has been done. The
         --  place of insertion depends on the context. When dealing with a
         --  controlled function, the counter is inserted directly after the
         --  declaration because such objects lack init calls.

         Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);

         Insert_After (Count_Ins, Inc_Decl);
         Analyze (Inc_Decl);

         --  If the current declaration is the last in the list, the finalizer
         --  body needs to be inserted after the set counter statement for the
         --  current object declaration. This is complicated by the fact that
         --  the set counter statement may appear in abort deferred block. In
         --  that case, the proper insertion place is after the block.

         if No (Finalizer_Insert_Nod) then

            --  Insertion after an abort deffered block

            if Present (Body_Ins) then
               Finalizer_Insert_Nod := Body_Ins;
            else
               Finalizer_Insert_Nod := Inc_Decl;
            end if;
         end if;

         --  Create the associated label with this object, generate:
         --
         --    L<counter> : label;

         Label_Id :=
           Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
         Set_Entity
           (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
         Label := Make_Label (Loc, Label_Id);

         Prepend_To (Finalizer_Decls,
           Make_Implicit_Label_Declaration (Loc,
             Defining_Identifier => Entity (Label_Id),
             Label_Construct     => Label));

         --  Create the associated jump with this object, generate:
         --
         --    when <counter> =>
         --       goto L<counter>;

         Prepend_To (Jump_Alts,
           Make_Case_Statement_Alternative (Loc,
             Discrete_Choices => New_List (
               Make_Integer_Literal (Loc, Counter_Val)),
             Statements       => New_List (
               Make_Goto_Statement (Loc,
                 Name => New_Reference_To (Entity (Label_Id), Loc)))));

         --  Insert the jump destination, generate:
         --
         --     <<L<counter>>>

         Append_To (Finalizer_Stmts, Label);

         --  Processing for simple protected objects. Such objects require
         --  manual finalization of their lock managers.

         if Is_Protected then
            Fin_Stmts := No_List;

            if Is_Simple_Protected_Type (Obj_Typ) then
               Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);

               if Present (Fin_Call) then
                  Fin_Stmts := New_List (Fin_Call);
               end if;

            elsif Has_Simple_Protected_Object (Obj_Typ) then
               if Is_Record_Type (Obj_Typ) then
                  Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
               elsif Is_Array_Type (Obj_Typ) then
                  Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
               end if;
            end if;

            --  Generate:
            --    begin
            --       System.Tasking.Protected_Objects.Finalize_Protection
            --         (Obj._object);

            --    exception
            --       when others =>
            --          null;
            --    end;

            if Present (Fin_Stmts) then
               Append_To (Finalizer_Stmts,
                 Make_Block_Statement (Loc,
                   Handled_Statement_Sequence =>
                     Make_Handled_Sequence_Of_Statements (Loc,
                       Statements         => Fin_Stmts,

                       Exception_Handlers => New_List (
                         Make_Exception_Handler (Loc,
                           Exception_Choices => New_List (
                             Make_Others_Choice (Loc)),

                           Statements     => New_List (
                             Make_Null_Statement (Loc)))))));
            end if;

         --  Processing for regular controlled objects

         else
            --  Generate:
            --    [Deep_]Finalize (Obj);  --  No_Exception_Propagation

            --    begin                   --  Exception handlers allowed
            --       [Deep_]Finalize (Obj);

            --    exception
            --       when Id : others =>
            --          if not Raised then
            --             Raised := True;
            --             Save_Occurrence (E, Id);
            --          end if;
            --    end;

            Fin_Call :=
              Make_Final_Call (
                Obj_Ref => Obj_Ref,
                Typ     => Obj_Typ);

            if Exceptions_OK then
               Fin_Stmts := New_List (
                 Make_Block_Statement (Loc,
                   Handled_Statement_Sequence =>
                     Make_Handled_Sequence_Of_Statements (Loc,
                       Statements => New_List (Fin_Call),

                    Exception_Handlers => New_List (
                      Build_Exception_Handler
                        (Finalizer_Data, For_Package)))));

            --  When exception handlers are prohibited, the finalization call
            --  appears unprotected. Any exception raised during finalization
            --  will bypass the circuitry which ensures the cleanup of all
            --  remaining objects.

            else
               Fin_Stmts := New_List (Fin_Call);
            end if;

            --  If we are dealing with a return object of a build-in-place
            --  function, generate the following cleanup statements:

            --    if BIPallocfrom > Secondary_Stack'Pos
            --      and then BIPfinalizationmaster /= null
            --    then
            --       declare
            --          type Ptr_Typ is access Obj_Typ;
            --          for Ptr_Typ'Storage_Pool use
            --                Base_Pool (BIPfinalizationmaster.all).all;
            --       begin
            --          Free (Ptr_Typ (Temp));
            --       end;
            --    end if;
            --
            --  The generated code effectively detaches the temporary from the
            --  caller finalization master and deallocates the object. This is
            --  disabled on .NET/JVM because pools are not supported.

            if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
               declare
                  Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
               begin
                  if Is_Build_In_Place_Function (Func_Id)
                    and then Needs_BIP_Finalization_Master (Func_Id)
                  then
                     Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
                  end if;
               end;
            end if;

            if Ekind_In (Obj_Id, E_Constant, E_Variable)
              and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
            then
               --  Return objects use a flag to aid their potential
               --  finalization when the enclosing function fails to return
               --  properly. Generate:

               --    if not Flag then
               --       <object finalization statements>
               --    end if;

               if Is_Return_Object (Obj_Id) then
                  Fin_Stmts := New_List (
                    Make_If_Statement (Loc,
                      Condition     =>
                        Make_Op_Not (Loc,
                          Right_Opnd =>
                            New_Reference_To
                              (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)),

                    Then_Statements => Fin_Stmts));

               --  Temporaries created for the purpose of "exporting" a
               --  controlled transient out of an Expression_With_Actions (EWA)
               --  need guards. The following illustrates the usage of such
               --  temporaries.

               --    Access_Typ : access [all] Obj_Typ;
               --    Temp       : Access_Typ := null;
               --    <Counter>  := ...;

               --    do
               --       Ctrl_Trans : [access [all]] Obj_Typ := ...;
               --       Temp := Access_Typ (Ctrl_Trans);  --  when a pointer
               --         <or>
               --       Temp := Ctrl_Trans'Unchecked_Access;
               --    in ... end;

               --  The finalization machinery does not process EWA nodes as
               --  this may lead to premature finalization of expressions. Note
               --  that Temp is marked as being properly initialized regardless
               --  of whether the initialization of Ctrl_Trans succeeded. Since
               --  a failed initialization may leave Temp with a value of null,
               --  add a guard to handle this case:

               --    if Obj /= null then
               --       <object finalization statements>
               --    end if;

               else
                  pragma Assert
                    (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
                       N_Object_Declaration);

                  Fin_Stmts := New_List (
                    Make_If_Statement (Loc,
                      Condition       =>
                        Make_Op_Ne (Loc,
                          Left_Opnd  => New_Reference_To (Obj_Id, Loc),
                          Right_Opnd => Make_Null (Loc)),

                      Then_Statements => Fin_Stmts));
               end if;
            end if;
         end if;

         Append_List_To (Finalizer_Stmts, Fin_Stmts);

         --  Since the declarations are examined in reverse, the state counter
         --  must be decremented in order to keep with the true position of
         --  objects.

         Counter_Val := Counter_Val - 1;
      end Process_Object_Declaration;

      -------------------------------------
      -- Process_Tagged_Type_Declaration --
      -------------------------------------

      procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
         Typ    : constant Entity_Id := Defining_Identifier (Decl);
         DT_Ptr : constant Entity_Id :=
                    Node (First_Elmt (Access_Disp_Table (Typ)));
      begin
         --  Generate:
         --    Ada.Tags.Unregister_Tag (<Typ>P);

         Append_To (Tagged_Type_Stmts,
           Make_Procedure_Call_Statement (Loc,
             Name                   =>
               New_Reference_To (RTE (RE_Unregister_Tag), Loc),
             Parameter_Associations => New_List (
               New_Reference_To (DT_Ptr, Loc))));
      end Process_Tagged_Type_Declaration;

   --  Start of processing for Build_Finalizer

   begin
      Fin_Id := Empty;

      --  Do not perform this expansion in Alfa mode because it is not
      --  necessary.

      if Alfa_Mode then
         return;
      end if;

      --  Step 1: Extract all lists which may contain controlled objects or
      --  library-level tagged types.

      if For_Package_Spec then
         Decls      := Visible_Declarations (Specification (N));
         Priv_Decls := Private_Declarations (Specification (N));

         --  Retrieve the package spec id

         Spec_Id := Defining_Unit_Name (Specification (N));

         if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
            Spec_Id := Defining_Identifier (Spec_Id);
         end if;

      --  Accept statement, block, entry body, package body, protected body,
      --  subprogram body or task body.

      else
         Decls := Declarations (N);
         HSS   := Handled_Statement_Sequence (N);

         if Present (HSS) then
            if Present (Statements (HSS)) then
               Stmts := Statements (HSS);
            end if;

            if Present (At_End_Proc (HSS)) then
               Prev_At_End := At_End_Proc (HSS);
            end if;
         end if;

         --  Retrieve the package spec id for package bodies

         if For_Package_Body then
            Spec_Id := Corresponding_Spec (N);
         end if;
      end if;

      --  Do not process nested packages since those are handled by the
      --  enclosing scope's finalizer. Do not process non-expanded package
      --  instantiations since those will be re-analyzed and re-expanded.

      if For_Package
        and then
          (not Is_Library_Level_Entity (Spec_Id)

             --  Nested packages are considered to be library level entities,
             --  but do not need to be processed separately. True library level
             --  packages have a scope value of 1.

             or else Scope_Depth_Value (Spec_Id) /= Uint_1
             or else (Is_Generic_Instance (Spec_Id)
                       and then Package_Instantiation (Spec_Id) /= N))
      then
         return;
      end if;

      --  Step 2: Object [pre]processing

      if For_Package then

         --  Preprocess the visible declarations now in order to obtain the
         --  correct number of controlled object by the time the private
         --  declarations are processed.

         Process_Declarations (Decls, Preprocess => True, Top_Level => True);

         --  From all the possible contexts, only package specifications may
         --  have private declarations.

         if For_Package_Spec then
            Process_Declarations
              (Priv_Decls, Preprocess => True, Top_Level => True);
         end if;

         --  The current context may lack controlled objects, but require some
         --  other form of completion (task termination for instance). In such
         --  cases, the finalizer must be created and carry the additional
         --  statements.

         if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
            Build_Components;
         end if;

         --  The preprocessing has determined that the context has controlled
         --  objects or library-level tagged types.

         if Has_Ctrl_Objs or Has_Tagged_Types then

            --  Private declarations are processed first in order to preserve
            --  possible dependencies between public and private objects.

            if For_Package_Spec then
               Process_Declarations (Priv_Decls);
            end if;

            Process_Declarations (Decls);
         end if;

      --  Non-package case

      else
         --  Preprocess both declarations and statements

         Process_Declarations (Decls, Preprocess => True, Top_Level => True);
         Process_Declarations (Stmts, Preprocess => True, Top_Level => True);

         --  At this point it is known that N has controlled objects. Ensure
         --  that N has a declarative list since the finalizer spec will be
         --  attached to it.

         if Has_Ctrl_Objs and then No (Decls) then
            Set_Declarations (N, New_List);
            Decls      := Declarations (N);
            Spec_Decls := Decls;
         end if;

         --  The current context may lack controlled objects, but require some
         --  other form of completion (task termination for instance). In such
         --  cases, the finalizer must be created and carry the additional
         --  statements.

         if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
            Build_Components;
         end if;

         if Has_Ctrl_Objs or Has_Tagged_Types then
            Process_Declarations (Stmts);
            Process_Declarations (Decls);
         end if;
      end if;

      --  Step 3: Finalizer creation

      if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
         Create_Finalizer;
      end if;
   end Build_Finalizer;

   --------------------------
   -- Build_Finalizer_Call --
   --------------------------

   procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
      Is_Prot_Body : constant Boolean :=
                       Nkind (N) = N_Subprogram_Body
                         and then Is_Protected_Subprogram_Body (N);
      --  Determine whether N denotes the protected version of a subprogram
      --  which belongs to a protected type.

      Loc : constant Source_Ptr := Sloc (N);
      HSS : Node_Id;

   begin
      --  Do not perform this expansion in Alfa mode because we do not create
      --  finalizers in the first place.

      if Alfa_Mode then
         return;
      end if;

      --  The At_End handler should have been assimilated by the finalizer

      HSS := Handled_Statement_Sequence (N);
      pragma Assert (No (At_End_Proc (HSS)));

      --  If the construct to be cleaned up is a protected subprogram body, the
      --  finalizer call needs to be associated with the block which wraps the
      --  unprotected version of the subprogram. The following illustrates this
      --  scenario:

      --     procedure Prot_SubpP is
      --        procedure finalizer is
      --        begin
      --           Service_Entries (Prot_Obj);
      --           Abort_Undefer;
      --        end finalizer;

      --     begin
      --        . . .
      --        begin
      --           Prot_SubpN (Prot_Obj);
      --        at end
      --           finalizer;
      --        end;
      --     end Prot_SubpP;

      if Is_Prot_Body then
         HSS := Handled_Statement_Sequence (Last (Statements (HSS)));

      --  An At_End handler and regular exception handlers cannot coexist in
      --  the same statement sequence. Wrap the original statements in a block.

      elsif Present (Exception_Handlers (HSS)) then
         declare
            End_Lab : constant Node_Id := End_Label (HSS);
            Block   : Node_Id;

         begin
            Block :=
              Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);

            Set_Handled_Statement_Sequence (N,
              Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));

            HSS := Handled_Statement_Sequence (N);
            Set_End_Label (HSS, End_Lab);
         end;
      end if;

      Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc));

      Analyze (At_End_Proc (HSS));
      Expand_At_End_Handler (HSS, Empty);
   end Build_Finalizer_Call;

   ---------------------
   -- Build_Late_Proc --
   ---------------------

   procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
   begin
      for Final_Prim in Name_Of'Range loop
         if Name_Of (Final_Prim) = Nam then
            Set_TSS (Typ,
              Make_Deep_Proc
                (Prim  => Final_Prim,
                 Typ   => Typ,
                 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
         end if;
      end loop;
   end Build_Late_Proc;

   -------------------------------
   -- Build_Object_Declarations --
   -------------------------------

   procedure Build_Object_Declarations
     (Data        : out Finalization_Exception_Data;
      Decls       : List_Id;
      Loc         : Source_Ptr;
      For_Package : Boolean := False)
   is
      A_Expr : Node_Id;
      E_Decl : Node_Id;

   begin
      pragma Assert (Decls /= No_List);

      --  Always set the proper location as it may be needed even when
      --  exception propagation is forbidden.

      Data.Loc := Loc;

      if Restriction_Active (No_Exception_Propagation) then
         Data.Abort_Id  := Empty;
         Data.E_Id      := Empty;
         Data.Raised_Id := Empty;
         return;
      end if;

      Data.Abort_Id  := Make_Temporary (Loc, 'A');
      Data.E_Id      := Make_Temporary (Loc, 'E');
      Data.Raised_Id := Make_Temporary (Loc, 'R');

      --  In certain scenarios, finalization can be triggered by an abort. If
      --  the finalization itself fails and raises an exception, the resulting
      --  Program_Error must be supressed and replaced by an abort signal. In
      --  order to detect this scenario, save the state of entry into the
      --  finalization code.

      --  No need to do this for VM case, since VM version of Ada.Exceptions
      --  does not include routine Raise_From_Controlled_Operation which is the
      --  the sole user of flag Abort.

      --  This is not needed for library-level finalizers as they are called
      --  by the environment task and cannot be aborted.

      if Abort_Allowed
        and then VM_Target = No_VM
        and then not For_Package
      then
         A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);

      --  No abort, .NET/JVM or library-level finalizers

      else
         A_Expr := New_Reference_To (Standard_False, Loc);
      end if;

      --  Generate:
      --    Abort_Id : constant Boolean := <A_Expr>;

      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => Data.Abort_Id,
          Constant_Present    => True,
          Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
          Expression          => A_Expr));

      --  Generate:
      --    E_Id : Exception_Occurrence;

      E_Decl :=
        Make_Object_Declaration (Loc,
          Defining_Identifier => Data.E_Id,
          Object_Definition   =>
            New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
      Set_No_Initialization (E_Decl);

      Append_To (Decls, E_Decl);

      --  Generate:
      --    Raised_Id : Boolean := False;

      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => Data.Raised_Id,
          Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
          Expression          => New_Reference_To (Standard_False, Loc)));
   end Build_Object_Declarations;

   ---------------------------
   -- Build_Raise_Statement --
   ---------------------------

   function Build_Raise_Statement
     (Data : Finalization_Exception_Data) return Node_Id
   is
      Stmt : Node_Id;

   begin
      --  Standard run-time and .NET/JVM targets use the specialized routine
      --  Raise_From_Controlled_Operation.

      if RTE_Available (RE_Raise_From_Controlled_Operation) then
         Stmt :=
           Make_Procedure_Call_Statement (Data.Loc,
              Name                   =>
                New_Reference_To
                  (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
              Parameter_Associations =>
                New_List (New_Reference_To (Data.E_Id, Data.Loc)));

      --  Restricted run-time: exception messages are not supported and hence
      --  Raise_From_Controlled_Operation is not supported. Raise Program_Error
      --  instead.

      else
         Stmt :=
           Make_Raise_Program_Error (Data.Loc,
             Reason => PE_Finalize_Raised_Exception);
      end if;

      --  Generate:
      --    if Raised_Id and then not Abort_Id then
      --       Raise_From_Controlled_Operation (E_Id);
      --         <or>
      --       raise Program_Error;  --  restricted runtime
      --    end if;

      return
        Make_If_Statement (Data.Loc,
          Condition       =>
            Make_And_Then (Data.Loc,
              Left_Opnd  => New_Reference_To (Data.Raised_Id, Data.Loc),
              Right_Opnd =>
                Make_Op_Not (Data.Loc,
                  Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))),

          Then_Statements => New_List (Stmt));
   end Build_Raise_Statement;

   -----------------------------
   -- Build_Record_Deep_Procs --
   -----------------------------

   procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
   begin
      Set_TSS (Typ,
        Make_Deep_Proc
          (Prim  => Initialize_Case,
           Typ   => Typ,
           Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));

      if not Is_Immutably_Limited_Type (Typ) then
         Set_TSS (Typ,
           Make_Deep_Proc
             (Prim  => Adjust_Case,
              Typ   => Typ,
              Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
      end if;

      --  Do not generate Deep_Finalize and Finalize_Address if finalization is
      --  suppressed since these routine will not be used.

      if not Restriction_Active (No_Finalization) then
         Set_TSS (Typ,
           Make_Deep_Proc
             (Prim  => Finalize_Case,
              Typ   => Typ,
              Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));

         --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
         --  .NET do not support address arithmetic and unchecked conversions.

         if VM_Target = No_VM then
            Set_TSS (Typ,
              Make_Deep_Proc
                (Prim  => Address_Case,
                 Typ   => Typ,
                 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
         end if;
      end if;
   end Build_Record_Deep_Procs;

   -------------------
   -- Cleanup_Array --
   -------------------

   function Cleanup_Array
     (N    : Node_Id;
      Obj  : Node_Id;
      Typ  : Entity_Id) return List_Id
   is
      Loc        : constant Source_Ptr := Sloc (N);
      Index_List : constant List_Id := New_List;

      function Free_Component return List_Id;
      --  Generate the code to finalize the task or protected  subcomponents
      --  of a single component of the array.

      function Free_One_Dimension (Dim : Int) return List_Id;
      --  Generate a loop over one dimension of the array

      --------------------
      -- Free_Component --
      --------------------

      function Free_Component return List_Id is
         Stmts : List_Id := New_List;
         Tsk   : Node_Id;
         C_Typ : constant Entity_Id := Component_Type (Typ);

      begin
         --  Component type is known to contain tasks or protected objects

         Tsk :=
           Make_Indexed_Component (Loc,
             Prefix        => Duplicate_Subexpr_No_Checks (Obj),
             Expressions   => Index_List);

         Set_Etype (Tsk, C_Typ);

         if Is_Task_Type (C_Typ) then
            Append_To (Stmts, Cleanup_Task (N, Tsk));

         elsif Is_Simple_Protected_Type (C_Typ) then
            Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));

         elsif Is_Record_Type (C_Typ) then
            Stmts := Cleanup_Record (N, Tsk, C_Typ);

         elsif Is_Array_Type (C_Typ) then
            Stmts := Cleanup_Array (N, Tsk, C_Typ);
         end if;

         return Stmts;
      end Free_Component;

      ------------------------
      -- Free_One_Dimension --
      ------------------------

      function Free_One_Dimension (Dim : Int) return List_Id is
         Index : Entity_Id;

      begin
         if Dim > Number_Dimensions (Typ) then
            return Free_Component;

         --  Here we generate the required loop

         else
            Index := Make_Temporary (Loc, 'J');
            Append (New_Reference_To (Index, Loc), Index_List);

            return New_List (
              Make_Implicit_Loop_Statement (N,
                Identifier       => Empty,
                Iteration_Scheme =>
                  Make_Iteration_Scheme (Loc,
                    Loop_Parameter_Specification =>
                      Make_Loop_Parameter_Specification (Loc,
                        Defining_Identifier         => Index,
                        Discrete_Subtype_Definition =>
                          Make_Attribute_Reference (Loc,
                            Prefix          => Duplicate_Subexpr (Obj),
                            Attribute_Name  => Name_Range,
                            Expressions     => New_List (
                              Make_Integer_Literal (Loc, Dim))))),
                Statements       =>  Free_One_Dimension (Dim + 1)));
         end if;
      end Free_One_Dimension;

   --  Start of processing for Cleanup_Array

   begin
      return Free_One_Dimension (1);
   end Cleanup_Array;

   --------------------
   -- Cleanup_Record --
   --------------------

   function Cleanup_Record
     (N    : Node_Id;
      Obj  : Node_Id;
      Typ  : Entity_Id) return List_Id
   is
      Loc   : constant Source_Ptr := Sloc (N);
      Tsk   : Node_Id;
      Comp  : Entity_Id;
      Stmts : constant List_Id    := New_List;
      U_Typ : constant Entity_Id  := Underlying_Type (Typ);

   begin
      if Has_Discriminants (U_Typ)
        and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
        and then
          Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
        and then
          Present
            (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
      then
         --  For now, do not attempt to free a component that may appear in a
         --  variant, and instead issue a warning. Doing this "properly" would
         --  require building a case statement and would be quite a mess. Note
         --  that the RM only requires that free "work" for the case of a task
         --  access value, so already we go way beyond this in that we deal
         --  with the array case and non-discriminated record cases.

         Error_Msg_N
           ("task/protected object in variant record will not be freed?", N);
         return New_List (Make_Null_Statement (Loc));
      end if;

      Comp := First_Component (Typ);
      while Present (Comp) loop
         if Has_Task (Etype (Comp))
           or else Has_Simple_Protected_Object (Etype (Comp))
         then
            Tsk :=
              Make_Selected_Component (Loc,
                Prefix        => Duplicate_Subexpr_No_Checks (Obj),
                Selector_Name => New_Occurrence_Of (Comp, Loc));
            Set_Etype (Tsk, Etype (Comp));

            if Is_Task_Type (Etype (Comp)) then
               Append_To (Stmts, Cleanup_Task (N, Tsk));

            elsif Is_Simple_Protected_Type (Etype (Comp)) then
               Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));

            elsif Is_Record_Type (Etype (Comp)) then

               --  Recurse, by generating the prefix of the argument to
               --  the eventual cleanup call.

               Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));

            elsif Is_Array_Type (Etype (Comp)) then
               Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
            end if;
         end if;

         Next_Component (Comp);
      end loop;

      return Stmts;
   end Cleanup_Record;

   ------------------------------
   -- Cleanup_Protected_Object --
   ------------------------------

   function Cleanup_Protected_Object
     (N   : Node_Id;
      Ref : Node_Id) return Node_Id
   is
      Loc : constant Source_Ptr := Sloc (N);

   begin
      --  For restricted run-time libraries (Ravenscar), tasks are
      --  non-terminating, and protected objects can only appear at library
      --  level, so we do not want finalization of protected objects.

      if Restricted_Profile then
         return Empty;

      else
         return
           Make_Procedure_Call_Statement (Loc,
             Name                   =>
               New_Reference_To (RTE (RE_Finalize_Protection), Loc),
             Parameter_Associations => New_List (Concurrent_Ref (Ref)));
      end if;
   end Cleanup_Protected_Object;

   ------------------
   -- Cleanup_Task --
   ------------------

   function Cleanup_Task
     (N   : Node_Id;
      Ref : Node_Id) return Node_Id
   is
      Loc  : constant Source_Ptr := Sloc (N);

   begin
      --  For restricted run-time libraries (Ravenscar), tasks are
      --  non-terminating and they can only appear at library level, so we do
      --  not want finalization of task objects.

      if Restricted_Profile then
         return Empty;

      else
         return
           Make_Procedure_Call_Statement (Loc,
             Name                   =>
               New_Reference_To (RTE (RE_Free_Task), Loc),
             Parameter_Associations => New_List (Concurrent_Ref (Ref)));
      end if;
   end Cleanup_Task;

   ------------------------------
   -- Check_Visibly_Controlled --
   ------------------------------

   procedure Check_Visibly_Controlled
     (Prim : Final_Primitives;
      Typ  : Entity_Id;
      E    : in out Entity_Id;
      Cref : in out Node_Id)
   is
      Parent_Type : Entity_Id;
      Op          : Entity_Id;

   begin
      if Is_Derived_Type (Typ)
        and then Comes_From_Source (E)
        and then not Present (Overridden_Operation (E))
      then
         --  We know that the explicit operation on the type does not override
         --  the inherited operation of the parent, and that the derivation
         --  is from a private type that is not visibly controlled.

         Parent_Type := Etype (Typ);
         Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));

         if Present (Op) then
            E := Op;

            --  Wrap the object to be initialized into the proper
            --  unchecked conversion, to be compatible with the operation
            --  to be called.

            if Nkind (Cref) = N_Unchecked_Type_Conversion then
               Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
            else
               Cref := Unchecked_Convert_To (Parent_Type, Cref);
            end if;
         end if;
      end if;
   end Check_Visibly_Controlled;

   -------------------------------
   -- CW_Or_Has_Controlled_Part --
   -------------------------------

   function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
   begin
      return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
   end CW_Or_Has_Controlled_Part;

   ------------------
   -- Convert_View --
   ------------------

   function Convert_View
     (Proc : Entity_Id;
      Arg  : Node_Id;
      Ind  : Pos := 1) return Node_Id
   is
      Fent : Entity_Id := First_Entity (Proc);
      Ftyp : Entity_Id;
      Atyp : Entity_Id;

   begin
      for J in 2 .. Ind loop
         Next_Entity (Fent);
      end loop;

      Ftyp := Etype (Fent);

      if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
         Atyp := Entity (Subtype_Mark (Arg));
      else
         Atyp := Etype (Arg);
      end if;

      if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
         return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);

      elsif Ftyp /= Atyp
        and then Present (Atyp)
        and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
        and then Base_Type (Underlying_Type (Atyp)) =
                 Base_Type (Underlying_Type (Ftyp))
      then
         return Unchecked_Convert_To (Ftyp, Arg);

      --  If the argument is already a conversion, as generated by
      --  Make_Init_Call, set the target type to the type of the formal
      --  directly, to avoid spurious typing problems.

      elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
        and then not Is_Class_Wide_Type (Atyp)
      then
         Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
         Set_Etype (Arg, Ftyp);
         return Arg;

      else
         return Arg;
      end if;
   end Convert_View;

   ------------------------
   -- Enclosing_Function --
   ------------------------

   function Enclosing_Function (E : Entity_Id) return Entity_Id is
      Func_Id : Entity_Id;

   begin
      Func_Id := E;
      while Present (Func_Id)
        and then Func_Id /= Standard_Standard
      loop
         if Ekind (Func_Id) = E_Function then
            return Func_Id;
         end if;

         Func_Id := Scope (Func_Id);
      end loop;

      return Empty;
   end Enclosing_Function;

   -------------------------------
   -- Establish_Transient_Scope --
   -------------------------------

   --  This procedure is called each time a transient block has to be inserted
   --  that is to say for each call to a function with unconstrained or tagged
   --  result. It creates a new scope on the stack scope in order to enclose
   --  all transient variables generated

   procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
      Loc       : constant Source_Ptr := Sloc (N);
      Wrap_Node : Node_Id;

   begin
      --  Do not create a transient scope if we are already inside one

      for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
         if Scope_Stack.Table (S).Is_Transient then
            if Sec_Stack then
               Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
            end if;

            return;

         --  If we have encountered Standard there are no enclosing
         --  transient scopes.

         elsif Scope_Stack.Table (S).Entity = Standard_Standard then
            exit;
         end if;
      end loop;

      Wrap_Node := Find_Node_To_Be_Wrapped (N);

      --  Case of no wrap node, false alert, no transient scope needed

      if No (Wrap_Node) then
         null;

      --  If the node to wrap is an iteration_scheme, the expression is
      --  one of the bounds, and the expansion will make an explicit
      --  declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
      --  so do not apply any transformations here.

      elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
         null;

      --  In formal verification mode, if the node to wrap is a pragma check,
      --  this node and enclosed expression are not expanded, so do not apply
      --  any transformations here.

      elsif Alfa_Mode
        and then Nkind (Wrap_Node) = N_Pragma
        and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
      then
         null;

      else
         Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
         Set_Scope_Is_Transient;

         if Sec_Stack then
            Set_Uses_Sec_Stack (Current_Scope);
            Check_Restriction (No_Secondary_Stack, N);
         end if;

         Set_Etype (Current_Scope, Standard_Void_Type);
         Set_Node_To_Be_Wrapped (Wrap_Node);

         if Debug_Flag_W then
            Write_Str ("    <Transient>");
            Write_Eol;
         end if;
      end if;
   end Establish_Transient_Scope;

   ----------------------------
   -- Expand_Cleanup_Actions --
   ----------------------------

   procedure Expand_Cleanup_Actions (N : Node_Id) is
      Scop : constant Entity_Id := Current_Scope;

      Is_Asynchronous_Call : constant Boolean :=
                               Nkind (N) = N_Block_Statement
                                 and then Is_Asynchronous_Call_Block (N);
      Is_Master            : constant Boolean :=
                               Nkind (N) /= N_Entry_Body
                                 and then Is_Task_Master (N);
      Is_Protected_Body    : constant Boolean :=
                               Nkind (N) = N_Subprogram_Body
                                 and then Is_Protected_Subprogram_Body (N);
      Is_Task_Allocation   : constant Boolean :=
                               Nkind (N) = N_Block_Statement
                                 and then Is_Task_Allocation_Block (N);
      Is_Task_Body         : constant Boolean :=
                               Nkind (Original_Node (N)) = N_Task_Body;
      Needs_Sec_Stack_Mark : constant Boolean :=
                               Uses_Sec_Stack (Scop)
                                 and then
                                   not Sec_Stack_Needed_For_Return (Scop)
                                 and then VM_Target = No_VM;

      Actions_Required     : constant Boolean :=
                               Requires_Cleanup_Actions (N)
                                 or else Is_Asynchronous_Call
                                 or else Is_Master
                                 or else Is_Protected_Body
                                 or else Is_Task_Allocation
                                 or else Is_Task_Body
                                 or else Needs_Sec_Stack_Mark;

      HSS : Node_Id := Handled_Statement_Sequence (N);
      Loc : Source_Ptr;

      procedure Wrap_HSS_In_Block;
      --  Move HSS inside a new block along with the original exception
      --  handlers. Make the newly generated block the sole statement of HSS.

      -----------------------
      -- Wrap_HSS_In_Block --
      -----------------------

      procedure Wrap_HSS_In_Block is
         Block   : Node_Id;
         End_Lab : Node_Id;

      begin
         --  Preserve end label to provide proper cross-reference information

         End_Lab := End_Label (HSS);
         Block :=
           Make_Block_Statement (Loc,
             Handled_Statement_Sequence => HSS);

         Set_Handled_Statement_Sequence (N,
           Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
         HSS := Handled_Statement_Sequence (N);

         Set_First_Real_Statement (HSS, Block);
         Set_End_Label (HSS, End_Lab);

         --  Comment needed here, see RH for 1.306 ???

         if Nkind (N) = N_Subprogram_Body then
            Set_Has_Nested_Block_With_Handler (Scop);
         end if;
      end Wrap_HSS_In_Block;

   --  Start of processing for Expand_Cleanup_Actions

   begin
      --  The current construct does not need any form of servicing

      if not Actions_Required then
         return;

      --  If the current node is a rewritten task body and the descriptors have
      --  not been delayed (due to some nested instantiations), do not generate
      --  redundant cleanup actions.

      elsif Is_Task_Body
        and then Nkind (N) = N_Subprogram_Body
        and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
      then
         return;
      end if;

      declare
         Decls     : List_Id := Declarations (N);
         Fin_Id    : Entity_Id;
         Mark      : Entity_Id := Empty;
         New_Decls : List_Id;
         Old_Poll  : Boolean;

      begin
         --  If we are generating expanded code for debugging purposes, use the
         --  Sloc of the point of insertion for the cleanup code. The Sloc will
         --  be updated subsequently to reference the proper line in .dg files.
         --  If we are not debugging generated code, use No_Location instead,
         --  so that no debug information is generated for the cleanup code.
         --  This makes the behavior of the NEXT command in GDB monotonic, and
         --  makes the placement of breakpoints more accurate.

         if Debug_Generated_Code then
            Loc := Sloc (Scop);
         else
            Loc := No_Location;
         end if;

         --  Set polling off. The finalization and cleanup code is executed
         --  with aborts deferred.

         Old_Poll := Polling_Required;
         Polling_Required := False;

         --  A task activation call has already been built for a task
         --  allocation block.

         if not Is_Task_Allocation then
            Build_Task_Activation_Call (N);
         end if;

         if Is_Master then
            Establish_Task_Master (N);
         end if;

         New_Decls := New_List;

         --  If secondary stack is in use, generate:
         --
         --    Mnn : constant Mark_Id := SS_Mark;

         --  Suppress calls to SS_Mark and SS_Release if VM_Target, since the
         --  secondary stack is never used on a VM.

         if Needs_Sec_Stack_Mark then
            Mark := Make_Temporary (Loc, 'M');

            Append_To (New_Decls,
              Make_Object_Declaration (Loc,
                Defining_Identifier => Mark,
                Object_Definition   =>
                  New_Reference_To (RTE (RE_Mark_Id), Loc),
                Expression          =>
                  Make_Function_Call (Loc,
                    Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));

            Set_Uses_Sec_Stack (Scop, False);
         end if;

         --  If exception handlers are present, wrap the sequence of statements
         --  in a block since it is not possible to have exception handlers and
         --  an At_End handler in the same construct.

         if Present (Exception_Handlers (HSS)) then
            Wrap_HSS_In_Block;

         --  Ensure that the First_Real_Statement field is set

         elsif No (First_Real_Statement (HSS)) then
            Set_First_Real_Statement (HSS, First (Statements (HSS)));
         end if;

         --  Do not move the Activation_Chain declaration in the context of
         --  task allocation blocks. Task allocation blocks use _chain in their
         --  cleanup handlers and gigi complains if it is declared in the
         --  sequence of statements of the scope that declares the handler.

         if Is_Task_Allocation then
            declare
               Chain : constant Entity_Id := Activation_Chain_Entity (N);
               Decl  : Node_Id;

            begin
               Decl := First (Decls);
               while Nkind (Decl) /= N_Object_Declaration
                 or else Defining_Identifier (Decl) /= Chain
               loop
                  Next (Decl);

                  --  A task allocation block should always include a _chain
                  --  declaration.

                  pragma Assert (Present (Decl));
               end loop;

               Remove (Decl);
               Prepend_To (New_Decls, Decl);
            end;
         end if;

         --  Ensure the presence of a declaration list in order to successfully
         --  append all original statements to it.

         if No (Decls) then
            Set_Declarations (N, New_List);
            Decls := Declarations (N);
         end if;

         --  Move the declarations into the sequence of statements in order to
         --  have them protected by the At_End handler. It may seem weird to
         --  put declarations in the sequence of statement but in fact nothing
         --  forbids that at the tree level.

         Append_List_To (Decls, Statements (HSS));
         Set_Statements (HSS, Decls);

         --  Reset the Sloc of the handled statement sequence to properly
         --  reflect the new initial "statement" in the sequence.

         Set_Sloc (HSS, Sloc (First (Decls)));

         --  The declarations of finalizer spec and auxiliary variables replace
         --  the old declarations that have been moved inward.

         Set_Declarations (N, New_Decls);
         Analyze_Declarations (New_Decls);

         --  Generate finalization calls for all controlled objects appearing
         --  in the statements of N. Add context specific cleanup for various
         --  constructs.

         Build_Finalizer
           (N           => N,
            Clean_Stmts => Build_Cleanup_Statements (N),
            Mark_Id     => Mark,
            Top_Decls   => New_Decls,
            Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
                             or else Is_Master,
            Fin_Id      => Fin_Id);

         if Present (Fin_Id) then
            Build_Finalizer_Call (N, Fin_Id);
         end if;

         --  Restore saved polling mode

         Polling_Required := Old_Poll;
      end;
   end Expand_Cleanup_Actions;

   ---------------------------
   -- Expand_N_Package_Body --
   ---------------------------

   --  Add call to Activate_Tasks if body is an activator (actual processing
   --  is in chapter 9).

   --  Generate subprogram descriptor for elaboration routine

   --  Encode entity names in package body

   procedure Expand_N_Package_Body (N : Node_Id) is
      Spec_Ent : constant Entity_Id := Corresponding_Spec (N);
      Fin_Id   : Entity_Id;

   begin
      --  This is done only for non-generic packages

      if Ekind (Spec_Ent) = E_Package then
         Push_Scope (Corresponding_Spec (N));

         --  Build dispatch tables of library level tagged types

         if Tagged_Type_Expansion
           and then Is_Library_Level_Entity (Spec_Ent)
         then
            Build_Static_Dispatch_Tables (N);
         end if;

         Build_Task_Activation_Call (N);
         Pop_Scope;
      end if;

      Set_Elaboration_Flag (N, Corresponding_Spec (N));
      Set_In_Package_Body (Spec_Ent, False);

      --  Set to encode entity names in package body before gigi is called

      Qualify_Entity_Names (N);

      if Ekind (Spec_Ent) /= E_Generic_Package then
         Build_Finalizer
           (N           => N,
            Clean_Stmts => No_List,
            Mark_Id     => Empty,
            Top_Decls   => No_List,
            Defer_Abort => False,
            Fin_Id      => Fin_Id);

         if Present (Fin_Id) then
            declare
               Body_Ent : Node_Id := Defining_Unit_Name (N);

            begin
               if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
                  Body_Ent := Defining_Identifier (Body_Ent);
               end if;

               Set_Finalizer (Body_Ent, Fin_Id);
            end;
         end if;
      end if;
   end Expand_N_Package_Body;

   ----------------------------------
   -- Expand_N_Package_Declaration --
   ----------------------------------

   --  Add call to Activate_Tasks if there are tasks declared and the package
   --  has no body. Note that in Ada 83 this may result in premature activation
   --  of some tasks, given that we cannot tell whether a body will eventually
   --  appear.

   procedure Expand_N_Package_Declaration (N : Node_Id) is
      Id     : constant Entity_Id := Defining_Entity (N);
      Spec   : constant Node_Id   := Specification (N);
      Decls  : List_Id;
      Fin_Id : Entity_Id;

      No_Body : Boolean := False;
      --  True in the case of a package declaration that is a compilation
      --  unit and for which no associated body will be compiled in this
      --  compilation.

   begin
      --  Case of a package declaration other than a compilation unit

      if Nkind (Parent (N)) /= N_Compilation_Unit then
         null;

      --  Case of a compilation unit that does not require a body

      elsif not Body_Required (Parent (N))
        and then not Unit_Requires_Body (Id)
      then
         No_Body := True;

      --  Special case of generating calling stubs for a remote call interface
      --  package: even though the package declaration requires one, the body
      --  won't be processed in this compilation (so any stubs for RACWs
      --  declared in the package must be generated here, along with the spec).

      elsif Parent (N) = Cunit (Main_Unit)
        and then Is_Remote_Call_Interface (Id)
        and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
      then
         No_Body := True;
      end if;

      --  For a nested instance, delay processing until freeze point

      if Has_Delayed_Freeze (Id)
        and then Nkind (Parent (N)) /= N_Compilation_Unit
      then
         return;
      end if;

      --  For a package declaration that implies no associated body, generate
      --  task activation call and RACW supporting bodies now (since we won't
      --  have a specific separate compilation unit for that).

      if No_Body then
         Push_Scope (Id);

         if Has_RACW (Id) then

            --  Generate RACW subprogram bodies

            Decls := Private_Declarations (Spec);

            if No (Decls) then
               Decls := Visible_Declarations (Spec);
            end if;

            if No (Decls) then
               Decls := New_List;
               Set_Visible_Declarations (Spec, Decls);
            end if;

            Append_RACW_Bodies (Decls, Id);
            Analyze_List (Decls);
         end if;

         if Present (Activation_Chain_Entity (N)) then

            --  Generate task activation call as last step of elaboration

            Build_Task_Activation_Call (N);
         end if;

         Pop_Scope;
      end if;

      --  Build dispatch tables of library level tagged types

      if Tagged_Type_Expansion
        and then (Is_Compilation_Unit (Id)
                   or else (Is_Generic_Instance (Id)
                             and then Is_Library_Level_Entity (Id)))
      then
         Build_Static_Dispatch_Tables (N);
      end if;

      --  Note: it is not necessary to worry about generating a subprogram
      --  descriptor, since the only way to get exception handlers into a
      --  package spec is to include instantiations, and that would cause
      --  generation of subprogram descriptors to be delayed in any case.

      --  Set to encode entity names in package spec before gigi is called

      Qualify_Entity_Names (N);

      if Ekind (Id) /= E_Generic_Package then
         Build_Finalizer
           (N           => N,
            Clean_Stmts => No_List,
            Mark_Id     => Empty,
            Top_Decls   => No_List,
            Defer_Abort => False,
            Fin_Id      => Fin_Id);

         Set_Finalizer (Id, Fin_Id);
      end if;
   end Expand_N_Package_Declaration;

   -----------------------------
   -- Find_Node_To_Be_Wrapped --
   -----------------------------

   function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
      P          : Node_Id;
      The_Parent : Node_Id;

   begin
      The_Parent := N;
      loop
         P := The_Parent;
         pragma Assert (P /= Empty);
         The_Parent := Parent (P);

         case Nkind (The_Parent) is

            --  Simple statement can be wrapped

            when N_Pragma =>
               return The_Parent;

            --  Usually assignments are good candidate for wrapping except
            --  when they have been generated as part of a controlled aggregate
            --  where the wrapping should take place more globally.

            when N_Assignment_Statement =>
               if No_Ctrl_Actions (The_Parent) then
                  null;
               else
                  return The_Parent;
               end if;

            --  An entry call statement is a special case if it occurs in the
            --  context of a Timed_Entry_Call. In this case we wrap the entire
            --  timed entry call.

            when N_Entry_Call_Statement     |
                 N_Procedure_Call_Statement =>
               if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
                 and then Nkind_In (Parent (Parent (The_Parent)),
                                    N_Timed_Entry_Call,
                                    N_Conditional_Entry_Call)
               then
                  return Parent (Parent (The_Parent));
               else
                  return The_Parent;
               end if;

            --  Object declarations are also a boundary for the transient scope
            --  even if they are not really wrapped. For further details, see
            --  Wrap_Transient_Declaration.

            when N_Object_Declaration          |
                 N_Object_Renaming_Declaration |
                 N_Subtype_Declaration         =>
               return The_Parent;

            --  The expression itself is to be wrapped if its parent is a
            --  compound statement or any other statement where the expression
            --  is known to be scalar

            when N_Accept_Alternative               |
                 N_Attribute_Definition_Clause      |
                 N_Case_Statement                   |
                 N_Code_Statement                   |
                 N_Delay_Alternative                |
                 N_Delay_Until_Statement            |
                 N_Delay_Relative_Statement         |
                 N_Discriminant_Association         |
                 N_Elsif_Part                       |
                 N_Entry_Body_Formal_Part           |
                 N_Exit_Statement                   |
                 N_If_Statement                     |
                 N_Iteration_Scheme                 |
                 N_Terminate_Alternative            =>
               return P;

            when N_Attribute_Reference =>

               if Is_Procedure_Attribute_Name
                    (Attribute_Name (The_Parent))
               then
                  return The_Parent;
               end if;

            --  A raise statement can be wrapped. This will arise when the
            --  expression in a raise_with_expression uses the secondary
            --  stack, for example.

            when N_Raise_Statement =>
               return The_Parent;

            --  If the expression is within the iteration scheme of a loop,
            --  we must create a declaration for it, followed by an assignment
            --  in order to have a usable statement to wrap.

            when N_Loop_Parameter_Specification =>
               return Parent (The_Parent);

            --  The following nodes contains "dummy calls" which don't need to
            --  be wrapped.

            when N_Parameter_Specification     |
                 N_Discriminant_Specification  |
                 N_Component_Declaration       =>
               return Empty;

            --  The return statement is not to be wrapped when the function
            --  itself needs wrapping at the outer-level

            when N_Simple_Return_Statement =>
               declare
                  Applies_To : constant Entity_Id :=
                                 Return_Applies_To
                                   (Return_Statement_Entity (The_Parent));
                  Return_Type : constant Entity_Id := Etype (Applies_To);
               begin
                  if Requires_Transient_Scope (Return_Type) then
                     return Empty;
                  else
                     return The_Parent;
                  end if;
               end;

            --  If we leave a scope without having been able to find a node to
            --  wrap, something is going wrong but this can happen in error
            --  situation that are not detected yet (such as a dynamic string
            --  in a pragma export)

            when N_Subprogram_Body     |
                 N_Package_Declaration |
                 N_Package_Body        |
                 N_Block_Statement     =>
               return Empty;

            --  Otherwise continue the search

            when others =>
               null;
         end case;
      end loop;
   end Find_Node_To_Be_Wrapped;

   -------------------------------------
   -- Get_Global_Pool_For_Access_Type --
   -------------------------------------

   function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is
   begin
      --  Access types whose size is smaller than System.Address size can exist
      --  only on VMS. We can't use the usual global pool which returns an
      --  object of type Address as truncation will make it invalid. To handle
      --  this case, VMS has a dedicated global pool that returns addresses
      --  that fit into 32 bit accesses.

      if Opt.True_VMS_Target and then Esize (T) = 32 then
         return RTE (RE_Global_Pool_32_Object);
      else
         return RTE (RE_Global_Pool_Object);
      end if;
   end Get_Global_Pool_For_Access_Type;

   ----------------------------------
   -- Has_New_Controlled_Component --
   ----------------------------------

   function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
      Comp : Entity_Id;

   begin
      if not Is_Tagged_Type (E) then
         return Has_Controlled_Component (E);
      elsif not Is_Derived_Type (E) then
         return Has_Controlled_Component (E);
      end if;

      Comp := First_Component (E);
      while Present (Comp) loop
         if Chars (Comp) = Name_uParent then
            null;

         elsif Scope (Original_Record_Component (Comp)) = E
           and then Needs_Finalization (Etype (Comp))
         then
            return True;
         end if;

         Next_Component (Comp);
      end loop;

      return False;
   end Has_New_Controlled_Component;

   ---------------------------------
   -- Has_Simple_Protected_Object --
   ---------------------------------

   function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
   begin
      if Has_Task (T) then
         return False;

      elsif Is_Simple_Protected_Type (T) then
         return True;

      elsif Is_Array_Type (T) then
         return Has_Simple_Protected_Object (Component_Type (T));

      elsif Is_Record_Type (T) then
         declare
            Comp : Entity_Id;

         begin
            Comp := First_Component (T);
            while Present (Comp) loop
               if Has_Simple_Protected_Object (Etype (Comp)) then
                  return True;
               end if;

               Next_Component (Comp);
            end loop;

            return False;
         end;

      else
         return False;
      end if;
   end Has_Simple_Protected_Object;

   ------------------------------------
   -- Insert_Actions_In_Scope_Around --
   ------------------------------------

   procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
      SE     : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
      After  : List_Id renames SE.Actions_To_Be_Wrapped_After;
      Before : List_Id renames SE.Actions_To_Be_Wrapped_Before;

      procedure Process_Transient_Objects
        (First_Object : Node_Id;
         Last_Object  : Node_Id;
         Related_Node : Node_Id);
      --  First_Object and Last_Object define a list which contains potential
      --  controlled transient objects. Finalization flags are inserted before
      --  First_Object and finalization calls are inserted after Last_Object.
      --  Related_Node is the node for which transient objects have been
      --  created.

      -------------------------------
      -- Process_Transient_Objects --
      -------------------------------

      procedure Process_Transient_Objects
        (First_Object : Node_Id;
         Last_Object  : Node_Id;
         Related_Node : Node_Id)
      is
         Requires_Hooking : constant Boolean :=
                              Nkind_In (N, N_Function_Call,
                                           N_Procedure_Call_Statement);

         Built     : Boolean := False;
         Desig_Typ : Entity_Id;
         Fin_Block : Node_Id;
         Fin_Data  : Finalization_Exception_Data;
         Fin_Decls : List_Id;
         Last_Fin  : Node_Id := Empty;
         Loc       : Source_Ptr;
         Obj_Id    : Entity_Id;
         Obj_Ref   : Node_Id;
         Obj_Typ   : Entity_Id;
         Stmt      : Node_Id;
         Stmts     : List_Id;
         Temp_Id   : Entity_Id;

      begin
         --  Examine all objects in the list First_Object .. Last_Object

         Stmt := First_Object;
         while Present (Stmt) loop
            if Nkind (Stmt) = N_Object_Declaration
              and then Analyzed (Stmt)
              and then Is_Finalizable_Transient (Stmt, N)

              --  Do not process the node to be wrapped since it will be
              --  handled by the enclosing finalizer.

              and then Stmt /= Related_Node
            then
               Loc       := Sloc (Stmt);
               Obj_Id    := Defining_Identifier (Stmt);
               Obj_Typ   := Base_Type (Etype (Obj_Id));
               Desig_Typ := Obj_Typ;

               Set_Is_Processed_Transient (Obj_Id);

               --  Handle access types

               if Is_Access_Type (Desig_Typ) then
                  Desig_Typ := Available_View (Designated_Type (Desig_Typ));
               end if;

               --  Create the necessary entities and declarations the first
               --  time around.

               if not Built then
                  Fin_Decls := New_List;

                  Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
                  Insert_List_Before_And_Analyze (First_Object, Fin_Decls);

                  Built := True;
               end if;

               --  Transient variables associated with subprogram calls need
               --  extra processing. These variables are usually created right
               --  before the call and finalized immediately after the call.
               --  If an exception occurs during the call, the clean up code
               --  is skipped due to the sudden change in control and the
               --  transient is never finalized.

               --  To handle this case, such variables are "exported" to the
               --  enclosing sequence of statements where their corresponding
               --  "hooks" are picked up by the finalization machinery.

               if Requires_Hooking then
                  declare
                     Expr   : Node_Id;
                     Ptr_Id : Entity_Id;

                  begin
                     --  Step 1: Create an access type which provides a
                     --  reference to the transient object. Generate:

                     --    Ann : access [all] <Desig_Typ>;

                     Ptr_Id := Make_Temporary (Loc, 'A');

                     Insert_Action (Stmt,
                       Make_Full_Type_Declaration (Loc,
                         Defining_Identifier => Ptr_Id,
                         Type_Definition     =>
                           Make_Access_To_Object_Definition (Loc,
                             All_Present        =>
                               Ekind (Obj_Typ) = E_General_Access_Type,
                             Subtype_Indication =>
                               New_Reference_To (Desig_Typ, Loc))));

                     --  Step 2: Create a temporary which acts as a hook to
                     --  the transient object. Generate:

                     --    Temp : Ptr_Id := null;

                     Temp_Id := Make_Temporary (Loc, 'T');

                     Insert_Action (Stmt,
                       Make_Object_Declaration (Loc,
                         Defining_Identifier => Temp_Id,
                         Object_Definition   =>
                           New_Reference_To (Ptr_Id, Loc)));

                     --  Mark the temporary as a transient hook. This signals
                     --  the machinery in Build_Finalizer to recognize this
                     --  special case.

                     Set_Return_Flag_Or_Transient_Decl (Temp_Id, Stmt);

                     --  Step 3: Hook the transient object to the temporary

                     if Is_Access_Type (Obj_Typ) then
                        Expr :=
                          Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
                     else
                        Expr :=
                          Make_Attribute_Reference (Loc,
                            Prefix         => New_Reference_To (Obj_Id, Loc),
                            Attribute_Name => Name_Unrestricted_Access);
                     end if;

                     --  Generate:
                     --    Temp := Ptr_Id (Obj_Id);
                     --      <or>
                     --    Temp := Obj_Id'Unrestricted_Access;

                     Insert_After_And_Analyze (Stmt,
                       Make_Assignment_Statement (Loc,
                         Name       => New_Reference_To (Temp_Id, Loc),
                         Expression => Expr));
                  end;
               end if;

               Stmts := New_List;

               --  The transient object is about to be finalized by the clean
               --  up code following the subprogram call. In order to avoid
               --  double finalization, clear the hook.

               --  Generate:
               --    Temp := null;

               if Requires_Hooking then
                  Append_To (Stmts,
                    Make_Assignment_Statement (Loc,
                      Name       => New_Reference_To (Temp_Id, Loc),
                      Expression => Make_Null (Loc)));
               end if;

               --  Generate:
               --    [Deep_]Finalize (Obj_Ref);

               Obj_Ref := New_Reference_To (Obj_Id, Loc);

               if Is_Access_Type (Obj_Typ) then
                  Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
               end if;

               Append_To (Stmts,
                 Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ));

               --  Generate:
               --    [Temp := null;]
               --    begin
               --       [Deep_]Finalize (Obj_Ref);

               --    exception
               --       when others =>
               --          if not Raised then
               --             Raised := True;
               --             Save_Occurrence
               --               (Enn, Get_Current_Excep.all.all);
               --          end if;
               --    end;

               Fin_Block :=
                 Make_Block_Statement (Loc,
                   Handled_Statement_Sequence =>
                     Make_Handled_Sequence_Of_Statements (Loc,
                       Statements => Stmts,
                       Exception_Handlers => New_List (
                         Build_Exception_Handler (Fin_Data))));

               Insert_After_And_Analyze (Last_Object, Fin_Block);

               --  The raise statement must be inserted after all the
               --  finalization blocks.

               if No (Last_Fin) then
                  Last_Fin := Fin_Block;
               end if;

            --  When the associated node is an array object, the expander may
            --  sometimes generate a loop and create transient objects inside
            --  the loop.

            elsif Nkind (Related_Node) = N_Object_Declaration
              and then Is_Array_Type
                         (Base_Type
                           (Etype (Defining_Identifier (Related_Node))))
              and then Nkind (Stmt) = N_Loop_Statement
            then
               declare
                  Block_HSS : Node_Id := First (Statements (Stmt));

               begin
                  --  The loop statements may have been wrapped in a block by
                  --  Process_Statements_For_Controlled_Objects, inspect the
                  --  handled sequence of statements.

                  if Nkind (Block_HSS) = N_Block_Statement
                    and then No (Next (Block_HSS))
                  then
                     Block_HSS := Handled_Statement_Sequence (Block_HSS);

                     Process_Transient_Objects
                       (First_Object => First (Statements (Block_HSS)),
                        Last_Object  => Last (Statements (Block_HSS)),
                        Related_Node => Related_Node);

                  --  Inspect the statements of the loop

                  else
                     Process_Transient_Objects
                       (First_Object => First (Statements (Stmt)),
                        Last_Object  => Last (Statements (Stmt)),
                        Related_Node => Related_Node);
                  end if;
               end;

            --  Terminate the scan after the last object has been processed

            elsif Stmt = Last_Object then
               exit;
            end if;

            Next (Stmt);
         end loop;

         --  Generate:
         --    if Raised and then not Abort then
         --       Raise_From_Controlled_Operation (E);
         --    end if;

         if Built
           and then Present (Last_Fin)
         then
            Insert_After_And_Analyze (Last_Fin,
              Build_Raise_Statement (Fin_Data));
         end if;
      end Process_Transient_Objects;

   --  Start of processing for Insert_Actions_In_Scope_Around

   begin
      if No (Before) and then No (After) then
         return;
      end if;

      declare
         Node_To_Wrap  : constant Node_Id := Node_To_Be_Wrapped;
         First_Obj  : Node_Id;
         Last_Obj   : Node_Id;
         Target     : Node_Id;

      begin
         --  If the node to be wrapped is the trigger of an asynchronous
         --  select, it is not part of a statement list. The actions must be
         --  inserted before the select itself, which is part of some list of
         --  statements. Note that the triggering alternative includes the
         --  triggering statement and an optional statement list. If the node
         --  to be wrapped is part of that list, the normal insertion applies.

         if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
           and then not Is_List_Member (Node_To_Wrap)
         then
            Target := Parent (Parent (Node_To_Wrap));
         else
            Target := N;
         end if;

         First_Obj := Target;
         Last_Obj  := Target;

         --  Add all actions associated with a transient scope into the main
         --  tree. There are several scenarios here:

         --       +--- Before ----+        +----- After ---+
         --    1) First_Obj ....... Target ........ Last_Obj

         --    2) First_Obj ....... Target

         --    3)                   Target ........ Last_Obj

         if Present (Before) then

            --  Flag declarations are inserted before the first object

            First_Obj := First (Before);

            Insert_List_Before (Target, Before);
         end if;

         if Present (After) then

            --  Finalization calls are inserted after the last object

            Last_Obj := Last (After);

            Insert_List_After (Target, After);
         end if;

         --  Check for transient controlled objects associated with Target and
         --  generate the appropriate finalization actions for them.

         Process_Transient_Objects
           (First_Object => First_Obj,
            Last_Object  => Last_Obj,
            Related_Node => Target);

         --  Reset the action lists

         if Present (Before) then
            Before := No_List;
         end if;

         if Present (After) then
            After := No_List;
         end if;
      end;
   end Insert_Actions_In_Scope_Around;

   ------------------------------
   -- Is_Simple_Protected_Type --
   ------------------------------

   function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
   begin
      return
        Is_Protected_Type (T)
          and then not Has_Entries (T)
          and then Is_RTE (Find_Protection_Type (T), RE_Protection);
   end Is_Simple_Protected_Type;

   -----------------------
   -- Make_Adjust_Call --
   -----------------------

   function Make_Adjust_Call
     (Obj_Ref    : Node_Id;
      Typ        : Entity_Id;
      For_Parent : Boolean := False) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Obj_Ref);
      Adj_Id : Entity_Id := Empty;
      Ref    : Node_Id   := Obj_Ref;
      Utyp   : Entity_Id;

   begin
      --  Recover the proper type which contains Deep_Adjust

      if Is_Class_Wide_Type (Typ) then
         Utyp := Root_Type (Typ);
      else
         Utyp := Typ;
      end if;

      Utyp := Underlying_Type (Base_Type (Utyp));
      Set_Assignment_OK (Ref);

      --  Deal with non-tagged derivation of private views

      if Is_Untagged_Derivation (Typ) then
         Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
         Ref  := Unchecked_Convert_To (Utyp, Ref);
         Set_Assignment_OK (Ref);
      end if;

      --  When dealing with the completion of a private type, use the base
      --  type instead.

      if Utyp /= Base_Type (Utyp) then
         pragma Assert (Is_Private_Type (Typ));

         Utyp := Base_Type (Utyp);
         Ref  := Unchecked_Convert_To (Utyp, Ref);
      end if;

      --  Select the appropriate version of adjust

      if For_Parent then
         if Has_Controlled_Component (Utyp) then
            Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
         end if;

      --  Class-wide types, interfaces and types with controlled components

      elsif Is_Class_Wide_Type (Typ)
        or else Is_Interface (Typ)
        or else Has_Controlled_Component (Utyp)
      then
         if Is_Tagged_Type (Utyp) then
            Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
         else
            Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
         end if;

      --  Derivations from [Limited_]Controlled

      elsif Is_Controlled (Utyp) then
         if Has_Controlled_Component (Utyp) then
            Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
         else
            Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
         end if;

      --  Tagged types

      elsif Is_Tagged_Type (Utyp) then
         Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);

      else
         raise Program_Error;
      end if;

      if Present (Adj_Id) then

         --  If the object is unanalyzed, set its expected type for use in
         --  Convert_View in case an additional conversion is needed.

         if No (Etype (Ref))
           and then Nkind (Ref) /= N_Unchecked_Type_Conversion
         then
            Set_Etype (Ref, Typ);
         end if;

         --  The object reference may need another conversion depending on the
         --  type of the formal and that of the actual.

         if not Is_Class_Wide_Type (Typ) then
            Ref := Convert_View (Adj_Id, Ref);
         end if;

         return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent);
      else
         return Empty;
      end if;
   end Make_Adjust_Call;

   ----------------------
   -- Make_Attach_Call --
   ----------------------

   function Make_Attach_Call
     (Obj_Ref : Node_Id;
      Ptr_Typ : Entity_Id) return Node_Id
   is
      pragma Assert (VM_Target /= No_VM);

      Loc : constant Source_Ptr := Sloc (Obj_Ref);
   begin
      return
        Make_Procedure_Call_Statement (Loc,
          Name                   =>
            New_Reference_To (RTE (RE_Attach), Loc),
          Parameter_Associations => New_List (
            New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
            Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
   end Make_Attach_Call;

   ----------------------
   -- Make_Detach_Call --
   ----------------------

   function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
      Loc : constant Source_Ptr := Sloc (Obj_Ref);

   begin
      return
        Make_Procedure_Call_Statement (Loc,
          Name                   =>
            New_Reference_To (RTE (RE_Detach), Loc),
          Parameter_Associations => New_List (
            Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
   end Make_Detach_Call;

   ---------------
   -- Make_Call --
   ---------------

   function Make_Call
     (Loc        : Source_Ptr;
      Proc_Id    : Entity_Id;
      Param      : Node_Id;
      For_Parent : Boolean := False) return Node_Id
   is
      Params : constant List_Id := New_List (Param);

   begin
      --  When creating a call to Deep_Finalize for a _parent field of a
      --  derived type, disable the invocation of the nested Finalize by giving
      --  the corresponding flag a False value.

      if For_Parent then
         Append_To (Params, New_Reference_To (Standard_False, Loc));
      end if;

      return
        Make_Procedure_Call_Statement (Loc,
          Name                   => New_Reference_To (Proc_Id, Loc),
          Parameter_Associations => Params);
   end Make_Call;

   --------------------------
   -- Make_Deep_Array_Body --
   --------------------------

   function Make_Deep_Array_Body
     (Prim : Final_Primitives;
      Typ  : Entity_Id) return List_Id
   is
      function Build_Adjust_Or_Finalize_Statements
        (Typ : Entity_Id) return List_Id;
      --  Create the statements necessary to adjust or finalize an array of
      --  controlled elements. Generate:
      --
      --    declare
      --       Abort  : constant Boolean := Triggered_By_Abort;
      --         <or>
      --       Abort  : constant Boolean := False;  --  no abort
      --
      --       E      : Exception_Occurrence;
      --       Raised : Boolean := False;
      --
      --    begin
      --       for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
      --                 ^--  in the finalization case
      --          ...
      --          for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
      --             begin
      --                [Deep_]Adjust / Finalize (V (J1, ..., Jn));
      --
      --             exception
      --                when others =>
      --                   if not Raised then
      --                      Raised := True;
      --                      Save_Occurrence (E, Get_Current_Excep.all.all);
      --                   end if;
      --             end;
      --          end loop;
      --          ...
      --       end loop;
      --
      --       if Raised and then not Abort then
      --          Raise_From_Controlled_Operation (E);
      --       end if;
      --    end;

      function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
      --  Create the statements necessary to initialize an array of controlled
      --  elements. Include a mechanism to carry out partial finalization if an
      --  exception occurs. Generate:
      --
      --    declare
      --       Counter : Integer := 0;
      --
      --    begin
      --       for J1 in V'Range (1) loop
      --          ...
      --          for JN in V'Range (N) loop
      --             begin
      --                [Deep_]Initialize (V (J1, ..., JN));
      --
      --                Counter := Counter + 1;
      --
      --             exception
      --                when others =>
      --                   declare
      --                      Abort  : constant Boolean := Triggered_By_Abort;
      --                        <or>
      --                      Abort  : constant Boolean := False; --  no abort
      --                      E      : Exception_Occurence;
      --                      Raised : Boolean := False;

      --                   begin
      --                      Counter :=
      --                        V'Length (1) *
      --                        V'Length (2) *
      --                        ...
      --                        V'Length (N) - Counter;

      --                      for F1 in reverse V'Range (1) loop
      --                         ...
      --                         for FN in reverse V'Range (N) loop
      --                            if Counter > 0 then
      --                               Counter := Counter - 1;
      --                            else
      --                               begin
      --                                  [Deep_]Finalize (V (F1, ..., FN));

      --                               exception
      --                                  when others =>
      --                                     if not Raised then
      --                                        Raised := True;
      --                                        Save_Occurrence (E,
      --                                          Get_Current_Excep.all.all);
      --                                     end if;
      --                               end;
      --                            end if;
      --                         end loop;
      --                         ...
      --                      end loop;
      --                   end;
      --
      --                   if Raised and then not Abort then
      --                      Raise_From_Controlled_Operation (E);
      --                   end if;
      --
      --                   raise;
      --             end;
      --          end loop;
      --       end loop;
      --    end;

      function New_References_To
        (L   : List_Id;
         Loc : Source_Ptr) return List_Id;
      --  Given a list of defining identifiers, return a list of references to
      --  the original identifiers, in the same order as they appear.

      -----------------------------------------
      -- Build_Adjust_Or_Finalize_Statements --
      -----------------------------------------

      function Build_Adjust_Or_Finalize_Statements
        (Typ : Entity_Id) return List_Id
      is
         Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
         Index_List      : constant List_Id    := New_List;
         Loc             : constant Source_Ptr := Sloc (Typ);
         Num_Dims        : constant Int        := Number_Dimensions (Typ);
         Finalizer_Decls : List_Id := No_List;
         Finalizer_Data  : Finalization_Exception_Data;
         Call            : Node_Id;
         Comp_Ref        : Node_Id;
         Core_Loop       : Node_Id;
         Dim             : Int;
         J               : Entity_Id;
         Loop_Id         : Entity_Id;
         Stmts           : List_Id;

         Exceptions_OK : constant Boolean :=
                           not Restriction_Active (No_Exception_Propagation);

         procedure Build_Indices;
         --  Generate the indices used in the dimension loops

         -------------------
         -- Build_Indices --
         -------------------

         procedure Build_Indices is
         begin
            --  Generate the following identifiers:
            --    Jnn  -  for initialization

            for Dim in 1 .. Num_Dims loop
               Append_To (Index_List,
                 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
            end loop;
         end Build_Indices;

      --  Start of processing for Build_Adjust_Or_Finalize_Statements

      begin
         Finalizer_Decls := New_List;

         Build_Indices;
         Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);

         Comp_Ref :=
           Make_Indexed_Component (Loc,
             Prefix      => Make_Identifier (Loc, Name_V),
             Expressions => New_References_To (Index_List, Loc));
         Set_Etype (Comp_Ref, Comp_Typ);

         --  Generate:
         --    [Deep_]Adjust (V (J1, ..., JN))

         if Prim = Adjust_Case then
            Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);

         --  Generate:
         --    [Deep_]Finalize (V (J1, ..., JN))

         else pragma Assert (Prim = Finalize_Case);
            Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
         end if;

         --  Generate the block which houses the adjust or finalize call:

         --    <adjust or finalize call>;  --  No_Exception_Propagation

         --    begin                       --  Exception handlers allowed
         --       <adjust or finalize call>

         --    exception
         --       when others =>
         --          if not Raised then
         --             Raised := True;
         --             Save_Occurrence (E, Get_Current_Excep.all.all);
         --          end if;
         --    end;

         if Exceptions_OK then
            Core_Loop :=
              Make_Block_Statement (Loc,
                Handled_Statement_Sequence =>
                  Make_Handled_Sequence_Of_Statements (Loc,
                    Statements         => New_List (Call),
                    Exception_Handlers => New_List (
                      Build_Exception_Handler (Finalizer_Data))));
         else
            Core_Loop := Call;
         end if;

         --  Generate the dimension loops starting from the innermost one

         --    for Jnn in [reverse] V'Range (Dim) loop
         --       <core loop>
         --    end loop;

         J := Last (Index_List);
         Dim := Num_Dims;
         while Present (J) and then Dim > 0 loop
            Loop_Id := J;
            Prev (J);
            Remove (Loop_Id);

            Core_Loop :=
              Make_Loop_Statement (Loc,
                Iteration_Scheme =>
                  Make_Iteration_Scheme (Loc,
                    Loop_Parameter_Specification =>
                      Make_Loop_Parameter_Specification (Loc,
                        Defining_Identifier         => Loop_Id,
                        Discrete_Subtype_Definition =>
                          Make_Attribute_Reference (Loc,
                            Prefix         => Make_Identifier (Loc, Name_V),
                            Attribute_Name => Name_Range,
                            Expressions    => New_List (
                              Make_Integer_Literal (Loc, Dim))),

                        Reverse_Present => Prim = Finalize_Case)),

                Statements => New_List (Core_Loop),
                End_Label  => Empty);

            Dim := Dim - 1;
         end loop;

         --  Generate the block which contains the core loop, the declarations
         --  of the abort flag, the exception occurrence, the raised flag and
         --  the conditional raise:

         --    declare
         --       Abort  : constant Boolean := Triggered_By_Abort;
         --         <or>
         --       Abort  : constant Boolean := False;  --  no abort

         --       E      : Exception_Occurrence;
         --       Raised : Boolean := False;

         --    begin
         --       <core loop>

         --       if Raised and then not Abort then  --  Expection handlers OK
         --          Raise_From_Controlled_Operation (E);
         --       end if;
         --    end;

         Stmts := New_List (Core_Loop);

         if Exceptions_OK then
            Append_To (Stmts,
              Build_Raise_Statement (Finalizer_Data));
         end if;

         return
           New_List (
             Make_Block_Statement (Loc,
               Declarations               =>
                 Finalizer_Decls,
               Handled_Statement_Sequence =>
                 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
      end Build_Adjust_Or_Finalize_Statements;

      ---------------------------------
      -- Build_Initialize_Statements --
      ---------------------------------

      function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
         Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
         Final_List      : constant List_Id    := New_List;
         Index_List      : constant List_Id    := New_List;
         Loc             : constant Source_Ptr := Sloc (Typ);
         Num_Dims        : constant Int        := Number_Dimensions (Typ);
         Counter_Id      : Entity_Id;
         Dim             : Int;
         F               : Node_Id;
         Fin_Stmt        : Node_Id;
         Final_Block     : Node_Id;
         Final_Loop      : Node_Id;
         Finalizer_Data  : Finalization_Exception_Data;
         Finalizer_Decls : List_Id := No_List;
         Init_Loop       : Node_Id;
         J               : Node_Id;
         Loop_Id         : Node_Id;
         Stmts           : List_Id;

         Exceptions_OK : constant Boolean :=
                           not Restriction_Active (No_Exception_Propagation);

         function Build_Counter_Assignment return Node_Id;
         --  Generate the following assignment:
         --    Counter := V'Length (1) *
         --               ...
         --               V'Length (N) - Counter;

         function Build_Finalization_Call return Node_Id;
         --  Generate a deep finalization call for an array element

         procedure Build_Indices;
         --  Generate the initialization and finalization indices used in the
         --  dimension loops.

         function Build_Initialization_Call return Node_Id;
         --  Generate a deep initialization call for an array element

         ------------------------------
         -- Build_Counter_Assignment --
         ------------------------------

         function Build_Counter_Assignment return Node_Id is
            Dim  : Int;
            Expr : Node_Id;

         begin
            --  Start from the first dimension and generate:
            --    V'Length (1)

            Dim := 1;
            Expr :=
              Make_Attribute_Reference (Loc,
                Prefix         => Make_Identifier (Loc, Name_V),
                Attribute_Name => Name_Length,
                Expressions    => New_List (Make_Integer_Literal (Loc, Dim)));

            --  Process the rest of the dimensions, generate:
            --    Expr * V'Length (N)

            Dim := Dim + 1;
            while Dim <= Num_Dims loop
               Expr :=
                 Make_Op_Multiply (Loc,
                   Left_Opnd  => Expr,
                   Right_Opnd =>
                     Make_Attribute_Reference (Loc,
                       Prefix         => Make_Identifier (Loc, Name_V),
                       Attribute_Name => Name_Length,
                       Expressions    => New_List (
                         Make_Integer_Literal (Loc, Dim))));

               Dim := Dim + 1;
            end loop;

            --  Generate:
            --    Counter := Expr - Counter;

            return
              Make_Assignment_Statement (Loc,
                Name       => New_Reference_To (Counter_Id, Loc),
                Expression =>
                  Make_Op_Subtract (Loc,
                    Left_Opnd  => Expr,
                    Right_Opnd => New_Reference_To (Counter_Id, Loc)));
         end Build_Counter_Assignment;

         -----------------------------
         -- Build_Finalization_Call --
         -----------------------------

         function Build_Finalization_Call return Node_Id is
            Comp_Ref : constant Node_Id :=
                         Make_Indexed_Component (Loc,
                           Prefix      => Make_Identifier (Loc, Name_V),
                           Expressions => New_References_To (Final_List, Loc));

         begin
            Set_Etype (Comp_Ref, Comp_Typ);

            --  Generate:
            --    [Deep_]Finalize (V);

            return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
         end Build_Finalization_Call;

         -------------------
         -- Build_Indices --
         -------------------

         procedure Build_Indices is
         begin
            --  Generate the following identifiers:
            --    Jnn  -  for initialization
            --    Fnn  -  for finalization

            for Dim in 1 .. Num_Dims loop
               Append_To (Index_List,
                 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));

               Append_To (Final_List,
                 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
            end loop;
         end Build_Indices;

         -------------------------------
         -- Build_Initialization_Call --
         -------------------------------

         function Build_Initialization_Call return Node_Id is
            Comp_Ref : constant Node_Id :=
                         Make_Indexed_Component (Loc,
                           Prefix      => Make_Identifier (Loc, Name_V),
                           Expressions => New_References_To (Index_List, Loc));

         begin
            Set_Etype (Comp_Ref, Comp_Typ);

            --  Generate:
            --    [Deep_]Initialize (V (J1, ..., JN));

            return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
         end Build_Initialization_Call;

      --  Start of processing for Build_Initialize_Statements

      begin
         Counter_Id := Make_Temporary (Loc, 'C');
         Finalizer_Decls := New_List;

         Build_Indices;
         Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);

         --  Generate the block which houses the finalization call, the index
         --  guard and the handler which triggers Program_Error later on.

         --    if Counter > 0 then
         --       Counter := Counter - 1;
         --    else
         --       [Deep_]Finalize (V (F1, ..., FN));  --  No_Except_Propagation

         --       begin                               --  Exceptions allowed
         --          [Deep_]Finalize (V (F1, ..., FN));
         --       exception
         --          when others =>
         --             if not Raised then
         --                Raised := True;
         --                Save_Occurrence (E, Get_Current_Excep.all.all);
         --             end if;
         --       end;
         --    end if;

         if Exceptions_OK then
            Fin_Stmt :=
              Make_Block_Statement (Loc,
                Handled_Statement_Sequence =>
                  Make_Handled_Sequence_Of_Statements (Loc,
                    Statements         => New_List (Build_Finalization_Call),
                    Exception_Handlers => New_List (
                      Build_Exception_Handler (Finalizer_Data))));
         else
            Fin_Stmt := Build_Finalization_Call;
         end if;

         --  This is the core of the loop, the dimension iterators are added
         --  one by one in reverse.

         Final_Loop :=
           Make_If_Statement (Loc,
             Condition =>
               Make_Op_Gt (Loc,
                 Left_Opnd  => New_Reference_To (Counter_Id, Loc),
                 Right_Opnd => Make_Integer_Literal (Loc, 0)),

             Then_Statements => New_List (
               Make_Assignment_Statement (Loc,
                 Name       => New_Reference_To (Counter_Id, Loc),
                 Expression =>
                   Make_Op_Subtract (Loc,
                     Left_Opnd  => New_Reference_To (Counter_Id, Loc),
                     Right_Opnd => Make_Integer_Literal (Loc, 1)))),

             Else_Statements => New_List (Fin_Stmt));

         --  Generate all finalization loops starting from the innermost
         --  dimension.

         --    for Fnn in reverse V'Range (Dim) loop
         --       <final loop>
         --    end loop;

         F := Last (Final_List);
         Dim := Num_Dims;
         while Present (F) and then Dim > 0 loop
            Loop_Id := F;
            Prev (F);
            Remove (Loop_Id);

            Final_Loop :=
              Make_Loop_Statement (Loc,
                Iteration_Scheme =>
                  Make_Iteration_Scheme (Loc,
                    Loop_Parameter_Specification =>
                      Make_Loop_Parameter_Specification (Loc,
                        Defining_Identifier => Loop_Id,
                        Discrete_Subtype_Definition =>
                          Make_Attribute_Reference (Loc,
                            Prefix         => Make_Identifier (Loc, Name_V),
                            Attribute_Name => Name_Range,
                            Expressions    => New_List (
                              Make_Integer_Literal (Loc, Dim))),

                        Reverse_Present => True)),

                Statements => New_List (Final_Loop),
                End_Label => Empty);

            Dim := Dim - 1;
         end loop;

         --  Generate the block which contains the finalization loops, the
         --  declarations of the abort flag, the exception occurrence, the
         --  raised flag and the conditional raise.

         --    declare
         --       Abort  : constant Boolean := Triggered_By_Abort;
         --         <or>
         --       Abort  : constant Boolean := False;  --  no abort

         --       E      : Exception_Occurrence;
         --       Raised : Boolean := False;

         --    begin
         --       Counter :=
         --         V'Length (1) *
         --         ...
         --         V'Length (N) - Counter;

         --       <final loop>

         --       if Raised and then not Abort then  --  Exception handlers OK
         --          Raise_From_Controlled_Operation (E);
         --       end if;

         --       raise;  --  Exception handlers OK
         --    end;

         Stmts := New_List (Build_Counter_Assignment, Final_Loop);

         if Exceptions_OK then
            Append_To (Stmts,
              Build_Raise_Statement (Finalizer_Data));
            Append_To (Stmts, Make_Raise_Statement (Loc));
         end if;

         Final_Block :=
           Make_Block_Statement (Loc,
             Declarations               =>
               Finalizer_Decls,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));

         --  Generate the block which contains the initialization call and
         --  the partial finalization code.

         --    begin
         --       [Deep_]Initialize (V (J1, ..., JN));

         --       Counter := Counter + 1;

         --    exception
         --       when others =>
         --          <finalization code>
         --    end;

         Init_Loop :=
           Make_Block_Statement (Loc,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 Statements         => New_List (Build_Initialization_Call),
                 Exception_Handlers => New_List (
                   Make_Exception_Handler (Loc,
                     Exception_Choices => New_List (Make_Others_Choice (Loc)),
                     Statements        => New_List (Final_Block)))));

         Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
           Make_Assignment_Statement (Loc,
             Name       => New_Reference_To (Counter_Id, Loc),
             Expression =>
               Make_Op_Add (Loc,
                 Left_Opnd  => New_Reference_To (Counter_Id, Loc),
                 Right_Opnd => Make_Integer_Literal (Loc, 1))));

         --  Generate all initialization loops starting from the innermost
         --  dimension.

         --    for Jnn in V'Range (Dim) loop
         --       <init loop>
         --    end loop;

         J := Last (Index_List);
         Dim := Num_Dims;
         while Present (J) and then Dim > 0 loop
            Loop_Id := J;
            Prev (J);
            Remove (Loop_Id);

            Init_Loop :=
              Make_Loop_Statement (Loc,
                Iteration_Scheme =>
                  Make_Iteration_Scheme (Loc,
                    Loop_Parameter_Specification =>
                      Make_Loop_Parameter_Specification (Loc,
                        Defining_Identifier => Loop_Id,
                        Discrete_Subtype_Definition =>
                          Make_Attribute_Reference (Loc,
                            Prefix         => Make_Identifier (Loc, Name_V),
                            Attribute_Name => Name_Range,
                            Expressions    => New_List (
                              Make_Integer_Literal (Loc, Dim))))),

                Statements => New_List (Init_Loop),
                End_Label => Empty);

            Dim := Dim - 1;
         end loop;

         --  Generate the block which contains the counter variable and the
         --  initialization loops.

         --    declare
         --       Counter : Integer := 0;
         --    begin
         --       <init loop>
         --    end;

         return
           New_List (
             Make_Block_Statement (Loc,
               Declarations               => New_List (
                 Make_Object_Declaration (Loc,
                   Defining_Identifier => Counter_Id,
                   Object_Definition   =>
                     New_Reference_To (Standard_Integer, Loc),
                   Expression          => Make_Integer_Literal (Loc, 0))),

               Handled_Statement_Sequence =>
                 Make_Handled_Sequence_Of_Statements (Loc,
                   Statements => New_List (Init_Loop))));
      end Build_Initialize_Statements;

      -----------------------
      -- New_References_To --
      -----------------------

      function New_References_To
        (L   : List_Id;
         Loc : Source_Ptr) return List_Id
      is
         Refs : constant List_Id := New_List;
         Id   : Node_Id;

      begin
         Id := First (L);
         while Present (Id) loop
            Append_To (Refs, New_Reference_To (Id, Loc));
            Next (Id);
         end loop;

         return Refs;
      end New_References_To;

   --  Start of processing for Make_Deep_Array_Body

   begin
      case Prim is
         when Address_Case =>
            return Make_Finalize_Address_Stmts (Typ);

         when Adjust_Case   |
              Finalize_Case =>
            return Build_Adjust_Or_Finalize_Statements (Typ);

         when Initialize_Case =>
            return Build_Initialize_Statements (Typ);
      end case;
   end Make_Deep_Array_Body;

   --------------------
   -- Make_Deep_Proc --
   --------------------

   function Make_Deep_Proc
     (Prim  : Final_Primitives;
      Typ   : Entity_Id;
      Stmts : List_Id) return Entity_Id
   is
      Loc     : constant Source_Ptr := Sloc (Typ);
      Formals : List_Id;
      Proc_Id : Entity_Id;

   begin
      --  Create the object formal, generate:
      --    V : System.Address

      if Prim = Address_Case then
         Formals := New_List (
           Make_Parameter_Specification (Loc,
             Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
             Parameter_Type      => New_Reference_To (RTE (RE_Address), Loc)));

      --  Default case

      else
         --  V : in out Typ

         Formals := New_List (
           Make_Parameter_Specification (Loc,
             Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
             In_Present          => True,
             Out_Present         => True,
             Parameter_Type      => New_Reference_To (Typ, Loc)));

         --  F : Boolean := True

         if Prim = Adjust_Case
           or else Prim = Finalize_Case
         then
            Append_To (Formals,
              Make_Parameter_Specification (Loc,
                Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
                Parameter_Type      =>
                  New_Reference_To (Standard_Boolean, Loc),
                Expression          =>
                  New_Reference_To (Standard_True, Loc)));
         end if;
      end if;

      Proc_Id :=
        Make_Defining_Identifier (Loc,
          Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));

      --  Generate:
      --    procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
      --    begin
      --       <stmts>
      --    exception                --  Finalize and Adjust cases only
      --       raise Program_Error;
      --    end Deep_Initialize / Adjust / Finalize;

      --       or

      --    procedure Finalize_Address (V : System.Address) is
      --    begin
      --       <stmts>
      --    end Finalize_Address;

      Discard_Node (
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Procedure_Specification (Loc,
              Defining_Unit_Name       => Proc_Id,
              Parameter_Specifications => Formals),

          Declarations => Empty_List,

          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));

      return Proc_Id;
   end Make_Deep_Proc;

   ---------------------------
   -- Make_Deep_Record_Body --
   ---------------------------

   function Make_Deep_Record_Body
     (Prim     : Final_Primitives;
      Typ      : Entity_Id;
      Is_Local : Boolean := False) return List_Id
   is
      function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
      --  Build the statements necessary to adjust a record type. The type may
      --  have discriminants and contain variant parts. Generate:
      --
      --    begin
      --       begin
      --          [Deep_]Adjust (V.Comp_1);
      --       exception
      --          when Id : others =>
      --             if not Raised then
      --                Raised := True;
      --                Save_Occurrence (E, Get_Current_Excep.all.all);
      --             end if;
      --       end;
      --       .  .  .
      --       begin
      --          [Deep_]Adjust (V.Comp_N);
      --       exception
      --          when Id : others =>
      --             if not Raised then
      --                Raised := True;
      --                Save_Occurrence (E, Get_Current_Excep.all.all);
      --             end if;
      --       end;
      --
      --       begin
      --          Deep_Adjust (V._parent, False);  --  If applicable
      --       exception
      --          when Id : others =>
      --             if not Raised then
      --                Raised := True;
      --                Save_Occurrence (E, Get_Current_Excep.all.all);
      --             end if;
      --       end;
      --
      --       if F then
      --          begin
      --             Adjust (V);  --  If applicable
      --          exception
      --             when others =>
      --                if not Raised then
      --                   Raised := True;
      --                   Save_Occurence (E, Get_Current_Excep.all.all);
      --                end if;
      --          end;
      --       end if;
      --
      --       if Raised and then not Abort then
      --          Raise_From_Controlled_Operation (E);
      --       end if;
      --    end;

      function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
      --  Build the statements necessary to finalize a record type. The type
      --  may have discriminants and contain variant parts. Generate:
      --
      --    declare
      --       Abort  : constant Boolean := Triggered_By_Abort;
      --         <or>
      --       Abort  : constant Boolean := False;  --  no abort
      --       E      : Exception_Occurence;
      --       Raised : Boolean := False;
      --
      --    begin
      --       if F then
      --          begin
      --             Finalize (V);  --  If applicable
      --          exception
      --             when others =>
      --                if not Raised then
      --                   Raised := True;
      --                   Save_Occurence (E, Get_Current_Excep.all.all);
      --                end if;
      --          end;
      --       end if;
      --
      --       case Variant_1 is
      --          when Value_1 =>
      --             case State_Counter_N =>  --  If Is_Local is enabled
      --                when N =>                 .
      --                   goto LN;               .
      --                ...                       .
      --                when 1 =>                 .
      --                   goto L1;               .
      --                when others =>            .
      --                   goto L0;               .
      --             end case;                    .
      --
      --             <<LN>>                   --  If Is_Local is enabled
      --             begin
      --                [Deep_]Finalize (V.Comp_N);
      --             exception
      --                when others =>
      --                   if not Raised then
      --                      Raised := True;
      --                      Save_Occurence (E, Get_Current_Excep.all.all);
      --                   end if;
      --             end;
      --             .  .  .
      --             <<L1>>
      --             begin
      --                [Deep_]Finalize (V.Comp_1);
      --             exception
      --                when others =>
      --                   if not Raised then
      --                      Raised := True;
      --                      Save_Occurence (E, Get_Current_Excep.all.all);
      --                   end if;
      --             end;
      --             <<L0>>
      --       end case;
      --
      --       case State_Counter_1 =>  --  If Is_Local is enabled
      --          when M =>                 .
      --             goto LM;               .
      --       ...
      --
      --       begin
      --          Deep_Finalize (V._parent, False);  --  If applicable
      --       exception
      --          when Id : others =>
      --             if not Raised then
      --                Raised := True;
      --                Save_Occurrence (E, Get_Current_Excep.all.all);
      --             end if;
      --       end;
      --
      --       if Raised and then not Abort then
      --          Raise_From_Controlled_Operation (E);
      --       end if;
      --    end;

      function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
      --  Given a derived tagged type Typ, traverse all components, find field
      --  _parent and return its type.

      procedure Preprocess_Components
        (Comps     : Node_Id;
         Num_Comps : out Int;
         Has_POC   : out Boolean);
      --  Examine all components in component list Comps, count all controlled
      --  components and determine whether at least one of them is per-object
      --  constrained. Component _parent is always skipped.

      -----------------------------
      -- Build_Adjust_Statements --
      -----------------------------

      function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
         Loc             : constant Source_Ptr := Sloc (Typ);
         Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
         Bod_Stmts       : List_Id;
         Finalizer_Data  : Finalization_Exception_Data;
         Finalizer_Decls : List_Id := No_List;
         Rec_Def         : Node_Id;
         Var_Case        : Node_Id;

         Exceptions_OK : constant Boolean :=
                           not Restriction_Active (No_Exception_Propagation);

         function Process_Component_List_For_Adjust
           (Comps : Node_Id) return List_Id;
         --  Build all necessary adjust statements for a single component list

         ---------------------------------------
         -- Process_Component_List_For_Adjust --
         ---------------------------------------

         function Process_Component_List_For_Adjust
           (Comps : Node_Id) return List_Id
         is
            Stmts     : constant List_Id := New_List;
            Decl      : Node_Id;
            Decl_Id   : Entity_Id;
            Decl_Typ  : Entity_Id;
            Has_POC   : Boolean;
            Num_Comps : Int;

            procedure Process_Component_For_Adjust (Decl : Node_Id);
            --  Process the declaration of a single controlled component

            ----------------------------------
            -- Process_Component_For_Adjust --
            ----------------------------------

            procedure Process_Component_For_Adjust (Decl : Node_Id) is
               Id       : constant Entity_Id := Defining_Identifier (Decl);
               Typ      : constant Entity_Id := Etype (Id);
               Adj_Stmt : Node_Id;

            begin
               --  Generate:
               --    [Deep_]Adjust (V.Id);  --  No_Exception_Propagation

               --    begin                  --  Exception handlers allowed
               --       [Deep_]Adjust (V.Id);
               --    exception
               --       when others =>
               --          if not Raised then
               --             Raised := True;
               --             Save_Occurrence (E, Get_Current_Excep.all.all);
               --          end if;
               --    end;

               Adj_Stmt :=
                 Make_Adjust_Call (
                   Obj_Ref =>
                     Make_Selected_Component (Loc,
                       Prefix        => Make_Identifier (Loc, Name_V),
                       Selector_Name => Make_Identifier (Loc, Chars (Id))),
                   Typ     => Typ);

               if Exceptions_OK then
                  Adj_Stmt :=
                    Make_Block_Statement (Loc,
                      Handled_Statement_Sequence =>
                        Make_Handled_Sequence_Of_Statements (Loc,
                          Statements         => New_List (Adj_Stmt),
                          Exception_Handlers => New_List (
                            Build_Exception_Handler (Finalizer_Data))));
               end if;

               Append_To (Stmts, Adj_Stmt);
            end Process_Component_For_Adjust;

         --  Start of processing for Process_Component_List_For_Adjust

         begin
            --  Perform an initial check, determine the number of controlled
            --  components in the current list and whether at least one of them
            --  is per-object constrained.

            Preprocess_Components (Comps, Num_Comps, Has_POC);

            --  The processing in this routine is done in the following order:
            --    1) Regular components
            --    2) Per-object constrained components
            --    3) Variant parts

            if Num_Comps > 0 then

               --  Process all regular components in order of declarations

               Decl := First_Non_Pragma (Component_Items (Comps));
               while Present (Decl) loop
                  Decl_Id  := Defining_Identifier (Decl);
                  Decl_Typ := Etype (Decl_Id);

                  --  Skip _parent as well as per-object constrained components

                  if Chars (Decl_Id) /= Name_uParent
                    and then Needs_Finalization (Decl_Typ)
                  then
                     if Has_Access_Constraint (Decl_Id)
                       and then No (Expression (Decl))
                     then
                        null;
                     else
                        Process_Component_For_Adjust (Decl);
                     end if;
                  end if;

                  Next_Non_Pragma (Decl);
               end loop;

               --  Process all per-object constrained components in order of
               --  declarations.

               if Has_POC then
                  Decl := First_Non_Pragma (Component_Items (Comps));
                  while Present (Decl) loop
                     Decl_Id  := Defining_Identifier (Decl);
                     Decl_Typ := Etype (Decl_Id);

                     --  Skip _parent

                     if Chars (Decl_Id) /= Name_uParent
                       and then Needs_Finalization (Decl_Typ)
                       and then Has_Access_Constraint (Decl_Id)
                       and then No (Expression (Decl))
                     then
                        Process_Component_For_Adjust (Decl);
                     end if;

                     Next_Non_Pragma (Decl);
                  end loop;
               end if;
            end if;

            --  Process all variants, if any

            Var_Case := Empty;
            if Present (Variant_Part (Comps)) then
               declare
                  Var_Alts : constant List_Id := New_List;
                  Var      : Node_Id;

               begin
                  Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
                  while Present (Var) loop

                     --  Generate:
                     --     when <discrete choices> =>
                     --        <adjust statements>

                     Append_To (Var_Alts,
                       Make_Case_Statement_Alternative (Loc,
                         Discrete_Choices =>
                           New_Copy_List (Discrete_Choices (Var)),
                         Statements       =>
                           Process_Component_List_For_Adjust (
                             Component_List (Var))));

                     Next_Non_Pragma (Var);
                  end loop;

                  --  Generate:
                  --     case V.<discriminant> is
                  --        when <discrete choices 1> =>
                  --           <adjust statements 1>
                  --        ...
                  --        when <discrete choices N> =>
                  --           <adjust statements N>
                  --     end case;

                  Var_Case :=
                    Make_Case_Statement (Loc,
                      Expression =>
                        Make_Selected_Component (Loc,
                          Prefix        => Make_Identifier (Loc, Name_V),
                          Selector_Name =>
                            Make_Identifier (Loc,
                              Chars => Chars (Name (Variant_Part (Comps))))),
                      Alternatives => Var_Alts);
               end;
            end if;

            --  Add the variant case statement to the list of statements

            if Present (Var_Case) then
               Append_To (Stmts, Var_Case);
            end if;

            --  If the component list did not have any controlled components
            --  nor variants, return null.

            if Is_Empty_List (Stmts) then
               Append_To (Stmts, Make_Null_Statement (Loc));
            end if;

            return Stmts;
         end Process_Component_List_For_Adjust;

      --  Start of processing for Build_Adjust_Statements

      begin
         Finalizer_Decls := New_List;
         Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);

         if Nkind (Typ_Def) = N_Derived_Type_Definition then
            Rec_Def := Record_Extension_Part (Typ_Def);
         else
            Rec_Def := Typ_Def;
         end if;

         --  Create an adjust sequence for all record components

         if Present (Component_List (Rec_Def)) then
            Bod_Stmts :=
              Process_Component_List_For_Adjust (Component_List (Rec_Def));
         end if;

         --  A derived record type must adjust all inherited components. This
         --  action poses the following problem:

         --    procedure Deep_Adjust (Obj : in out Parent_Typ) is
         --    begin
         --       Adjust (Obj);
         --       ...

         --    procedure Deep_Adjust (Obj : in out Derived_Typ) is
         --    begin
         --       Deep_Adjust (Obj._parent);
         --       ...
         --       Adjust (Obj);
         --       ...

         --  Adjusting the derived type will invoke Adjust of the parent and
         --  then that of the derived type. This is undesirable because both
         --  routines may modify shared components. Only the Adjust of the
         --  derived type should be invoked.

         --  To prevent this double adjustment of shared components,
         --  Deep_Adjust uses a flag to control the invocation of Adjust:

         --    procedure Deep_Adjust
         --      (Obj  : in out Some_Type;
         --       Flag : Boolean := True)
         --    is
         --    begin
         --       if Flag then
         --          Adjust (Obj);
         --       end if;
         --       ...

         --  When Deep_Adjust is invokes for field _parent, a value of False is
         --  provided for the flag:

         --    Deep_Adjust (Obj._parent, False);

         if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
            declare
               Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
               Adj_Stmt : Node_Id;
               Call     : Node_Id;

            begin
               if Needs_Finalization (Par_Typ) then
                  Call :=
                    Make_Adjust_Call
                      (Obj_Ref    =>
                         Make_Selected_Component (Loc,
                           Prefix        => Make_Identifier (Loc, Name_V),
                           Selector_Name =>
                             Make_Identifier (Loc, Name_uParent)),
                       Typ        => Par_Typ,
                       For_Parent => True);

                  --  Generate:
                  --    Deep_Adjust (V._parent, False);  --  No_Except_Propagat

                  --    begin                            --  Exceptions OK
                  --       Deep_Adjust (V._parent, False);
                  --    exception
                  --       when Id : others =>
                  --          if not Raised then
                  --             Raised := True;
                  --             Save_Occurrence (E,
                  --               Get_Current_Excep.all.all);
                  --          end if;
                  --    end;

                  if Present (Call) then
                     Adj_Stmt := Call;

                     if Exceptions_OK then
                        Adj_Stmt :=
                          Make_Block_Statement (Loc,
                            Handled_Statement_Sequence =>
                              Make_Handled_Sequence_Of_Statements (Loc,
                                Statements         => New_List (Adj_Stmt),
                                Exception_Handlers => New_List (
                                  Build_Exception_Handler (Finalizer_Data))));
                     end if;

                     Prepend_To (Bod_Stmts, Adj_Stmt);
                  end if;
               end if;
            end;
         end if;

         --  Adjust the object. This action must be performed last after all
         --  components have been adjusted.

         if Is_Controlled (Typ) then
            declare
               Adj_Stmt : Node_Id;
               Proc     : Entity_Id;

            begin
               Proc := Find_Prim_Op (Typ, Name_Adjust);

               --  Generate:
               --    if F then
               --       Adjust (V);  --  No_Exception_Propagation

               --       begin        --  Exception handlers allowed
               --          Adjust (V);
               --       exception
               --          when others =>
               --             if not Raised then
               --                Raised := True;
               --                Save_Occurrence (E,
               --                  Get_Current_Excep.all.all);
               --             end if;
               --       end;
               --    end if;

               if Present (Proc) then
                  Adj_Stmt :=
                    Make_Procedure_Call_Statement (Loc,
                      Name                   => New_Reference_To (Proc, Loc),
                      Parameter_Associations => New_List (
                        Make_Identifier (Loc, Name_V)));

                  if Exceptions_OK then
                     Adj_Stmt :=
                       Make_Block_Statement (Loc,
                         Handled_Statement_Sequence =>
                           Make_Handled_Sequence_Of_Statements (Loc,
                             Statements         => New_List (Adj_Stmt),
                             Exception_Handlers => New_List (
                               Build_Exception_Handler
                                 (Finalizer_Data))));
                  end if;

                  Append_To (Bod_Stmts,
                    Make_If_Statement (Loc,
                      Condition       => Make_Identifier (Loc, Name_F),
                      Then_Statements => New_List (Adj_Stmt)));
               end if;
            end;
         end if;

         --  At this point either all adjustment statements have been generated
         --  or the type is not controlled.

         if Is_Empty_List (Bod_Stmts) then
            Append_To (Bod_Stmts, Make_Null_Statement (Loc));

            return Bod_Stmts;

         --  Generate:
         --    declare
         --       Abort  : constant Boolean := Triggered_By_Abort;
         --         <or>
         --       Abort  : constant Boolean := False;  --  no abort

         --       E      : Exception_Occurence;
         --       Raised : Boolean := False;

         --    begin
         --       <adjust statements>

         --       if Raised and then not Abort then
         --          Raise_From_Controlled_Operation (E);
         --       end if;
         --    end;

         else
            if Exceptions_OK then
               Append_To (Bod_Stmts,
                 Build_Raise_Statement (Finalizer_Data));
            end if;

            return
              New_List (
                Make_Block_Statement (Loc,
                  Declarations               =>
                    Finalizer_Decls,
                  Handled_Statement_Sequence =>
                    Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
         end if;
      end Build_Adjust_Statements;

      -------------------------------
      -- Build_Finalize_Statements --
      -------------------------------

      function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
         Loc             : constant Source_Ptr := Sloc (Typ);
         Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
         Bod_Stmts       : List_Id;
         Counter         : Int := 0;
         Finalizer_Data  : Finalization_Exception_Data;
         Finalizer_Decls : List_Id := No_List;
         Rec_Def         : Node_Id;
         Var_Case        : Node_Id;

         Exceptions_OK : constant Boolean :=
                           not Restriction_Active (No_Exception_Propagation);

         function Process_Component_List_For_Finalize
           (Comps : Node_Id) return List_Id;
         --  Build all necessary finalization statements for a single component
         --  list. The statements may include a jump circuitry if flag Is_Local
         --  is enabled.

         -----------------------------------------
         -- Process_Component_List_For_Finalize --
         -----------------------------------------

         function Process_Component_List_For_Finalize
           (Comps : Node_Id) return List_Id
         is
            Alts       : List_Id;
            Counter_Id : Entity_Id;
            Decl       : Node_Id;
            Decl_Id    : Entity_Id;
            Decl_Typ   : Entity_Id;
            Decls      : List_Id;
            Has_POC    : Boolean;
            Jump_Block : Node_Id;
            Label      : Node_Id;
            Label_Id   : Entity_Id;
            Num_Comps  : Int;
            Stmts      : List_Id;

            procedure Process_Component_For_Finalize
              (Decl  : Node_Id;
               Alts  : List_Id;
               Decls : List_Id;
               Stmts : List_Id);
            --  Process the declaration of a single controlled component. If
            --  flag Is_Local is enabled, create the corresponding label and
            --  jump circuitry. Alts is the list of case alternatives, Decls
            --  is the top level declaration list where labels are declared
            --  and Stmts is the list of finalization actions.

            ------------------------------------
            -- Process_Component_For_Finalize --
            ------------------------------------

            procedure Process_Component_For_Finalize
              (Decl  : Node_Id;
               Alts  : List_Id;
               Decls : List_Id;
               Stmts : List_Id)
            is
               Id       : constant Entity_Id := Defining_Identifier (Decl);
               Typ      : constant Entity_Id := Etype (Id);
               Fin_Stmt : Node_Id;

            begin
               if Is_Local then
                  declare
                     Label    : Node_Id;
                     Label_Id : Entity_Id;

                  begin
                     --  Generate:
                     --    LN : label;

                     Label_Id :=
                       Make_Identifier (Loc,
                         Chars => New_External_Name ('L', Num_Comps));
                     Set_Entity (Label_Id,
                       Make_Defining_Identifier (Loc, Chars (Label_Id)));
                     Label := Make_Label (Loc, Label_Id);

                     Append_To (Decls,
                       Make_Implicit_Label_Declaration (Loc,
                         Defining_Identifier => Entity (Label_Id),
                         Label_Construct     => Label));

                     --  Generate:
                     --    when N =>
                     --      goto LN;

                     Append_To (Alts,
                       Make_Case_Statement_Alternative (Loc,
                         Discrete_Choices => New_List (
                           Make_Integer_Literal (Loc, Num_Comps)),

                         Statements => New_List (
                           Make_Goto_Statement (Loc,
                             Name =>
                               New_Reference_To (Entity (Label_Id), Loc)))));

                     --  Generate:
                     --    <<LN>>

                     Append_To (Stmts, Label);

                     --  Decrease the number of components to be processed.
                     --  This action yields a new Label_Id in future calls.

                     Num_Comps := Num_Comps - 1;
                  end;
               end if;

               --  Generate:
               --    [Deep_]Finalize (V.Id);  --  No_Exception_Propagation

               --    begin                    --  Exception handlers allowed
               --       [Deep_]Finalize (V.Id);
               --    exception
               --       when others =>
               --          if not Raised then
               --             Raised := True;
               --             Save_Occurrence (E,
               --               Get_Current_Excep.all.all);
               --          end if;
               --    end;

               Fin_Stmt :=
                 Make_Final_Call
                   (Obj_Ref =>
                      Make_Selected_Component (Loc,
                        Prefix        => Make_Identifier (Loc, Name_V),
                        Selector_Name => Make_Identifier (Loc, Chars (Id))),
                    Typ     => Typ);

               if not Restriction_Active (No_Exception_Propagation) then
                  Fin_Stmt :=
                    Make_Block_Statement (Loc,
                      Handled_Statement_Sequence =>
                        Make_Handled_Sequence_Of_Statements (Loc,
                          Statements         => New_List (Fin_Stmt),
                          Exception_Handlers => New_List (
                            Build_Exception_Handler (Finalizer_Data))));
               end if;

               Append_To (Stmts, Fin_Stmt);
            end Process_Component_For_Finalize;

         --  Start of processing for Process_Component_List_For_Finalize

         begin
            --  Perform an initial check, look for controlled and per-object
            --  constrained components.

            Preprocess_Components (Comps, Num_Comps, Has_POC);

            --  Create a state counter to service the current component list.
            --  This step is performed before the variants are inspected in
            --  order to generate the same state counter names as those from
            --  Build_Initialize_Statements.

            if Num_Comps > 0
              and then Is_Local
            then
               Counter := Counter + 1;

               Counter_Id :=
                 Make_Defining_Identifier (Loc,
                   Chars => New_External_Name ('C', Counter));
            end if;

            --  Process the component in the following order:
            --    1) Variants
            --    2) Per-object constrained components
            --    3) Regular components

            --  Start with the variant parts

            Var_Case := Empty;
            if Present (Variant_Part (Comps)) then
               declare
                  Var_Alts : constant List_Id := New_List;
                  Var      : Node_Id;

               begin
                  Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
                  while Present (Var) loop

                     --  Generate:
                     --     when <discrete choices> =>
                     --        <finalize statements>

                     Append_To (Var_Alts,
                       Make_Case_Statement_Alternative (Loc,
                         Discrete_Choices =>
                           New_Copy_List (Discrete_Choices (Var)),
                         Statements =>
                           Process_Component_List_For_Finalize (
                             Component_List (Var))));

                     Next_Non_Pragma (Var);
                  end loop;

                  --  Generate:
                  --     case V.<discriminant> is
                  --        when <discrete choices 1> =>
                  --           <finalize statements 1>
                  --        ...
                  --        when <discrete choices N> =>
                  --           <finalize statements N>
                  --     end case;

                  Var_Case :=
                    Make_Case_Statement (Loc,
                      Expression =>
                        Make_Selected_Component (Loc,
                          Prefix        => Make_Identifier (Loc, Name_V),
                          Selector_Name =>
                            Make_Identifier (Loc,
                              Chars => Chars (Name (Variant_Part (Comps))))),
                      Alternatives => Var_Alts);
               end;
            end if;

            --  The current component list does not have a single controlled
            --  component, however it may contain variants. Return the case
            --  statement for the variants or nothing.

            if Num_Comps = 0 then
               if Present (Var_Case) then
                  return New_List (Var_Case);
               else
                  return New_List (Make_Null_Statement (Loc));
               end if;
            end if;

            --  Prepare all lists

            Alts  := New_List;
            Decls := New_List;
            Stmts := New_List;

            --  Process all per-object constrained components in reverse order

            if Has_POC then
               Decl := Last_Non_Pragma (Component_Items (Comps));
               while Present (Decl) loop
                  Decl_Id  := Defining_Identifier (Decl);
                  Decl_Typ := Etype (Decl_Id);

                  --  Skip _parent

                  if Chars (Decl_Id) /= Name_uParent
                    and then Needs_Finalization (Decl_Typ)
                    and then Has_Access_Constraint (Decl_Id)
                    and then No (Expression (Decl))
                  then
                     Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
                  end if;

                  Prev_Non_Pragma (Decl);
               end loop;
            end if;

            --  Process the rest of the components in reverse order

            Decl := Last_Non_Pragma (Component_Items (Comps));
            while Present (Decl) loop
               Decl_Id  := Defining_Identifier (Decl);
               Decl_Typ := Etype (Decl_Id);

               --  Skip _parent

               if Chars (Decl_Id) /= Name_uParent
                 and then Needs_Finalization (Decl_Typ)
               then
                  --  Skip per-object constrained components since they were
                  --  handled in the above step.

                  if Has_Access_Constraint (Decl_Id)
                    and then No (Expression (Decl))
                  then
                     null;
                  else
                     Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
                  end if;
               end if;

               Prev_Non_Pragma (Decl);
            end loop;

            --  Generate:
            --    declare
            --       LN : label;        --  If Is_Local is enabled
            --       ...                    .
            --       L0 : label;            .

            --    begin                     .
            --       case CounterX is       .
            --          when N =>           .
            --             goto LN;         .
            --          ...                 .
            --          when 1 =>           .
            --             goto L1;         .
            --          when others =>      .
            --             goto L0;         .
            --       end case;              .

            --       <<LN>>             --  If Is_Local is enabled
            --          begin
            --             [Deep_]Finalize (V.CompY);
            --          exception
            --             when Id : others =>
            --                if not Raised then
            --                   Raised := True;
            --                   Save_Occurrence (E,
            --                     Get_Current_Excep.all.all);
            --                end if;
            --          end;
            --       ...
            --       <<L0>>  --  If Is_Local is enabled
            --    end;

            if Is_Local then

               --  Add the declaration of default jump location L0, its
               --  corresponding alternative and its place in the statements.

               Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
               Set_Entity (Label_Id,
                 Make_Defining_Identifier (Loc, Chars (Label_Id)));
               Label := Make_Label (Loc, Label_Id);

               Append_To (Decls,          --  declaration
                 Make_Implicit_Label_Declaration (Loc,
                   Defining_Identifier => Entity (Label_Id),
                   Label_Construct     => Label));

               Append_To (Alts,           --  alternative
                 Make_Case_Statement_Alternative (Loc,
                   Discrete_Choices => New_List (
                     Make_Others_Choice (Loc)),

                   Statements => New_List (
                     Make_Goto_Statement (Loc,
                       Name => New_Reference_To (Entity (Label_Id), Loc)))));

               Append_To (Stmts, Label);  --  statement

               --  Create the jump block

               Prepend_To (Stmts,
                 Make_Case_Statement (Loc,
                   Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
                   Alternatives => Alts));
            end if;

            Jump_Block :=
              Make_Block_Statement (Loc,
                Declarations               => Decls,
                Handled_Statement_Sequence =>
                  Make_Handled_Sequence_Of_Statements (Loc, Stmts));

            if Present (Var_Case) then
               return New_List (Var_Case, Jump_Block);
            else
               return New_List (Jump_Block);
            end if;
         end Process_Component_List_For_Finalize;

      --  Start of processing for Build_Finalize_Statements

      begin
         Finalizer_Decls := New_List;
         Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);

         if Nkind (Typ_Def) = N_Derived_Type_Definition then
            Rec_Def := Record_Extension_Part (Typ_Def);
         else
            Rec_Def := Typ_Def;
         end if;

         --  Create a finalization sequence for all record components

         if Present (Component_List (Rec_Def)) then
            Bod_Stmts :=
              Process_Component_List_For_Finalize (Component_List (Rec_Def));
         end if;

         --  A derived record type must finalize all inherited components. This
         --  action poses the following problem:

         --    procedure Deep_Finalize (Obj : in out Parent_Typ) is
         --    begin
         --       Finalize (Obj);
         --       ...

         --    procedure Deep_Finalize (Obj : in out Derived_Typ) is
         --    begin
         --       Deep_Finalize (Obj._parent);
         --       ...
         --       Finalize (Obj);
         --       ...

         --  Finalizing the derived type will invoke Finalize of the parent and
         --  then that of the derived type. This is undesirable because both
         --  routines may modify shared components. Only the Finalize of the
         --  derived type should be invoked.

         --  To prevent this double adjustment of shared components,
         --  Deep_Finalize uses a flag to control the invocation of Finalize:

         --    procedure Deep_Finalize
         --      (Obj  : in out Some_Type;
         --       Flag : Boolean := True)
         --    is
         --    begin
         --       if Flag then
         --          Finalize (Obj);
         --       end if;
         --       ...

         --  When Deep_Finalize is invokes for field _parent, a value of False
         --  is provided for the flag:

         --    Deep_Finalize (Obj._parent, False);

         if Is_Tagged_Type (Typ)
           and then Is_Derived_Type (Typ)
         then
            declare
               Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
               Call     : Node_Id;
               Fin_Stmt : Node_Id;

            begin
               if Needs_Finalization (Par_Typ) then
                  Call :=
                    Make_Final_Call
                      (Obj_Ref    =>
                         Make_Selected_Component (Loc,
                           Prefix        => Make_Identifier (Loc, Name_V),
                           Selector_Name =>
                             Make_Identifier (Loc, Name_uParent)),
                       Typ        => Par_Typ,
                       For_Parent => True);

                  --  Generate:
                  --    Deep_Finalize (V._parent, False);  --  No_Except_Propag

                  --    begin                              --  Exceptions OK
                  --       Deep_Finalize (V._parent, False);
                  --    exception
                  --       when Id : others =>
                  --          if not Raised then
                  --             Raised := True;
                  --             Save_Occurrence (E,
                  --               Get_Current_Excep.all.all);
                  --          end if;
                  --    end;

                  if Present (Call) then
                     Fin_Stmt := Call;

                     if Exceptions_OK then
                        Fin_Stmt :=
                          Make_Block_Statement (Loc,
                            Handled_Statement_Sequence =>
                              Make_Handled_Sequence_Of_Statements (Loc,
                                Statements         => New_List (Fin_Stmt),
                                Exception_Handlers => New_List (
                                  Build_Exception_Handler
                                    (Finalizer_Data))));
                     end if;

                     Append_To (Bod_Stmts, Fin_Stmt);
                  end if;
               end if;
            end;
         end if;

         --  Finalize the object. This action must be performed first before
         --  all components have been finalized.

         if Is_Controlled (Typ)
           and then not Is_Local
         then
            declare
               Fin_Stmt : Node_Id;
               Proc     : Entity_Id;

            begin
               Proc := Find_Prim_Op (Typ, Name_Finalize);

               --  Generate:
               --    if F then
               --       Finalize (V);  --  No_Exception_Propagation

               --       begin
               --          Finalize (V);
               --       exception
               --          when others =>
               --             if not Raised then
               --                Raised := True;
               --                Save_Occurrence (E,
               --                  Get_Current_Excep.all.all);
               --             end if;
               --       end;
               --    end if;

               if Present (Proc) then
                  Fin_Stmt :=
                    Make_Procedure_Call_Statement (Loc,
                      Name                   => New_Reference_To (Proc, Loc),
                      Parameter_Associations => New_List (
                        Make_Identifier (Loc, Name_V)));

                  if Exceptions_OK then
                     Fin_Stmt :=
                       Make_Block_Statement (Loc,
                         Handled_Statement_Sequence =>
                           Make_Handled_Sequence_Of_Statements (Loc,
                             Statements         => New_List (Fin_Stmt),
                             Exception_Handlers => New_List (
                               Build_Exception_Handler
                                 (Finalizer_Data))));
                  end if;

                  Prepend_To (Bod_Stmts,
                    Make_If_Statement (Loc,
                      Condition       => Make_Identifier (Loc, Name_F),
                      Then_Statements => New_List (Fin_Stmt)));
               end if;
            end;
         end if;

         --  At this point either all finalization statements have been
         --  generated or the type is not controlled.

         if No (Bod_Stmts) then
            return New_List (Make_Null_Statement (Loc));

         --  Generate:
         --    declare
         --       Abort  : constant Boolean := Triggered_By_Abort;
         --         <or>
         --       Abort  : constant Boolean := False;  --  no abort

         --       E      : Exception_Occurence;
         --       Raised : Boolean := False;

         --    begin
         --       <finalize statements>

         --       if Raised and then not Abort then
         --          Raise_From_Controlled_Operation (E);
         --       end if;
         --    end;

         else
            if Exceptions_OK then
               Append_To (Bod_Stmts,
                 Build_Raise_Statement (Finalizer_Data));
            end if;

            return
              New_List (
                Make_Block_Statement (Loc,
                  Declarations               =>
                    Finalizer_Decls,
                  Handled_Statement_Sequence =>
                    Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
         end if;
      end Build_Finalize_Statements;

      -----------------------
      -- Parent_Field_Type --
      -----------------------

      function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
         Field : Entity_Id;

      begin
         Field := First_Entity (Typ);
         while Present (Field) loop
            if Chars (Field) = Name_uParent then
               return Etype (Field);
            end if;

            Next_Entity (Field);
         end loop;

         --  A derived tagged type should always have a parent field

         raise Program_Error;
      end Parent_Field_Type;

      ---------------------------
      -- Preprocess_Components --
      ---------------------------

      procedure Preprocess_Components
        (Comps     : Node_Id;
         Num_Comps : out Int;
         Has_POC   : out Boolean)
      is
         Decl : Node_Id;
         Id   : Entity_Id;
         Typ  : Entity_Id;

      begin
         Num_Comps := 0;
         Has_POC   := False;

         Decl := First_Non_Pragma (Component_Items (Comps));
         while Present (Decl) loop
            Id  := Defining_Identifier (Decl);
            Typ := Etype (Id);

            --  Skip field _parent

            if Chars (Id) /= Name_uParent
              and then Needs_Finalization (Typ)
            then
               Num_Comps := Num_Comps + 1;

               if Has_Access_Constraint (Id)
                 and then No (Expression (Decl))
               then
                  Has_POC := True;
               end if;
            end if;

            Next_Non_Pragma (Decl);
         end loop;
      end Preprocess_Components;

   --  Start of processing for Make_Deep_Record_Body

   begin
      case Prim is
         when Address_Case =>
            return Make_Finalize_Address_Stmts (Typ);

         when Adjust_Case =>
            return Build_Adjust_Statements (Typ);

         when Finalize_Case =>
            return Build_Finalize_Statements (Typ);

         when Initialize_Case =>
            declare
               Loc : constant Source_Ptr := Sloc (Typ);

            begin
               if Is_Controlled (Typ) then
                  return New_List (
                    Make_Procedure_Call_Statement (Loc,
                      Name                   =>
                        New_Reference_To
                          (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
                      Parameter_Associations => New_List (
                        Make_Identifier (Loc, Name_V))));
               else
                  return Empty_List;
               end if;
            end;
      end case;
   end Make_Deep_Record_Body;

   ----------------------
   -- Make_Final_Call --
   ----------------------

   function Make_Final_Call
     (Obj_Ref    : Node_Id;
      Typ        : Entity_Id;
      For_Parent : Boolean := False) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Obj_Ref);
      Atyp   : Entity_Id;
      Fin_Id : Entity_Id := Empty;
      Ref    : Node_Id;
      Utyp   : Entity_Id;

   begin
      --  Recover the proper type which contains [Deep_]Finalize

      if Is_Class_Wide_Type (Typ) then
         Utyp := Root_Type (Typ);
         Atyp := Utyp;
         Ref  := Obj_Ref;

      elsif Is_Concurrent_Type (Typ) then
         Utyp := Corresponding_Record_Type (Typ);
         Atyp := Empty;
         Ref  := Convert_Concurrent (Obj_Ref, Typ);

      elsif Is_Private_Type (Typ)
        and then Present (Full_View (Typ))
        and then Is_Concurrent_Type (Full_View (Typ))
      then
         Utyp := Corresponding_Record_Type (Full_View (Typ));
         Atyp := Typ;
         Ref  := Convert_Concurrent (Obj_Ref, Full_View (Typ));

      else
         Utyp := Typ;
         Atyp := Typ;
         Ref  := Obj_Ref;
      end if;

      Utyp := Underlying_Type (Base_Type (Utyp));
      Set_Assignment_OK (Ref);

      --  Deal with non-tagged derivation of private views. If the parent type
      --  is a protected type, Deep_Finalize is found on the corresponding
      --  record of the ancestor.

      if Is_Untagged_Derivation (Typ) then
         if Is_Protected_Type (Typ) then
            Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
         else
            Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));

            if Is_Protected_Type (Utyp) then
               Utyp := Corresponding_Record_Type (Utyp);
            end if;
         end if;

         Ref := Unchecked_Convert_To (Utyp, Ref);
         Set_Assignment_OK (Ref);
      end if;

      --  Deal with derived private types which do not inherit primitives from
      --  their parents. In this case, [Deep_]Finalize can be found in the full
      --  view of the parent type.

      if Is_Tagged_Type (Utyp)
        and then Is_Derived_Type (Utyp)
        and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
        and then Is_Private_Type (Etype (Utyp))
        and then Present (Full_View (Etype (Utyp)))
      then
         Utyp := Full_View (Etype (Utyp));
         Ref  := Unchecked_Convert_To (Utyp, Ref);
         Set_Assignment_OK (Ref);
      end if;

      --  When dealing with the completion of a private type, use the base type
      --  instead.

      if Utyp /= Base_Type (Utyp) then
         pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));

         Utyp := Base_Type (Utyp);
         Ref  := Unchecked_Convert_To (Utyp, Ref);
         Set_Assignment_OK (Ref);
      end if;

      --  Select the appropriate version of Finalize

      if For_Parent then
         if Has_Controlled_Component (Utyp) then
            Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
         end if;

      --  Class-wide types, interfaces and types with controlled components

      elsif Is_Class_Wide_Type (Typ)
        or else Is_Interface (Typ)
        or else Has_Controlled_Component (Utyp)
      then
         if Is_Tagged_Type (Utyp) then
            Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
         else
            Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
         end if;

      --  Derivations from [Limited_]Controlled

      elsif Is_Controlled (Utyp) then
         if Has_Controlled_Component (Utyp) then
            Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
         else
            Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
         end if;

      --  Tagged types

      elsif Is_Tagged_Type (Utyp) then
         Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);

      else
         raise Program_Error;
      end if;

      if Present (Fin_Id) then

         --  When finalizing a class-wide object, do not convert to the root
         --  type in order to produce a dispatching call.

         if Is_Class_Wide_Type (Typ) then
            null;

         --  Ensure that a finalization routine is at least decorated in order
         --  to inspect the object parameter.

         elsif Analyzed (Fin_Id)
           or else Ekind (Fin_Id) = E_Procedure
         then
            --  In certain cases, such as the creation of Stream_Read, the
            --  visible entity of the type is its full view. Since Stream_Read
            --  will have to create an object of type Typ, the local object
            --  will be finalzed by the scope finalizer generated later on. The
            --  object parameter of Deep_Finalize will always use the private
            --  view of the type. To avoid such a clash between a private and a
            --  full view, perform an unchecked conversion of the object
            --  reference to the private view.

            declare
               Formal_Typ : constant Entity_Id :=
                              Etype (First_Formal (Fin_Id));
            begin
               if Is_Private_Type (Formal_Typ)
                 and then Present (Full_View (Formal_Typ))
                 and then Full_View (Formal_Typ) = Utyp
               then
                  Ref := Unchecked_Convert_To (Formal_Typ, Ref);
               end if;
            end;

            Ref := Convert_View (Fin_Id, Ref);
         end if;

         return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent);
      else
         return Empty;
      end if;
   end Make_Final_Call;

   --------------------------------
   -- Make_Finalize_Address_Body --
   --------------------------------

   procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
      Is_Task : constant Boolean :=
                  Ekind (Typ) = E_Record_Type
                    and then Is_Concurrent_Record_Type (Typ)
                    and then Ekind (Corresponding_Concurrent_Type (Typ)) =
                               E_Task_Type;
      Loc     : constant Source_Ptr := Sloc (Typ);
      Proc_Id : Entity_Id;
      Stmts   : List_Id;

   begin
      --  The corresponding records of task types are not controlled by design.
      --  For the sake of completeness, create an empty Finalize_Address to be
      --  used in task class-wide allocations.

      if Is_Task then
         null;

      --  Nothing to do if the type is not controlled or it already has a
      --  TSS entry for Finalize_Address. Skip class-wide subtypes which do not
      --  come from source. These are usually generated for completeness and
      --  do not need the Finalize_Address primitive.

      elsif not Needs_Finalization (Typ)
        or else Is_Abstract_Type (Typ)
        or else Present (TSS (Typ, TSS_Finalize_Address))
        or else
          (Is_Class_Wide_Type (Typ)
            and then Ekind (Root_Type (Typ)) = E_Record_Subtype
            and then not Comes_From_Source (Root_Type (Typ)))
      then
         return;
      end if;

      Proc_Id :=
        Make_Defining_Identifier (Loc,
          Make_TSS_Name (Typ, TSS_Finalize_Address));

      --  Generate:

      --    procedure <Typ>FD (V : System.Address) is
      --    begin
      --       null;                            --  for tasks

      --       declare                          --  for all other types
      --          type Pnn is access all Typ;
      --          for Pnn'Storage_Size use 0;
      --       begin
      --          [Deep_]Finalize (Pnn (V).all);
      --       end;
      --    end TypFD;

      if Is_Task then
         Stmts := New_List (Make_Null_Statement (Loc));
      else
         Stmts := Make_Finalize_Address_Stmts (Typ);
      end if;

      Discard_Node (
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Procedure_Specification (Loc,
              Defining_Unit_Name => Proc_Id,

              Parameter_Specifications => New_List (
                Make_Parameter_Specification (Loc,
                  Defining_Identifier =>
                    Make_Defining_Identifier (Loc, Name_V),
                  Parameter_Type =>
                    New_Reference_To (RTE (RE_Address), Loc)))),

          Declarations => No_List,

          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements => Stmts)));

      Set_TSS (Typ, Proc_Id);
   end Make_Finalize_Address_Body;

   ---------------------------------
   -- Make_Finalize_Address_Stmts --
   ---------------------------------

   function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
      Loc      : constant Source_Ptr := Sloc (Typ);
      Ptr_Typ  : constant Entity_Id  := Make_Temporary (Loc, 'P');
      Decls    : List_Id;
      Desg_Typ : Entity_Id;
      Obj_Expr : Node_Id;

   begin
      if Is_Array_Type (Typ) then
         if Is_Constrained (First_Subtype (Typ)) then
            Desg_Typ := First_Subtype (Typ);
         else
            Desg_Typ := Base_Type (Typ);
         end if;

      --  Class-wide types of constrained root types

      elsif Is_Class_Wide_Type (Typ)
        and then Has_Discriminants (Root_Type (Typ))
        and then not
          Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
      then
         declare
            Parent_Typ : Entity_Id;

         begin
            --  Climb the parent type chain looking for a non-constrained type

            Parent_Typ := Root_Type (Typ);
            while Parent_Typ /= Etype (Parent_Typ)
              and then Has_Discriminants (Parent_Typ)
              and then not
                Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
            loop
               Parent_Typ := Etype (Parent_Typ);
            end loop;

            --  Handle views created for tagged types with unknown
            --  discriminants.

            if Is_Underlying_Record_View (Parent_Typ) then
               Parent_Typ := Underlying_Record_View (Parent_Typ);
            end if;

            Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
         end;

      --  General case

      else
         Desg_Typ := Typ;
      end if;

      --  Generate:
      --    type Ptr_Typ is access all Typ;
      --    for Ptr_Typ'Storage_Size use 0;

      Decls := New_List (
        Make_Full_Type_Declaration (Loc,
          Defining_Identifier => Ptr_Typ,
          Type_Definition     =>
            Make_Access_To_Object_Definition (Loc,
              All_Present        => True,
              Subtype_Indication => New_Reference_To (Desg_Typ, Loc))),

        Make_Attribute_Definition_Clause (Loc,
          Name       => New_Reference_To (Ptr_Typ, Loc),
          Chars      => Name_Storage_Size,
          Expression => Make_Integer_Literal (Loc, 0)));

      Obj_Expr := Make_Identifier (Loc, Name_V);

      --  Unconstrained arrays require special processing in order to retrieve
      --  the elements. To achieve this, we have to skip the dope vector which
      --  lays in front of the elements and then use a thin pointer to perform
      --  the address-to-access conversion.

      if Is_Array_Type (Typ)
        and then not Is_Constrained (First_Subtype (Typ))
      then
         declare
            Dope_Id : Entity_Id;

         begin
            --  Ensure that Ptr_Typ a thin pointer, generate:
            --    for Ptr_Typ'Size use System.Address'Size;

            Append_To (Decls,
              Make_Attribute_Definition_Clause (Loc,
                Name       => New_Reference_To (Ptr_Typ, Loc),
                Chars      => Name_Size,
                Expression =>
                  Make_Integer_Literal (Loc, System_Address_Size)));

            --  Generate:
            --    Dnn : constant Storage_Offset :=
            --            Desg_Typ'Descriptor_Size / Storage_Unit;

            Dope_Id := Make_Temporary (Loc, 'D');

            Append_To (Decls,
              Make_Object_Declaration (Loc,
                Defining_Identifier => Dope_Id,
                Constant_Present    => True,
                Object_Definition   =>
                  New_Reference_To (RTE (RE_Storage_Offset), Loc),
                Expression          =>
                  Make_Op_Divide (Loc,
                    Left_Opnd  =>
                      Make_Attribute_Reference (Loc,
                        Prefix         => New_Reference_To (Desg_Typ, Loc),
                        Attribute_Name => Name_Descriptor_Size),
                    Right_Opnd =>
                      Make_Integer_Literal (Loc, System_Storage_Unit))));

            --  Shift the address from the start of the dope vector to the
            --  start of the elements:
            --
            --    V + Dnn
            --
            --  Note that this is done through a wrapper routine since RTSfind
            --  cannot retrieve operations with string names of the form "+".

            Obj_Expr :=
              Make_Function_Call (Loc,
                Name                   =>
                  New_Reference_To (RTE (RE_Add_Offset_To_Address), Loc),
                Parameter_Associations => New_List (
                  Obj_Expr,
                  New_Reference_To (Dope_Id, Loc)));
         end;
      end if;

      --  Create the block and the finalization call

      return New_List (
        Make_Block_Statement (Loc,
          Declarations => Decls,

          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements => New_List (
                Make_Final_Call (
                  Obj_Ref =>
                    Make_Explicit_Dereference (Loc,
                      Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
                  Typ => Desg_Typ)))));
   end Make_Finalize_Address_Stmts;

   -------------------------------------
   -- Make_Handler_For_Ctrl_Operation --
   -------------------------------------

   --  Generate:

   --    when E : others =>
   --      Raise_From_Controlled_Operation (E);

   --  or:

   --    when others =>
   --      raise Program_Error [finalize raised exception];

   --  depending on whether Raise_From_Controlled_Operation is available

   function Make_Handler_For_Ctrl_Operation
     (Loc : Source_Ptr) return Node_Id
   is
      E_Occ : Entity_Id;
      --  Choice parameter (for the first case above)

      Raise_Node : Node_Id;
      --  Procedure call or raise statement

   begin
      --  Standard run-time, .NET/JVM targets: add choice parameter E and pass
      --  it to Raise_From_Controlled_Operation so that the original exception
      --  name and message can be recorded in the exception message for
      --  Program_Error.

      if RTE_Available (RE_Raise_From_Controlled_Operation) then
         E_Occ := Make_Defining_Identifier (Loc, Name_E);
         Raise_Node :=
           Make_Procedure_Call_Statement (Loc,
             Name                   =>
               New_Reference_To
                 (RTE (RE_Raise_From_Controlled_Operation), Loc),
             Parameter_Associations => New_List (
               New_Reference_To (E_Occ, Loc)));

      --  Restricted run-time: exception messages are not supported

      else
         E_Occ := Empty;
         Raise_Node :=
           Make_Raise_Program_Error (Loc,
             Reason => PE_Finalize_Raised_Exception);
      end if;

      return
        Make_Implicit_Exception_Handler (Loc,
          Exception_Choices => New_List (Make_Others_Choice (Loc)),
          Choice_Parameter  => E_Occ,
          Statements        => New_List (Raise_Node));
   end Make_Handler_For_Ctrl_Operation;

   --------------------
   -- Make_Init_Call --
   --------------------

   function Make_Init_Call
     (Obj_Ref : Node_Id;
      Typ     : Entity_Id) return Node_Id
   is
      Loc     : constant Source_Ptr := Sloc (Obj_Ref);
      Is_Conc : Boolean;
      Proc    : Entity_Id;
      Ref     : Node_Id;
      Utyp    : Entity_Id;

   begin
      --  Deal with the type and object reference. Depending on the context, an
      --  object reference may need several conversions.

      if Is_Concurrent_Type (Typ) then
         Is_Conc := True;
         Utyp    := Corresponding_Record_Type (Typ);
         Ref     := Convert_Concurrent (Obj_Ref, Typ);

      elsif Is_Private_Type (Typ)
        and then Present (Full_View (Typ))
        and then Is_Concurrent_Type (Underlying_Type (Typ))
      then
         Is_Conc := True;
         Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
         Ref     := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));

      else
         Is_Conc := False;
         Utyp    := Typ;
         Ref     := Obj_Ref;
      end if;

      Set_Assignment_OK (Ref);

      Utyp := Underlying_Type (Base_Type (Utyp));

      --  Deal with non-tagged derivation of private views

      if Is_Untagged_Derivation (Typ)
        and then not Is_Conc
      then
         Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
         Ref  := Unchecked_Convert_To (Utyp, Ref);

         --  The following is to prevent problems with UC see 1.156 RH ???

         Set_Assignment_OK (Ref);
      end if;

      --  If the underlying_type is a subtype, then we are dealing with the
      --  completion of a private type. We need to access the base type and
      --  generate a conversion to it.

      if Utyp /= Base_Type (Utyp) then
         pragma Assert (Is_Private_Type (Typ));
         Utyp := Base_Type (Utyp);
         Ref  := Unchecked_Convert_To (Utyp, Ref);
      end if;

      --  Select the appropriate version of initialize

      if Has_Controlled_Component (Utyp) then
         Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
      else
         Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
         Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
      end if;

      --  The object reference may need another conversion depending on the
      --  type of the formal and that of the actual.

      Ref := Convert_View (Proc, Ref);

      --  Generate:
      --    [Deep_]Initialize (Ref);

      return
        Make_Procedure_Call_Statement (Loc,
          Name =>
            New_Reference_To (Proc, Loc),
          Parameter_Associations => New_List (Ref));
   end Make_Init_Call;

   ------------------------------
   -- Make_Local_Deep_Finalize --
   ------------------------------

   function Make_Local_Deep_Finalize
     (Typ : Entity_Id;
      Nam : Entity_Id) return Node_Id
   is
      Loc : constant Source_Ptr := Sloc (Typ);
      Formals : List_Id;

   begin
      Formals := New_List (

         --  V : in out Typ

        Make_Parameter_Specification (Loc,
          Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
          In_Present          => True,
          Out_Present         => True,
          Parameter_Type      => New_Reference_To (Typ, Loc)),

         --  F : Boolean := True

        Make_Parameter_Specification (Loc,
          Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
          Parameter_Type      => New_Reference_To (Standard_Boolean, Loc),
          Expression          => New_Reference_To (Standard_True, Loc)));

      --  Add the necessary number of counters to represent the initialization
      --  state of an object.

      return
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Procedure_Specification (Loc,
              Defining_Unit_Name       => Nam,
              Parameter_Specifications => Formals),

          Declarations => No_List,

          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
   end Make_Local_Deep_Finalize;

   ------------------------------------
   -- Make_Set_Finalize_Address_Call --
   ------------------------------------

   function Make_Set_Finalize_Address_Call
     (Loc     : Source_Ptr;
      Typ     : Entity_Id;
      Ptr_Typ : Entity_Id) return Node_Id
   is
      Desig_Typ   : constant Entity_Id :=
                      Available_View (Designated_Type (Ptr_Typ));
      Fin_Mas_Id  : constant Entity_Id := Finalization_Master (Ptr_Typ);
      Fin_Mas_Ref : Node_Id;
      Utyp        : Entity_Id;

   begin
      --  If the context is a class-wide allocator, we use the class-wide type
      --  to obtain the proper Finalize_Address routine.

      if Is_Class_Wide_Type (Desig_Typ) then
         Utyp := Desig_Typ;

      else
         Utyp := Typ;

         if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
            Utyp := Full_View (Utyp);
         end if;

         if Is_Concurrent_Type (Utyp) then
            Utyp := Corresponding_Record_Type (Utyp);
         end if;
      end if;

      Utyp := Underlying_Type (Base_Type (Utyp));

      --  Deal with non-tagged derivation of private views. If the parent is
      --  now known to be protected, the finalization routine is the one
      --  defined on the corresponding record of the ancestor (corresponding
      --  records do not automatically inherit operations, but maybe they
      --  should???)

      if Is_Untagged_Derivation (Typ) then
         if Is_Protected_Type (Typ) then
            Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
         else
            Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));

            if Is_Protected_Type (Utyp) then
               Utyp := Corresponding_Record_Type (Utyp);
            end if;
         end if;
      end if;

      --  If the underlying_type is a subtype, we are dealing with the
      --  completion of a private type. We need to access the base type and
      --  generate a conversion to it.

      if Utyp /= Base_Type (Utyp) then
         pragma Assert (Is_Private_Type (Typ));

         Utyp := Base_Type (Utyp);
      end if;

      Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc);

      --  If the call is from a build-in-place function, the Master parameter
      --  is actually a pointer. Dereference it for the call.

      if Is_Access_Type (Etype (Fin_Mas_Id)) then
         Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref);
      end if;

      --  Generate:
      --    Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);

      return
        Make_Procedure_Call_Statement (Loc,
          Name                   =>
            New_Reference_To (RTE (RE_Set_Finalize_Address), Loc),
          Parameter_Associations => New_List (
            Fin_Mas_Ref,
            Make_Attribute_Reference (Loc,
              Prefix         =>
                New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
              Attribute_Name => Name_Unrestricted_Access)));
   end Make_Set_Finalize_Address_Call;

   --------------------------
   -- Make_Transient_Block --
   --------------------------

   function Make_Transient_Block
     (Loc    : Source_Ptr;
      Action : Node_Id;
      Par    : Node_Id) return Node_Id
   is
      Decls  : constant List_Id := New_List;
      Instrs : constant List_Id := New_List (Action);
      Block  : Node_Id;
      Insert : Node_Id;

   begin
      --  Case where only secondary stack use is involved

      if VM_Target = No_VM
        and then Uses_Sec_Stack (Current_Scope)
        and then Nkind (Action) /= N_Simple_Return_Statement
        and then Nkind (Par) /= N_Exception_Handler
      then
         declare
            S : Entity_Id;

         begin
            S := Scope (Current_Scope);
            loop
               --  At the outer level, no need to release the sec stack

               if S = Standard_Standard then
                  Set_Uses_Sec_Stack (Current_Scope, False);
                  exit;

               --  In a function, only release the sec stack if the function
               --  does not return on the sec stack otherwise the result may
               --  be lost. The caller is responsible for releasing.

               elsif Ekind (S) = E_Function then
                  Set_Uses_Sec_Stack (Current_Scope, False);

                  if not Requires_Transient_Scope (Etype (S)) then
                     Set_Uses_Sec_Stack (S, True);
                     Check_Restriction (No_Secondary_Stack, Action);
                  end if;

                  exit;

               --  In a loop or entry we should install a block encompassing
               --  all the construct. For now just release right away.

               elsif Ekind_In (S, E_Entry, E_Loop) then
                  exit;

               --  In a procedure or a block, we release on exit of the
               --  procedure or block. ??? memory leak can be created by
               --  recursive calls.

               elsif Ekind_In (S, E_Block, E_Procedure) then
                  Set_Uses_Sec_Stack (S, True);
                  Check_Restriction (No_Secondary_Stack, Action);
                  Set_Uses_Sec_Stack (Current_Scope, False);
                  exit;

               else
                  S := Scope (S);
               end if;
            end loop;
         end;
      end if;

      --  Create the transient block. Set the parent now since the block itself
      --  is not part of the tree.

      Block :=
        Make_Block_Statement (Loc,
          Identifier                 => New_Reference_To (Current_Scope, Loc),
          Declarations               => Decls,
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
          Has_Created_Identifier     => True);
      Set_Parent (Block, Par);

      --  Insert actions stuck in the transient scopes as well as all freezing
      --  nodes needed by those actions.

      Insert_Actions_In_Scope_Around (Action);

      Insert := Prev (Action);
      if Present (Insert) then
         Freeze_All (First_Entity (Current_Scope), Insert);
      end if;

      --  When the transient scope was established, we pushed the entry for the
      --  transient scope onto the scope stack, so that the scope was active
      --  for the installation of finalizable entities etc. Now we must remove
      --  this entry, since we have constructed a proper block.

      Pop_Scope;

      return Block;
   end Make_Transient_Block;

   ------------------------
   -- Node_To_Be_Wrapped --
   ------------------------

   function Node_To_Be_Wrapped return Node_Id is
   begin
      return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
   end Node_To_Be_Wrapped;

   ----------------------------
   -- Set_Node_To_Be_Wrapped --
   ----------------------------

   procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
   begin
      Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
   end Set_Node_To_Be_Wrapped;

   ----------------------------------
   -- Store_After_Actions_In_Scope --
   ----------------------------------

   procedure Store_After_Actions_In_Scope (L : List_Id) is
      SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);

   begin
      if Present (SE.Actions_To_Be_Wrapped_After) then
         Insert_List_Before_And_Analyze (
          First (SE.Actions_To_Be_Wrapped_After), L);

      else
         SE.Actions_To_Be_Wrapped_After := L;

         if Is_List_Member (SE.Node_To_Be_Wrapped) then
            Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
         else
            Set_Parent (L, SE.Node_To_Be_Wrapped);
         end if;

         Analyze_List (L);
      end if;
   end Store_After_Actions_In_Scope;

   -----------------------------------
   -- Store_Before_Actions_In_Scope --
   -----------------------------------

   procedure Store_Before_Actions_In_Scope (L : List_Id) is
      SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);

   begin
      if Present (SE.Actions_To_Be_Wrapped_Before) then
         Insert_List_After_And_Analyze (
           Last (SE.Actions_To_Be_Wrapped_Before), L);

      else
         SE.Actions_To_Be_Wrapped_Before := L;

         if Is_List_Member (SE.Node_To_Be_Wrapped) then
            Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
         else
            Set_Parent (L, SE.Node_To_Be_Wrapped);
         end if;

         Analyze_List (L);
      end if;
   end Store_Before_Actions_In_Scope;

   --------------------------------
   -- Wrap_Transient_Declaration --
   --------------------------------

   --  If a transient scope has been established during the processing of the
   --  Expression of an Object_Declaration, it is not possible to wrap the
   --  declaration into a transient block as usual case, otherwise the object
   --  would be itself declared in the wrong scope. Therefore, all entities (if
   --  any) defined in the transient block are moved to the proper enclosing
   --  scope, furthermore, if they are controlled variables they are finalized
   --  right after the declaration. The finalization list of the transient
   --  scope is defined as a renaming of the enclosing one so during their
   --  initialization they will be attached to the proper finalization list.
   --  For instance, the following declaration :

   --        X : Typ := F (G (A), G (B));

   --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
   --  is expanded into :

   --    X : Typ := [ complex Expression-Action ];
   --    [Deep_]Finalize (_v1);
   --    [Deep_]Finalize (_v2);

   procedure Wrap_Transient_Declaration (N : Node_Id) is
      Encl_S  : Entity_Id;
      S       : Entity_Id;
      Uses_SS : Boolean;

   begin
      S := Current_Scope;
      Encl_S := Scope (S);

      --  Insert Actions kept in the Scope stack

      Insert_Actions_In_Scope_Around (N);

      --  If the declaration is consuming some secondary stack, mark the
      --  enclosing scope appropriately.

      Uses_SS := Uses_Sec_Stack (S);
      Pop_Scope;

      --  Put the local entities back in the enclosing scope, and set the
      --  Is_Public flag appropriately.

      Transfer_Entities (S, Encl_S);

      --  Mark the enclosing dynamic scope so that the sec stack will be
      --  released upon its exit unless this is a function that returns on
      --  the sec stack in which case this will be done by the caller.

      if VM_Target = No_VM and then Uses_SS then
         S := Enclosing_Dynamic_Scope (S);

         if Ekind (S) = E_Function
           and then Requires_Transient_Scope (Etype (S))
         then
            null;
         else
            Set_Uses_Sec_Stack (S);
            Check_Restriction (No_Secondary_Stack, N);
         end if;
      end if;
   end Wrap_Transient_Declaration;

   -------------------------------
   -- Wrap_Transient_Expression --
   -------------------------------

   procedure Wrap_Transient_Expression (N : Node_Id) is
      Expr : constant Node_Id    := Relocate_Node (N);
      Loc  : constant Source_Ptr := Sloc (N);
      Temp : constant Entity_Id  := Make_Temporary (Loc, 'E', N);
      Typ  : constant Entity_Id  := Etype (N);

   begin
      --  Generate:

      --    Temp : Typ;
      --    declare
      --       M : constant Mark_Id := SS_Mark;
      --       procedure Finalizer is ...  (See Build_Finalizer)

      --    begin
      --       Temp := <Expr>;
      --
      --    at end
      --       Finalizer;
      --    end;

      Insert_Actions (N, New_List (
        Make_Object_Declaration (Loc,
          Defining_Identifier => Temp,
          Object_Definition   => New_Reference_To (Typ, Loc)),

        Make_Transient_Block (Loc,
          Action =>
            Make_Assignment_Statement (Loc,
              Name       => New_Reference_To (Temp, Loc),
              Expression => Expr),
          Par    => Parent (N))));

      Rewrite (N, New_Reference_To (Temp, Loc));
      Analyze_And_Resolve (N, Typ);
   end Wrap_Transient_Expression;

   ------------------------------
   -- Wrap_Transient_Statement --
   ------------------------------

   procedure Wrap_Transient_Statement (N : Node_Id) is
      Loc      : constant Source_Ptr := Sloc (N);
      New_Stmt : constant Node_Id    := Relocate_Node (N);

   begin
      --  Generate:
      --    declare
      --       M : constant Mark_Id := SS_Mark;
      --       procedure Finalizer is ...  (See Build_Finalizer)
      --
      --    begin
      --       <New_Stmt>;
      --
      --    at end
      --       Finalizer;
      --    end;

      Rewrite (N,
        Make_Transient_Block (Loc,
          Action => New_Stmt,
          Par    => Parent (N)));

      --  With the scope stack back to normal, we can call analyze on the
      --  resulting block. At this point, the transient scope is being
      --  treated like a perfectly normal scope, so there is nothing
      --  special about it.

      --  Note: Wrap_Transient_Statement is called with the node already
      --  analyzed (i.e. Analyzed (N) is True). This is important, since
      --  otherwise we would get a recursive processing of the node when
      --  we do this Analyze call.

      Analyze (N);
   end Wrap_Transient_Statement;

end Exp_Ch7;