Subversion Repositories scarts

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 7                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2005, 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 2,  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 COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- 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 Errout;   use Errout;

with Exp_Ch9;  use Exp_Ch9;

with Exp_Ch11; use Exp_Ch11;

with Exp_Dbug; use Exp_Dbug;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Freeze;   use Freeze;

with Hostparm; use Hostparm;

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 Targparm; use Targparm;

with Sinfo;    use Sinfo;

with Sem;      use Sem;

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_Type; use Sem_Type;

with Sem_Util; use Sem_Util;

with Snames;   use Snames;

with Stand;    use Stand;

with Tbuild;   use Tbuild;

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 function returning tagged types: It has been decided to

   --  always allocate their result in the secondary stack while it 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. But, allocating them always in the

   --  secondary stack simplifies many implementation hassles:

   --    - If it is 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 little loss in efficiency which is the result of this

   --  decision is not such a big deal because function returning tagged types

   --  are not very much used in real life as opposed 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 wich may generate a transient scope. Loop over the

   --  parent pointers of N until it find the appropriate node to

   --  wrap. It it returns Empty, it means that no transient scope is

   --  needed in this context.

   function Make_Clean

     (N                          : Node_Id;

      Clean                      : Entity_Id;

      Mark                       : Entity_Id;

      Flist                      : Entity_Id;

      Is_Task                    : Boolean;

      Is_Master                  : Boolean;

      Is_Protected_Subprogram    : Boolean;

      Is_Task_Allocation_Block   : Boolean;

      Is_Asynchronous_Call_Block : Boolean) return Node_Id;

   --  Expand a the clean-up procedure for controlled and/or transient

   --  block, and/or task master or task body, or blocks used to

   --  implement task allocation or asynchronous entry calls, or

   --  procedures used to implement protected procedures. Clean is the

   --  entity for such a procedure. Mark is the entity for the secondary

   --  stack mark, if empty only controlled block clean-up will be

   --  performed. Flist is the entity for the local final list, if empty

   --  only transient scope clean-up will be performed. The flags

   --  Is_Task and Is_Master control the calls to the corresponding

   --  finalization actions for a task body or for an entity that is a

   --  task master.

   procedure Set_Node_To_Be_Wrapped (N : Node_Id);

   --  Set the field Node_To_Be_Wrapped of the current scope

   procedure Insert_Actions_In_Scope_Around (N : Node_Id);

   --  Insert the before-actions kept in the scope stack before N, and the

   --  after after-actions, after N which must be a member of a list.

   function Make_Transient_Block

     (Loc    : Source_Ptr;

      Action : Node_Id) return Node_Id;

   --  Create a transient block whose name is Scope, which is also a

   --  controlled block if Flist is not empty and whose only code is

   --  Action (either a single statement or single declaration).

   type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_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);

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

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

   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 an 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.

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

   -- Finalization Management --

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

   --  This part describe how Initialization/Adjusment/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 adusting 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.

   --    - 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 : Record_Controller;

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

   function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean;

   --  Return True if Flist_Ref refers to a global final list, either

   --  the object GLobal_Final_List which is used to attach standalone

   --  objects, or any of the list controllers associated with library

   --  level access to controlled objects

   procedure Clean_Simple_Protected_Objects (N : Node_Id);

   --  Protected objects without entries are not controlled types, and the

   --  locks have to be released explicitly when such an object goes out

   --  of scope. Traverse declarations in scope to determine whether such

   --  objects are present.

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

   -- 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_Return_By_Reference_Type (Typ) then

         Set_TSS (Typ,

           Make_Deep_Proc (

             Prim  => Adjust_Case,

             Typ   => Typ,

             Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));

      end if;

      Set_TSS (Typ,

        Make_Deep_Proc (

          Prim  => Finalize_Case,

          Typ   => Typ,

          Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));

   end Build_Array_Deep_Procs;

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

   -- 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_Final_List --

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

   procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is

      Loc  : constant Source_Ptr := Sloc (N);

      Decl : Node_Id;

   begin

      Set_Associated_Final_Chain (Typ,

        Make_Defining_Identifier (Loc,

          New_External_Name (Chars (Typ), 'L')));

      Decl :=

        Make_Object_Declaration (Loc,

          Defining_Identifier =>

             Associated_Final_Chain (Typ),

          Object_Definition   =>

            New_Reference_To

              (RTE (RE_List_Controller), Loc));

      --  The type may have been frozen already, and this is a late freezing

      --  action, in which case the declaration must be elaborated at once.

      --  If the call is for an allocator, the chain must also be created now,

      --  because the freezing of the type does not build one. Otherwise, the

      --  declaration is one of the freezing actions for a user-defined type.

      if Is_Frozen (Typ)

        or else (Nkind (N) = N_Allocator

                  and then Ekind (Etype (N)) = E_Anonymous_Access_Type)

      then

         Insert_Action (N, Decl);

      else

         Append_Freeze_Action (Typ, Decl);

      end if;

   end Build_Final_List;

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

   -- 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_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_Return_By_Reference_Type (Typ) then

         Set_TSS (Typ,

           Make_Deep_Proc (

             Prim  => Adjust_Case,

             Typ   => Typ,

             Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));

      end if;

      Set_TSS (Typ,

        Make_Deep_Proc (

          Prim  => Finalize_Case,

          Typ   => Typ,

          Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));

   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_Defining_Identifier (Loc, New_Internal_Name ('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

      return

        Make_Procedure_Call_Statement (Loc,

          Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),

          Parameter_Associations => New_List (

            Concurrent_Ref (Ref)));

   end Cleanup_Protected_Object;

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

   -- Clean_Simple_Protected_Objects --

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

   procedure Clean_Simple_Protected_Objects (N : Node_Id) is

      Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N));

      Stmt  : Node_Id          := Last (Stmts);

      E     : Entity_Id;

   begin

      E := First_Entity (Current_Scope);

      while Present (E) loop

         if (Ekind (E) = E_Variable

              or else Ekind (E) = E_Constant)

           and then Has_Simple_Protected_Object (Etype (E))

           and then not Has_Task (Etype (E))

           and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration

         then

            declare

               Typ : constant Entity_Id := Etype (E);

               Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt));

            begin

               if Is_Simple_Protected_Type (Typ) then

                  Append_To (Stmts, Cleanup_Protected_Object (N, Ref));

               elsif Has_Simple_Protected_Object (Typ) then

                  if Is_Record_Type (Typ) then

                     Append_List_To (Stmts, Cleanup_Record (N, Ref, Typ));

                  elsif Is_Array_Type (Typ) then

                     Append_List_To (Stmts, Cleanup_Array (N, Ref, Typ));

                  end if;

               end if;

            end;

         end if;

         Next_Entity (E);

      end loop;

      --   Analyze inserted cleanup statements

      if Present (Stmt) then

         Stmt := Next (Stmt);

         while Present (Stmt) loop

            Analyze (Stmt);

            Next (Stmt);

         end loop;

      end if;

   end Clean_Simple_Protected_Objects;

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

   -- Cleanup_Task --

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

   function Cleanup_Task

     (N   : Node_Id;

      Ref : Node_Id) return Node_Id

   is

      Loc  : constant Source_Ptr := Sloc (N);

   begin

      return

        Make_Procedure_Call_Statement (Loc,

          Name => New_Reference_To (RTE (RE_Free_Task), Loc),

          Parameter_Associations =>

            New_List (Concurrent_Ref (Ref)));

   end Cleanup_Task;

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

   -- Has_Simple_Protected_Object --

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

   function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is

      Comp : Entity_Id;

   begin

      if 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

         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;

      else

         return False;

      end if;

   end Has_Simple_Protected_Object;

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

   -- Is_Simple_Protected_Type --

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

   function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is