Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         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);